phys/module_sf_ruclsm.F

   1 #define lsmruc_dbg_lvl 3000
   2 !wrf:model_layer:physics
   3 !
   4 module module_sf_ruclsm
   5
   6 ! notes for perturbations of soil properties (judith berner)
   7 ! perturbations are applied in subroutine soilprob to array hydro;
   8 ! soilprop is called from subroutine sfctmp which is called from subroutine lsmruc;
   9 ! subroutine lsmruc had two new 3d fields: pattern_spp_lsm (in) and field_sf(inout);
  10 !    their vertical dimension is number of atmospheric levels (kms:kme) - (suboptimal, but easiest hack)
  11 !    field_sf is used to pass perturbed fields of hydrop up to model (and output) driver;
  12 ! in argument list to sfctmp the arrays are passed as pattern_spp_lsm(i,1:nzs,j), and exist henceforth as
  13 ! column arrays;
  14 ! in the subroutines below sfctmp (snow and snowsoil) the fields are called rstochcol,fieldcol_sf
  15 ! to reflect their dimension rstochcol (1:nzs)
  16
  17
  18   use module_model_constants
  19   use module_wrf_error
  20
  21 ! vegetation parameters
  22         integer :: lucats , bare, natural, crop, urban
  23         integer, parameter :: nlus=50
  24         character*8 lutype
  25         integer, dimension(1:nlus) :: ifortbl
  26         real, dimension(1:nlus) ::  snuptbl, rstbl, rgltbl, hstbl, laitbl,         &
  27                                     albtbl, z0tbl, lemitbl, pctbl, shdtbl, maxalb
  28         real ::   topt_data,cmcmax_data,cfactr_data,rsmax_data
  29 ! soil parameters
  30         integer :: slcats
  31         integer, parameter :: nsltype=30
  32         character*8 sltype
  33         real, dimension (1:nsltype) :: bb,drysmc,hc,                           &
  34         maxsmc, refsmc,satpsi,satdk,satdw, wltsmc,qtz
  35
  36 ! lsm general parameters
  37         integer :: slpcats
  38         integer, parameter :: nslope=30
  39         real, dimension (1:nslope) :: slope_data
  40         real ::  sbeta_data,fxexp_data,csoil_data,salp_data,refdk_data,           &
  41                  refkdt_data,frzk_data,zbot_data,  smlow_data,smhigh_data,        &
  42                         czil_data
  43
  44         character*256  :: err_message
  45
  46       !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997
  47       !   integer, parameter :: isncond_opt = 1
  48       !
  49         integer, parameter :: isncond_opt=2
  50
  51       !-- Snow fraction options
  52       !-- option 1: original formulation using threshold snow depth to compute snow fraction
  53       !integer, parameter :: isncovr_opt = 1 (default)
  54       !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674.
  55       !integer, parameter :: isncovr_opt = 2
  56       !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with
  57       !   vegetation-dependent parameters from Noah MP (personal communication with
  58       !   Mike Barlage)
  59       !integer, parameter :: isncovr_opt = 3
  60       !-- Values of parameters are scale-dependent, have to be tuned for a given application
  61       !-- Tables below are for 21-class MODI-RUC (MODIFIED_IGBP_MODIS_NOAH_15s is used in HRRR and RRFS)
  62       !-- for 3-km RRFS application
  63         real, dimension(30), parameter ::        sncovfac =     &
  64      &                    (/ 0.030, 0.030, 0.030, 0.030, 0.030, &
  65      &                       0.016, 0.016, 0.020, 0.020, 0.020, &
  66      &                       0.020, 0.014, 0.042, 0.026, 0.030, &
  67      &                       0.016, 0.030, 0.030, 0.030, 0.030, &
  68      &                       0.000, 0.000, 0.000, 0.000, 0.000, &
  69      &                       0.000, 0.000, 0.000, 0.000, 0.000 /)
  70        real, dimension(30), parameter ::         mfsno =        &
  71      &                  (/  1.00, 1.00, 1.00, 1.00, 2.00, 2.00, &
  72      &                      2.00, 2.00, 2.00, 2.00, 2.00, 2.00, &
  73      &                      3.00, 3.00, 2.00, 2.00, 2.00, 2.00, &
  74      &                      2.00, 2.00, 0.00, 0.00, 0.00, 0.00, &
  75      &                      0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /)
  76
  77       !--
  78         integer, parameter :: isncovr_opt=2
  79       !--
  80
  81 contains
  82
  83 !-----------------------------------------------------------------
  84     subroutine lsmruc(spp_lsm,                                   &
  85 #if (EM_CORE==1)
  86                    pattern_spp_lsm,field_sf,                     &
  87 #endif
  88                    dt,ktau,nsl,                                  &
  89 #if (EM_CORE==1)
  90                    lakemodel,lakemask,                           &
  91                    graupelncv,snowncv,rainncv,                   &
  92 #endif
  93                    zs,rainbl,snow,snowh,snowc,frzfrac,frpcpn,    &
  94                    rhosnf,precipfr,                              & ! pass it out to module_diagnostics
  95                    z3d,p8w,t3d,qv3d,qc3d,rho3d,                  & !p8w in [pa]
  96                    glw,gsw,emiss,chklowq, chs,                   &
  97                    flqc,flhc,mavail,canwat,vegfra,alb,znt,       &
  98                    z0,snoalb,albbck,lai,                         &  !new
  99                    mminlu, landusef, nlcat, mosaic_lu,           &
 100                    mosaic_soil, soilctop, nscat,                 &  !new
 101                    qsfc,qsg,qvg,qcg,dew,soilt1,tsnav,            &
 102                    tbot,ivgtyp,isltyp,xland,                     &
 103                    iswater,isice,xice,xice_threshold,            &
 104                    cp,rovcp,g0,lv,stbolt,                        &
 105                    soilmois,sh2o,smavail,smmax,                  &
 106                    tso,soilt,hfx,qfx,lh,                         &
 107                    sfcrunoff,udrunoff,acrunoff,sfcexc,           &
 108                    sfcevp,grdflx,snowfallac,acsnow,snom,         &
 109                    smfr3d,keepfr3dflag,                          &
 110                    myj,shdmin,shdmax,rdlai2d,                    &
 111                    ids,ide, jds,jde, kds,kde,                    &
 112                    ims,ime, jms,jme, kms,kme,                    &
 113                    its,ite, jts,jte, kts,kte                     )
 114 !-----------------------------------------------------------------
 115    implicit none
 116 !-----------------------------------------------------------------
 117 !
 118 ! the ruc lsm model is described in:
 119 !  Smirnova, T.G., J.M. Brown, and S.G. Benjamin, 1997:
 120 !     performance of different soil model configurations in simulating
 121 !     ground surface temperature and surface fluxes.
 122 !     mon. wea. rev. 125, 1870-1884.
 123 !  Smirnova, T.G., J.M. Brown, and D. Kim, 2000: parameterization of
 124 !     cold-season processes in the maps land-surface scheme.
 125 !     j. geophys. res. 105, 4077-4086.
 126 !-----------------------------------------------------------------
 127 !-- dt            time step (second)
 128 !        ktau - number of time step
 129 !        nsl  - number of soil layers
 130 !        nzs  - number of levels in soil
 131 !        zs   - depth of soil levels (m)
 132 !-- rainbl    - accumulated rain in [mm] between the pbl calls
 133 !-- rainncv         one time step grid scale precipitation (mm/step)
 134 !        snow - snow water equivalent [mm]
 135 !        frazfrac - fraction of frozen precipitation
 136 !-- precipfr (mm) - time step frozen precipitation
 137 !-- snowc       flag indicating snow coverage (1 for snow cover)
 138 !-- z3d         heights (m)
 139 !-- p8w         3d pressure (pa)
 140 !-- t3d         temperature (k)
 141 !-- qv3d        3d water vapor mixing ratio (kg/kg)
 142 !        qc3d - 3d cloud water mixing ratio (kg/kg)
 143 !       rho3d - 3d air density (kg/m^3)
 144 !-- glw         downward long wave flux at ground surface (w/m^2)
 145 !-- gsw         absorbed short wave flux at ground surface (w/m^2)
 146 !-- emiss       surface emissivity (between 0 and 1)
 147 !        flqc - surface exchange coefficient for moisture (kg/m^2/s)
 148 !        flhc - surface exchange coefficient for heat [w/m^2/s/degreek]
 149 !      sfcexc - surface exchange coefficient for heat [m/s]
 150 !      canwat - canopy moisture content (mm)
 151 !      vegfra - vegetation fraction (between 0 and 100)
 152 !         alb - surface albedo (between 0 and 1)
 153 !      snoalb - maximum snow albedo (between 0 and 1)
 154 !      albbck - snow-free albedo (between 0 and 1)
 155 !         znt - roughness length [m]
 156 !-- tbot        soil temperature at lower boundary (k)
 157 !      ivgtyp - usgs vegetation type (24 classes)
 158 !      isltyp - stasgo soil type (16 classes)
 159 !-- xland       land mask (1 for land, 2 for water)
 160 !-- cp          heat capacity at constant pressure for dry air (j/kg/k)
 161 !-- g0          acceleration due to gravity (m/s^2)
 162 !-- lv          latent heat of melting (j/kg)
 163 !-- stbolt      stefan-boltzmann constant (w/m^2/k^4)
 164 !    soilmois - soil moisture content (volumetric fraction)
 165 !         tso - soil temp (k)
 166 !-- soilt       surface temperature (k)
 167 !-- hfx         upward heat flux at the surface (w/m^2)
 168 !-- qfx         upward moisture flux at the surface (kg/m^2/s)
 169 !-- lh          upward latent heat flux (w/m^2)
 170 !   sfcrunoff - ground surface runoff [mm]
 171 !   udrunoff - underground runoff [mm]
 172 !   acrunoff - run-total surface runoff [mm]
 173 !   sfcevp - total evaporation in [kg/m^2]
 174 !   grdflx - soil heat flux (w/m^2: negative, if downward from surface)
 175 !   snowfallac - run-total snowfall accumulation [m]
 176 !   acsnow - run-toral swe of snowfall [mm]
 177 !-- chklowq - is either 0 or 1 (so far set equal to 1).
 178 !--           used only in myjpbl.
 179 !-- tice - sea ice temperture (c)
 180 !-- rhosice - sea ice density (kg m^-3)
 181 !-- capice - sea ice volumetric heat capacity (j/m^3/k)
 182 !-- thdifice - sea ice thermal diffusivity (m^2/s)
 183 !--
 184 !-- ims           start index for i in memory
 185 !-- ime           end index for i in memory
 186 !-- jms           start index for j in memory
 187 !-- jme           end index for j in memory
 188 !-- kms           start index for k in memory
 189 !-- kme           end index for k in memory
 190 !-------------------------------------------------------------------------
 191 !   integer,     parameter            ::     nzss=5
 192 !   integer,     parameter            ::     nddzs=2*(nzss-2)
 193
 194    integer,     parameter            ::     nvegclas=24+3
 195
 196    real,       intent(in   )    ::     dt
 197    logical,    intent(in   )    ::     myj,frpcpn
 198    integer,    intent(in   )    ::     spp_lsm
 199    integer,    intent(in   )    ::     nlcat, nscat, mosaic_lu, mosaic_soil
 200    integer,    intent(in   )    ::     ktau, nsl, isice, iswater, &
 201                                        ims,ime, jms,jme, kms,kme, &
 202                                        ids,ide, jds,jde, kds,kde, &
 203                                        its,ite, jts,jte, kts,kte
 204
 205 #if (EM_CORE==1)
 206    real,    dimension( ims:ime, kms:kme, jms:jme ),optional::    pattern_spp_lsm
 207    real,    dimension( ims:ime, kms:kme, jms:jme ),optional::    field_sf
 208 #endif
 209    real,    dimension( ims:ime, 1  :nsl, jms:jme )         ::    field_sf_loc
 210
 211    real,    dimension( ims:ime, kms:kme, jms:jme )            , &
 212             intent(in   )    ::                           qv3d, &
 213                                                           qc3d, &
 214                                                            p8w, &
 215                                                          rho3d, &
 216                                                            t3d, &
 217                                                            z3d
 218
 219    real,       dimension( ims:ime , jms:jme ),                   &
 220                intent(in   )    ::                       rainbl, &
 221                                                             glw, &
 222                                                             gsw, &
 223                                                          albbck, &
 224                                                            flhc, &
 225                                                            flqc, &
 226                                                            chs , &
 227                                                            xice, &
 228                                                           xland, &
 229 !                                                         albbck, &
 230                                                            tbot
 231
 232 !beka
 233    real,       dimension( ims:ime , jms:jme ),                   &
 234                intent(inout   )    ::                       vegfra
 235
 236
 237 #if (EM_CORE==1)
 238    real,       optional, dimension( ims:ime , jms:jme ),         &
 239                intent(in   )    ::                   graupelncv, &
 240                                                         snowncv, &
 241                                                         rainncv
 242    real,       dimension( ims:ime , jms:jme ),                   &
 243                intent(in   )    ::                     lakemask
 244    integer,    intent(in   )    ::                    lakemodel
 245 #endif
 246
 247    real, dimension( ims:ime , jms:jme ), intent(in )::   shdmax
 248    real, dimension( ims:ime , jms:jme ), intent(in )::   shdmin
 249    logical, intent(in) :: rdlai2d
 250
 251    real,       dimension( 1:nsl), intent(in   )      ::      zs
 252
 253    real,       dimension( ims:ime , jms:jme ),                   &
 254                intent(inout)    ::                               &
 255                                                            snow, &
 256                                                           snowh, &
 257                                                           snowc, &
 258                                                          canwat, & ! new
 259                                                          snoalb, &
 260                                                             alb, &
 261                                                           emiss, &
 262                                                             lai, &
 263                                                          mavail, &
 264                                                          sfcexc, &
 265                                                             z0 , &
 266                                                             znt
 267
 268    real,       dimension( ims:ime , jms:jme ),                   &
 269                intent(in   )    ::                               &
 270                                                         frzfrac
 271
 272    integer,    dimension( ims:ime , jms:jme ),                   &
 273                intent(in   )    ::                       ivgtyp, &
 274                                                          isltyp
 275    character(len=*), intent(in   )    ::                 mminlu
 276    real,     dimension( ims:ime , 1:nlcat, jms:jme ), intent(in):: landusef
 277    real,     dimension( ims:ime , 1:nscat, jms:jme ), intent(in):: soilctop
 278
 279    real, intent(in   )          ::         cp,rovcp,g0,lv,stbolt,xice_threshold
 280
 281    real,       dimension( ims:ime , 1:nsl, jms:jme )           , &
 282                intent(inout)    ::                 soilmois,sh2o,tso
 283
 284    real,       dimension( ims:ime, jms:jme )                   , &
 285                intent(inout)    ::                        soilt, &
 286                                                             hfx, &
 287                                                             qfx, &
 288                                                              lh, &
 289                                                          sfcevp, &
 290                                                       sfcrunoff, &
 291                                                        udrunoff, &
 292                                                        acrunoff, &
 293                                                          grdflx, &
 294                                                          acsnow, &
 295                                                            snom, &
 296                                                             qvg, &
 297                                                             qcg, &
 298                                                             dew, &
 299                                                            qsfc, &
 300                                                             qsg, &
 301                                                         chklowq, &
 302                                                          soilt1, &
 303                                                           tsnav
 304
 305    real,       dimension( ims:ime, jms:jme )                   , &
 306                intent(inout)    ::                      smavail, &
 307                                                           smmax
 308
 309    real,       dimension( its:ite, jts:jte )    ::               &
 310                                                              pc, &
 311                                                         runoff1, &
 312                                                         runoff2, &
 313                                                          emissl, &
 314                                                            zntl, &
 315                                                         lmavail, &
 316                                                           smelt, &
 317                                                            snoh, &
 318                                                           snflx, &
 319                                                            edir, &
 320                                                              ec, &
 321                                                             ett, &
 322                                                          sublim, &
 323                                                            sflx, &
 324                                                             smf, &
 325                                                           evapl, &
 326                                                           prcpl, &
 327                                                          seaice, &
 328                                                         infiltr
 329 ! energy and water budget variables:
 330    real,       dimension( its:ite, jts:jte )    ::               &
 331                                                          budget, &
 332                                                        acbudget, &
 333                                                     waterbudget, &
 334                                                   acwaterbudget, &
 335                                                        smtotold, &
 336                                                         snowold, &
 337                                                       canwatold
 338
 339
 340    real,       dimension( ims:ime, 1:nsl, jms:jme)               &
 341                                              ::    keepfr3dflag, &
 342                                                          smfr3d
 343
 344    real,       dimension( ims:ime, jms:jme ), intent(out)     :: &
 345                                                          rhosnf, & !rho of snowfall
 346                                                        precipfr, & ! time-step frozen precip
 347                                                      snowfallac
 348 !--- soil/snow properties
 349    real                                                          &
 350                              ::                           rhocs, &
 351                                                        rhonewsn, &
 352                                                           rhosn, &
 353                                                       rhosnfall, &
 354                                                            bclh, &
 355                                                             dqm, &
 356                                                            ksat, &
 357                                                            psis, &
 358                                                            qmin, &
 359                                                           qwrtz, &
 360                                                             ref, &
 361                                                            wilt, &
 362                                                         canwatr, &
 363                                                        snowfrac, &
 364                                                           snhei, &
 365                                                            snwe
 366
 367    real                                      ::              cn, &
 368                                                          sat,cw, &
 369                                                            c1sn, &
 370                                                            c2sn, &
 371                                                          kqwrtz, &
 372                                                            kice, &
 373                                                             kwt
 374
 375
 376    real,     dimension(1:nsl)                ::          zsmain, &
 377                                                          zshalf, &
 378                                                          dtdzs2
 379
 380    real,     dimension(1:2*(nsl-2))          ::           dtdzs
 381
 382    real,     dimension(1:5001)               ::             tbq
 383
 384
 385    real,     dimension( 1:nsl )              ::         soilm1d, &
 386                                                           tso1d, &
 387                                                         soilice, &
 388                                                         soiliqw, &
 389                                                        smfrkeep
 390
 391    real,     dimension( 1:nsl )              ::          keepfr
 392
 393    real,     dimension( 1:nlcat )            ::          lufrac
 394    real,     dimension( 1:nscat )            ::          soilfrac
 395
 396    real                           ::                        rsm, &
 397                                                       snweprint, &
 398                                                      snheiprint
 399
 400    real                           ::                     prcpms, &
 401                                                         newsnms, &
 402                                                       prcpncliq, &
 403                                                        prcpncfr, &
 404                                                       prcpculiq, &
 405                                                        prcpcufr, &
 406                                                            patm, &
 407                                                           patmb, &
 408                                                            tabs, &
 409                                                           qvatm, &
 410                                                           qcatm, &
 411                                                           q2sat, &
 412                                                          conflx, &
 413                                                             rho, &
 414                                                            qkms, &
 415                                                            tkms, &
 416                                                         snowrat, &
 417                                                        grauprat, &
 418                                                        graupamt, &
 419                                                          icerat, &
 420                                                           curat, &
 421                                                        infiltrp
 422    real      ::  cq,r61,r273,arp,brp,x,evs,eis
 423    real      ::  cropfr, cropsm, newsm, factor
 424
 425    real      ::  meltfactor, ac,as, wb
 426    integer   ::  nroot
 427    integer   ::  iland,isoil,iforest
 428
 429    integer   ::  i,j,k,nzs,nzs1,nddzs
 430    integer   ::  k1,l,k2,kp,km
 431    character (len=132) :: message
 432
 433    real,dimension(ims:ime,1:nsl,jms:jme) :: rstoch
 434 !beka
 435    real,dimension(ims:ime,jms:jme)::emisso,vegfrao,albo,snoalbo
 436    real,dimension(its:ite,jts:jte)::emisslo
 437
 438 !-----------------------------------------------------------------
 439          nzs=nsl
 440          nddzs=2*(nzs-2)
 441
 442          rstoch=0.0
 443          field_sf_loc=0.0
 444 !beka added
 445 #if (EM_CORE==1)
 446        if (spp_lsm==1) then
 447          do j=jts,jte
 448            do i=its,ite
 449              do k=1,nsl
 450                rstoch(i,k,j) = pattern_spp_lsm(i,k,j)
 451                field_sf_loc(i,k,j)=field_sf(i,k,j)
 452              enddo
 453            enddo
 454          enddo
 455        endif
 456 #endif
 457 !---- table tbq is for resolution of balance equation in vilka
 458         cq=173.15-.05
 459         r273=1./273.15
 460         r61=6.1153*0.62198
 461         arp=77455.*41.9/461.525
 462         brp=64.*41.9/461.525
 463
 464         do k=1,5001
 465           cq=cq+.05
 466         evs=exp(17.67*(cq-273.15)/(cq-29.65))
 467         eis=exp(22.514-6.15e3/cq)
 468         if(cq.ge.273.15) then
 469 ! tbq is in mb
 470         tbq(k) = r61*evs
 471         else
 472         tbq(k) = r61*eis
 473         endif
 474
 475         end do
 476
 477 !--- initialize soil/vegetation parameters
 478 #if ( NMM_CORE == 1 )
 479      if(ktau+1.eq.1) then
 480 #else
 481      if(ktau.eq.1) then
 482 #endif
 483      do j=jts,jte
 484          do i=its,ite
 485             do k=1,nsl
 486        keepfr3dflag(i,k,j)=0.
 487             enddo
 488 !--- initializing snow fraction, thereshold = 32 mm of snow water or ~100 mm of snow height
 489         if((soilt1(i,j) .lt. 170.) .or. (soilt1(i,j) .gt.400.)) then
 490          if(snowc(i,j).gt.0.) then
 491            soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j))
 492     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 493         write ( message , fmt='(a,f8.3,2i6)' ) &
 494        'temperature inside snow is initialized in ruclsm ', soilt1(i,j),i,j
 495         call wrf_debug ( 0 , message )
 496     endif
 497             else
 498            soilt1(i,j) = tso(i,1,j)
 499          endif ! snowc
 500        endif ! soilt1
 501        !-- temperature inside snow is initialized
 502            tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15
 503            patmb=p8w(i,kms,j)*1.e-2
 504            qsg  (i,j) = qsn(soilt(i,j),tbq)/patmb
 505            if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then
 506              qcg  (i,j) = qc3d(i,1,j)
 507              if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 508                write ( message , fmt='(a,3f8.3,2i6)' ) &
 509                 'qvg is initialized in ruclsm ', qvg(i,j),mavail(i,j),qsg(i,j),i,j
 510              endif
 511            endif ! qcg
 512
 513         if((qvg(i,j) .le. 0.) .or. (qvg(i,j) .gt.0.1)) then
 514            qvg  (i,j) = qsg(i,j)*mavail(i,j)
 515           if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 516            write ( message , fmt='(a,3f8.3,2i6)' ) &
 517           'qvg is initialized in ruclsm ', qvg(i,j),mavail(i,j),qsg(i,j),i,j
 518            call wrf_debug ( 0 , message )
 519           endif
 520         endif
 521            qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
 522            smelt(i,j) = 0.
 523            snom (i,j) = 0.
 524            snowfallac(i,j) = 0.
 525            precipfr(i,j) = 0.
 526            rhosnf(i,j) = -1.e3 ! non-zero flag
 527            snflx(i,j) = 0.
 528            dew  (i,j) = 0.
 529            pc   (i,j) = 0.
 530            zntl (i,j) = 0.
 531            runoff1(i,j) = 0.
 532            runoff2(i,j) = 0.
 533            sfcrunoff(i,j) = 0.
 534            udrunoff(i,j) = 0.
 535            acrunoff(i,j) = 0.
 536            emissl (i,j) = 0.
 537            budget(i,j) = 0.
 538            acbudget(i,j) = 0.
 539            waterbudget(i,j) = 0.
 540            acwaterbudget(i,j) = 0.
 541            smtotold(i,j)=0.
 542            canwatold(i,j)=0.
 543
 544 ! for ruc lsm chklowq needed for myjpbl should
 545 ! 1 because is actual specific humidity at the surface, and
 546 ! not the saturation value
 547            chklowq(i,j) = 1.
 548            infiltr(i,j) = 0.
 549            snoh  (i,j) = 0.
 550            edir  (i,j) = 0.
 551            ec    (i,j) = 0.
 552            ett   (i,j) = 0.
 553            sublim(i,j) = 0.
 554            sflx  (i,j) = 0.
 555            smf   (i,j) = 0.
 556            evapl (i,j) = 0.
 557            prcpl (i,j) = 0.
 558          enddo
 559      enddo
 560
 561         do k=1,nsl
 562            soilice(k)=0.
 563            soiliqw(k)=0.
 564         enddo
 565      endif
 566
 567 !-----------------------------------------------------------------
 568
 569         prcpms = 0.
 570         newsnms = 0.
 571         prcpncliq = 0.
 572         prcpculiq = 0.
 573         prcpncfr = 0.
 574         prcpcufr = 0.
 575
 576
 577    do j=jts,jte
 578
 579       do i=its,ite
 580
 581     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 582       print *,' in lsmruc ','ims,ime,jms,jme,its,ite,jts,jte,nzs', &
 583                 ims,ime,jms,jme,its,ite,jts,jte,nzs
 584       print *,' ivgtyp, isltyp ', ivgtyp(i,j),isltyp(i,j)
 585       print *,' mavail ', mavail(i,j)
 586       print *,' soilt,qvg,p8w',soilt(i,j),qvg(i,j),p8w(i,1,j)
 587       print *, 'lsmruc, i,j,xland, qfx,hfx from sfclay',i,j,xland(i,j), &
 588                   qfx(i,j),hfx(i,j)
 589       print *, ' gsw, glw =',gsw(i,j),glw(i,j)
 590       print *, 'soilt, tso start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl)
 591       print *, 'soilmois start of time step =',(soilmois(i,k,j),k=1,nsl)
 592       print *, 'smfrozen start of time step =',(smfr3d(i,k,j),k=1,nsl)
 593       print *, ' i,j=, after sfclay chs,flhc ',i,j,chs(i,j),flhc(i,j)
 594       print *, 'lsmruc, ivgtyp,isltyp,alb = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j
 595       print *, 'lsmruc  i,j,dt,rainbl =',i,j,dt,rainbl(i,j)
 596       print *, 'xland ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j
 597     endif
 598
 599
 600          iland     = ivgtyp(i,j)
 601          isoil     = isltyp(i,j)
 602          tabs      = t3d(i,kms,j)
 603          qvatm     = qv3d(i,kms,j)
 604          qcatm     = qc3d(i,kms,j)
 605          patm      = p8w(i,kms,j)*1.e-5
 606 !-- z3d(1) is thickness between first full sigma level and the surface,
 607 !-- but first mass level is at the half of the first sigma level
 608 !-- (u and v are also at the half of first sigma level)
 609          conflx    = z3d(i,kms,j)*0.5
 610          rho       = rho3d(i,kms,j)
 611 ! -- initialize snow, graupel and ice fractions in frozen precip
 612          snowrat = 0.
 613          grauprat = 0.
 614          icerat = 0.
 615          curat = 0.
 616        if(frpcpn) then
 617 #if (EM_CORE==1)
 618          prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j))
 619          prcpncfr = rainncv(i,j)*frzfrac(i,j)
 620 !- apply the same frozen precipitation fraction to convective precip
 621 !tgs - 31 mar17 - add safety temperature check in case thompson mp produces
 622 !                 frozen precip at t > 273.
 623        if(frzfrac(i,j) > 0..and. tabs < 273.) then
 624          prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1.-frzfrac(i,j)))
 625          prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))*frzfrac(i,j))
 626        else
 627           if(tabs < 273.) then
 628             prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j)))
 629             prcpculiq = 0.
 630           else
 631             prcpcufr = 0.
 632             prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j)))
 633           endif  ! tabs < 273.
 634        endif  ! frzfrac > 0.
 635 !--- 1*e-3 is to convert from mm/s to m/s
 636          prcpms   = (prcpncliq + prcpculiq)/dt*1.e-3
 637          newsnms  = (prcpncfr + prcpcufr)/dt*1.e-3
 638
 639          if ( present( graupelncv ) ) then
 640              graupamt = graupelncv(i,j)
 641          else
 642              graupamt = 0.
 643          endif
 644
 645          if((prcpncfr + prcpcufr) > 0.) then
 646 ! -- calculate snow, graupel and ice fractions in falling frozen precip
 647          snowrat=min(1.,max(0.,snowncv(i,j)/(prcpncfr + prcpcufr)))
 648          grauprat=min(1.,max(0.,graupamt/(prcpncfr + prcpcufr)))
 649          icerat=min(1.,max(0.,(prcpncfr-snowncv(i,j)-graupamt) &
 650                /(prcpncfr + prcpcufr)))
 651          curat=min(1.,max(0.,(prcpcufr/(prcpncfr + prcpcufr))))
 652          endif
 653 #else
 654          prcpms    = (rainbl(i,j)/dt*1.e-3)*(1-frzfrac(i,j))
 655          newsnms  = (rainbl(i,j)/dt*1.e-3)*frzfrac(i,j)
 656        if(newsnms == 0.) then
 657          snowrat = 0.
 658        else
 659          snowrat = min(1.,newsnms/(newsnms+prcpms))
 660        endif
 661 #endif
 662
 663        else  ! .not. frpcpn
 664           if (tabs.le.273.15) then
 665          prcpms    = 0.
 666          newsnms   = rainbl(i,j)/dt*1.e-3
 667 !-- here no info about constituents of frozen precipitation,
 668 !-- suppose it is all snow
 669          snowrat = 1.
 670           else
 671          prcpms    = rainbl(i,j)/dt*1.e-3
 672          newsnms   = 0.
 673           endif
 674        endif
 675
 676 ! -- save time-step water equivalent of frozen precipitation in precipfr array to be used in
 677 !    module_diagnostics
 678           precipfr(i,j) = newsnms * dt *1.e3
 679
 680         if   (myj)   then
 681          qkms=chs(i,j)
 682          tkms=chs(i,j)
 683         else
 684 !--- convert exchange coeff qkms to [m/s]
 685          qkms=flqc(i,j)/rho/mavail(i,j)
 686 !         tkms=flhc(i,j)/rho/cp
 687          tkms=flhc(i,j)/rho/(cp*(1.+0.84*qvatm))  ! mynnsfc uses cpm
 688         endif
 689 !--- convert incoming snow and canwat from mm to m
 690          snwe=snow(i,j)*1.e-3
 691          snhei=snowh(i,j)
 692          canwatr=canwat(i,j)*1.e-3
 693
 694          snowfrac=snowc(i,j)
 695          rhosnfall=rhosnf(i,j)
 696
 697          snowold(i,j)=snwe
 698 !-----
 699              zsmain(1)=0.
 700              zshalf(1)=0.
 701           do k=2,nzs
 702              zsmain(k)= zs(k)
 703              zshalf(k)=0.5*(zsmain(k-1) + zsmain(k))
 704           enddo
 705
 706           do k=1,nlcat
 707              lufrac(k) = landusef(i,k,j)
 708           enddo
 709           do k=1,nscat
 710              soilfrac(k) = soilctop(i,k,j)
 711           enddo
 712
 713 !------------------------------------------------------------
 714 !-----  ddzs and dsdz1 are for implicit solution of soil eqns.
 715 !-------------------------------------------------------------
 716         nzs1=nzs-1
 717 !-----
 718     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 719          print *,' dt,nzs1, zsmain, zshalf --->', dt,nzs1,zsmain,zshalf
 720     endif
 721
 722         do  k=2,nzs1
 723           k1=2*k-3
 724           k2=k1+1
 725           x=dt/2./(zshalf(k+1)-zshalf(k))
 726           dtdzs(k1)=x/(zsmain(k)-zsmain(k-1))
 727           dtdzs2(k-1)=x
 728           dtdzs(k2)=x/(zsmain(k+1)-zsmain(k))
 729         end do
 730
 731         cw =4.183e6
 732
 733
 734 !--- constants used in johansen soil thermal
 735 !--- conductivity method
 736
 737         kqwrtz=7.7
 738         kice=2.2
 739         kwt=0.57
 740
 741 !***********************************************************************
 742 !--- constants for snow density calculations c1sn and c2sn
 743
 744         c1sn=0.026
 745         c2sn=21.
 746
 747 !***********************************************************************
 748
 749         nroot= 4 ! levels in root layer
 750
 751         rhonewsn = 200.
 752        if(snow(i,j).gt.0. .and. snowh(i,j).gt.0.) then
 753         rhosn = snow(i,j)/snowh(i,j)
 754        else
 755         rhosn = 300.
 756        endif
 757
 758     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 759        if(ktau.eq.1 .and.(i.eq.358.and.j.eq.260)) &
 760            print *,'before soilvegin - z0,znt(195,254)',z0(i,j),znt(i,j)
 761     endif
 762 !--- initializing soil and surface properties
 763      call soilvegin  ( mosaic_lu, mosaic_soil,soilfrac,nscat,shdmin(i,j),shdmax(i,j),&
 764                        nlcat,iland,isoil,iswater,myj,iforest,lufrac,vegfra(i,j),     &
 765                        emissl(i,j),pc(i,j),znt(i,j),lai(i,j),rdlai2d,                &
 766                        qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j )
 767     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 768       if(ktau.eq.1 .and.(i.eq.358.and.j.eq.260)) &
 769          print *,'after soilvegin - z0,znt(375,254),lai(375,254)',z0(i,j),znt(i,j),lai(i,j)
 770
 771       if(ktau.eq.1 .and. (i.eq.358.and.j.eq.260)) then
 772          print *,'nlcat,iland,lufrac,emissl(i,j),pc(i,j),znt(i,j),lai(i,j)', &
 773                   nlcat,iland,lufrac,emissl(i,j),pc(i,j),znt(i,j),lai(i,j),i,j
 774          print *,'nscat,soilfrac,qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt',&
 775                  nscat,soilfrac,qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j
 776       endif
 777     endif
 778
 779         cn=cfactr_data   ! exponent
 780         sat = 5.e-4  ! units [m]
 781
 782 !-- definition of number of soil levels in the rooting zone
 783      if(iforest.gt.2) then
 784 !---- all vegetation types except evergreen and mixed forests
 785 !18apr08 - define meltfactor for egglston melting limit:
 786 ! for open areas factor is 2, and for forests - factor is 0.85
 787 ! this will make limit on snow melting smaller and let snow stay
 788 ! longer in the forests.
 789          meltfactor = 2.0
 790
 791          do k=2,nzs
 792          if(zsmain(k).ge.0.4) then
 793             nroot=k
 794             goto  111
 795          endif
 796          enddo
 797      else
 798 !---- evergreen and mixed forests
 799 !18apr08 - define meltfactor
 800 !         meltfactor = 1.5
 801 ! 28 march 11 - previously used value of metfactor= 1.5 needs to be further reduced
 802 ! to compensate for low snow albedos in the forested areas.
 803 ! melting rate in forests will reduce.
 804          meltfactor = 0.85
 805
 806          do k=2,nzs
 807          if(zsmain(k).ge.1.1) then
 808             nroot=k
 809             goto  111
 810          endif
 811          enddo
 812      endif
 813  111   continue
 814
 815 !-----
 816     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 817          print *,' znt, lai, vegfra, sat, emis, pc --->',                &
 818                    znt(i,j),lai(i,j),vegfra(i,j),sat,emissl(i,j),pc(i,j)
 819          print *,' zs, zsmain, zshalf, conflx, cn, sat, --->', zs,zsmain,zshalf,conflx,cn,sat
 820          print *,'nroot, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(i,j),i,j
 821     endif
 822
 823 #if (EM_CORE==1)
 824      if(lakemodel==1. .and. lakemask(i,j)==1.) goto 2999
 825 !lakes
 826 #endif
 827
 828         if((xland(i,j)-1.5).ge.0.)then
 829 !-- water
 830            smavail(i,j)=1.0
 831              smmax(i,j)=1.0
 832              snow(i,j)=0.0
 833              snowh(i,j)=0.0
 834              snowc(i,j)=0.0
 835            lmavail(i,j)=1.0
 836
 837            iland=iswater
 838            isoil=14
 839
 840            patmb=p8w(i,1,j)*1.e-2
 841            qvg  (i,j) = qsn(soilt(i,j),tbq)/patmb
 842            qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
 843            chklowq(i,j)=1.
 844            q2sat=qsn(tabs,tbq)/patmb
 845
 846             do k=1,nzs
 847               soilmois(i,k,j)=1.0
 848               sh2o    (i,k,j)=1.0
 849               tso(i,k,j)= soilt(i,j)
 850             enddo
 851
 852     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 853               print*,'  water point, i=',i,                      &
 854               'j=',j, 'soilt=', soilt(i,j)
 855     endif
 856
 857            else
 858
 859 ! land point or sea ice
 860        if(xice(i,j).ge.xice_threshold) then
 861            seaice(i,j)=1.
 862        else
 863            seaice(i,j)=0.
 864        endif
 865
 866          if(seaice(i,j).gt.0.5)then
 867 !-- sea-ice case
 868     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 869               print*,' sea-ice at water point, i=',i,            &
 870               'j=',j
 871     endif
 872 !            iland = 24
 873             iland = isice
 874             isoil = 16
 875             znt(i,j) = 0.011
 876             snoalb(i,j) = 0.75
 877             dqm = 1.
 878             ref = 1.
 879             qmin = 0.
 880             wilt = 0.
 881             emissl(i,j) = 0.98
 882
 883            patmb=p8w(i,1,j)*1.e-2
 884            qvg  (i,j) = qsn(soilt(i,j),tbq)/patmb
 885            qsg  (i,j) = qvg(i,j)
 886            qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
 887
 888             do k=1,nzs
 889                soilmois(i,k,j) = 1.
 890                smfr3d(i,k,j)   = 1.
 891                sh2o(i,k,j)     = 0.
 892                keepfr3dflag(i,k,j) = 0.
 893                tso(i,k,j) = min(271.4,tso(i,k,j))
 894             enddo
 895           endif
 896
 897 !  attention!!!!  ruc lsm uses soil moisture content minus residual (minimum
 898 !  or dry soil moisture content for a given soil type) as a state variable.
 899
 900            do k=1,nzs
 901 ! soilm1d - soil moisture content minus residual [m**3/m**3]
 902               soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin),dqm)
 903               tso1d   (k) = tso(i,k,j)
 904               soiliqw (k) = min(max(0.,sh2o(i,k,j)-qmin),soilm1d(k))
 905               soilice (k) =(soilm1d (k) - soiliqw (k))/0.9
 906            enddo
 907
 908            do k=1,nzs
 909               smfrkeep(k) = smfr3d(i,k,j)
 910               keepfr  (k) = keepfr3dflag(i,k,j)
 911            enddo
 912
 913               lmavail(i,j)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin)))
 914
 915 #if ( NMM_CORE == 1 )
 916      if(ktau+1.gt.1) then
 917 #else
 918      if(ktau.gt.1) then
 919 #endif
 920      endif
 921
 922     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 923    print *,'land, i,j,tso1d,soilm1d,patm,tabs,qvatm,qcatm,rho',  &
 924                   i,j,tso1d,soilm1d,patm,tabs,qvatm,qcatm,rho
 925    print *,'conflx =',conflx
 926    print *,'smfrkeep,keepfr   ',smfrkeep,keepfr
 927     endif
 928
 929         smtotold(i,j)=0.
 930       do k=1,nzs-1
 931         smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))*             &
 932                     (zshalf(k+1)-zshalf(k))
 933       enddo
 934
 935         smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))*           &
 936                     (zsmain(nzs)-zshalf(nzs))
 937
 938         canwatold(i,j) = canwatr
 939     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 940       print *,'before sfctmp, spp_lsm, rstoch, field_sf_loc',      &
 941       i,j,spp_lsm,(rstoch(i,k,j),k=1,nzs),(field_sf_loc(i,k,j),k=1,nzs)
 942     endif
 943 !-----------------------------------------------------------------
 944          call sfctmp (spp_lsm,rstoch(i,:,j),field_sf_loc(i,:,j), &
 945                 dt,ktau,conflx,i,j,                              &
 946 !--- input variables
 947                 nzs,nddzs,nroot,meltfactor,                      &   !added meltfactor
 948                 iland,isoil,xland(i,j),ivgtyp(i,j),isltyp(i,j),  &
 949                 prcpms, newsnms,snwe,snhei,snowfrac,             &
 950                 rhosn,rhonewsn,rhosnfall,                        &
 951                 snowrat,grauprat,icerat,curat,                   &
 952                 patm,tabs,qvatm,qcatm,rho,                       &
 953                 glw(i,j),gsw(i,j),emissl(i,j),                   &
 954                 qkms,tkms,pc(i,j),lmavail(i,j),                  &
 955                 canwatr,vegfra(i,j),alb(i,j),znt(i,j),           &
 956                 snoalb(i,j),albbck(i,j),lai(i,j),                &   !new
 957                 myj,seaice(i,j),isice,                           &
 958 !--- soil fixed fields
 959                 qwrtz,                                           &
 960                 rhocs,dqm,qmin,ref,                              &
 961                 wilt,psis,bclh,ksat,                             &
 962                 sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq,           &
 963 !--- constants
 964                 cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn,              &
 965                 kqwrtz,kice,kwt,                                 &
 966 !--- output variables
 967                 snweprint,snheiprint,rsm,                        &
 968                 soilm1d,tso1d,smfrkeep,keepfr,                   &
 969                 soilt(i,j),soilt1(i,j),tsnav(i,j),dew(i,j),      &
 970                 qvg(i,j),qsg(i,j),qcg(i,j),smelt(i,j),           &
 971                 snoh(i,j),snflx(i,j),snom(i,j),snowfallac(i,j),  &
 972                 acsnow(i,j),edir(i,j),ec(i,j),ett(i,j),qfx(i,j), &
 973                 lh(i,j),hfx(i,j),sflx(i,j),sublim(i,j),          &
 974                 evapl(i,j),prcpl(i,j),budget(i,j),runoff1(i,j),  &
 975                 runoff2(i,j),soilice,soiliqw,infiltrp,smf(i,j))
 976 !-----------------------------------------------------------------
 977
 978 ! irrigation: fraction of cropland category in the grid box should not have soil moisture below
 979 ! wilting point during the growing season.
 980 ! let's keep soil moisture 10% above wilting point for the fraction of grid box under
 981 ! croplands.
 982 ! this change violates lsm moisture budget, but
 983 ! can be considered as a compensation for irrigation not included into lsm.
 984
 985     if(mosaic_lu == 1) then
 986       ! greenness factor: between 0 for min greenness and 1 for max greenness.
 987       factor = max(0.,min(1.,(vegfra(i,j)-shdmin(i,j))/max(1.,(shdmax(i,j)-shdmin(i,j)))))
 988
 989       if ((lufrac(crop) > 0 .or. lufrac(natural) > 0.).and. factor > 0.75) then
 990       ! cropland or grassland, apply irrigation during the growing seaspon when
 991       ! factor is > 0.75.
 992         do k=1,nroot
 993              cropsm=1.1*wilt - qmin
 994           cropfr = min(1.,lufrac(crop) + 0.4*lufrac(natural)) ! assume that 40% of natural is cropland
 995           newsm = cropsm*cropfr + (1.-cropfr)*soilm1d(k)
 996           if(soilm1d(k) < newsm) then
 997     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
 998 print * ,'soil moisture is below wilting in cropland category at time step',ktau  &
 999               ,'i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm',                       &
1000                 i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm
1001     endif
1002             soilm1d(k) = newsm
1003     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1004       print * ,'added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k)
1005     endif
1006           endif
1007         enddo
1008       endif ! crop or natural
1009     endif ! mosaic_lu
1010
1011 ! fill in field_sf to pass perturbed field of hydraulic cond. up to model driver and output
1012 #if (EM_CORE==1)
1013        if (spp_lsm==1) then
1014          do k=1,nsl
1015            field_sf(i,k,j)=field_sf_loc(i,k,j)
1016          enddo
1017        endif
1018 #endif
1019
1020 !***  diagnostics
1021 !--- available and maximum soil moisture content in the soil
1022 !--- domain
1023
1024         smavail(i,j) = 0.
1025         smmax (i,j)  = 0.
1026
1027       do k=1,nzs-1
1028         smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))*             &
1029                     (zshalf(k+1)-zshalf(k))
1030         smmax (i,j) =smmax (i,j)+(qmin+dqm)*                     &
1031                     (zshalf(k+1)-zshalf(k))
1032       enddo
1033
1034         smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))*           &
1035                     (zsmain(nzs)-zshalf(nzs))
1036         smmax (i,j) =smmax (i,j)+(qmin+dqm)*                     &
1037                     (zsmain(nzs)-zshalf(nzs))
1038
1039 !--- convert the water unit into mm
1040         sfcrunoff(i,j) = sfcrunoff(i,j)+runoff1(i,j)*dt*1000.0
1041         udrunoff (i,j) = udrunoff(i,j)+runoff2(i,j)*dt*1000.0
1042         acrunoff(i,j)  = acrunoff(i,j)+runoff1(i,j)*dt*1000.0
1043         smavail  (i,j) = smavail(i,j) * 1000.
1044         smmax    (i,j) = smmax(i,j) * 1000.
1045         smtotold (i,j) = smtotold(i,j) * 1000.
1046
1047         do k=1,nzs
1048
1049              soilmois(i,k,j) = soilm1d(k) + qmin
1050              sh2o    (i,k,j) = min(soiliqw(k) + qmin,soilmois(i,k,j))
1051                   tso(i,k,j) = tso1d(k)
1052         enddo
1053
1054         tso(i,nzs,j) = tbot(i,j)
1055
1056         do k=1,nzs
1057              smfr3d(i,k,j) = smfrkeep(k)
1058            keepfr3dflag(i,k,j) = keepfr (k)
1059         enddo
1060
1061         z0       (i,j) = znt (i,j)
1062         sfcexc   (i,j) = tkms
1063         patmb=p8w(i,1,j)*1.e-2
1064         q2sat=qsn(tabs,tbq)/patmb
1065         qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
1066 ! for myj surface and pbl scheme
1067 !      if (myj) then
1068 ! myjsfc expects qsfc as actual specific humidity at the surface
1069         if((qvatm.ge.q2sat*0.95).and.qvatm.lt.qvg(i,j))then
1070           chklowq(i,j)=0.
1071         else
1072           chklowq(i,j)=1.
1073         endif
1074
1075     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1076       if(chklowq(i,j).eq.0.) then
1077    print *,'i,j,chklowq',  &
1078                   i,j,chklowq(i,j)
1079       endif
1080     endif
1081
1082         if(snow(i,j)==0.) emissl(i,j) = lemitbl(ivgtyp(i,j))
1083         emiss (i,j) = emissl(i,j)
1084 ! snow is in [mm], snwe is in [m]; canwat is in mm, canwatr is in m
1085         snow   (i,j) = snwe*1000.
1086         snowh  (i,j) = snhei
1087         canwat (i,j) = canwatr*1000.
1088
1089         infiltr(i,j) = infiltrp
1090
1091         mavail (i,j) = lmavail(i,j)
1092     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1093        print *,' land, i=,j=, qfx, hfx after sfctmp', i,j,lh(i,j),hfx(i,j)
1094     endif
1095         sfcevp (i,j) = sfcevp (i,j) + qfx (i,j) * dt
1096         grdflx (i,j) = -1. * sflx(i,j)
1097
1098 !       if(smf(i,j) .ne.0.) then
1099 !tgs - smf.ne.0. when there is phase change in the top soil layer
1100 ! the heat of soil water freezing/thawing is not computed explicitly
1101 ! and is responsible for the residual in the energy budget.
1102 !  print *,'budget',budget(i,j),i,j,smf(i,j)
1103 !       endif
1104
1105 !--- snowc snow cover flag
1106        if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then
1107            snowfrac = snowfrac*xice(i,j)
1108        endif
1109
1110        snowc(i,j)=snowfrac
1111
1112 !--- rhosnf - density of snowfall
1113        rhosnf(i,j)=rhosnfall
1114
1115 ! accumulated moisture flux [kg/m^2]
1116        sfcevp (i,j) = sfcevp (i,j) + qfx (i,j) * dt
1117
1118 !       if(smf(i,j) .ne.0.) then
1119 !tgs - smf.ne.0. when there is phase change in the top soil layer
1120 ! the heat of freezing/thawing of soil water is not computed explicitly
1121 ! and is responsible for the residual in the energy budget.
1122 !       endif
1123 !        budget(i,j)=budget(i,j)-smf(i,j)
1124
1125        ac=0.
1126        as=0.
1127
1128        ac=max(0.,canwat(i,j)-canwatold(i,j))
1129        as=max(0.,snwe-snowold(i,j))
1130        wb =rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source
1131                       -qfx(i,j)*dt &
1132                       -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 &
1133                       -ac-as - (smavail(i,j)-smtotold(i,j))
1134
1135        waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source
1136                       -qfx(i,j)*dt &
1137                       -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 &
1138                       -ac-as - (smavail(i,j)-smtotold(i,j))
1139
1140
1141        acwaterbudget(i,j)=acwaterbudget(i,j)+waterbudget(i,j)
1142
1143     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1144   print *,'smf=',smf(i,j),i,j
1145   print *,'budget',budget(i,j),i,j
1146   print *,'runoff2= ', i,j,runoff2(i,j)
1147   print *,'water budget ', i,j,waterbudget(i,j)
1148   print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', &
1149           i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, &
1150           smelt(i,j)*dt*1.e3, &
1151           (smavail(i,j)-smtotold(i,j))
1152
1153   print *,'snow,snowold',i,j,snwe,snowold(i,j)
1154   print *,'snow-snowold',i,j,max(0.,snwe-snowold(i,j))
1155   print *,'canwatold, canwat ',i,j,canwatold(i,j),canwat(i,j)
1156   print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j))
1157     endif
1158
1159
1160     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1161    print *,'land, i,j,tso1d,soilm1d,soilt - end of time step',         &
1162                   i,j,tso1d,soilm1d,soilt(i,j)
1163    print *,'land, qfx, hfx after sfctmp', i,j,lh(i,j),hfx(i,j)
1164     endif
1165
1166 !--- end of a land or sea ice point
1167         endif
1168 2999  continue ! lakes
1169
1170       enddo
1171
1172    enddo
1173
1174 !-----------------------------------------------------------------
1175    end subroutine lsmruc
1176 !-----------------------------------------------------------------
1177
1178
1179
1180    subroutine sfctmp (spp_lsm,rstochcol,fieldcol_sf,             &
1181                 delt,ktau,conflx,i,j,                            &
1182 !--- input variables
1183                 nzs,nddzs,nroot,meltfactor,                      &
1184                 iland,isoil,xland,ivgtyp,isltyp,prcpms,          &
1185                 newsnms,snwe,snhei,snowfrac,                     &
1186                 rhosn,rhonewsn,rhosnfall,                        &
1187                 snowrat,grauprat,icerat,curat,                   &
1188                 patm,tabs,qvatm,qcatm,rho,                       &
1189                 glw,gsw,emiss,qkms,tkms,pc,                      &
1190                 mavail,cst,vegfra,alb,znt,                       &
1191                 alb_snow,alb_snow_free,lai,                      &
1192                 myj,seaice,isice,                                &
1193 !--- soil fixed fields
1194                 qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,    &
1195                 sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq,           &
1196 !--- constants
1197                 cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn,              &
1198                 kqwrtz,kice,kwt,                                 &
1199 !--- output variables
1200                 snweprint,snheiprint,rsm,                        &
1201                 soilm1d,ts1d,smfrkeep,keepfr,soilt,soilt1,       &
1202                 tsnav,dew,qvg,qsg,qcg,                           &
1203                 smelt,snoh,snflx,snom,snowfallac,acsnow,         &
1204                 edir1,ec1,ett1,eeta,qfx,hfx,s,sublim,            &
1205                 evapl,prcpl,fltot,runoff1,runoff2,soilice,       &
1206                 soiliqw,infiltr,smf)
1207 !-----------------------------------------------------------------
1208        implicit none
1209 !-----------------------------------------------------------------
1210
1211 !--- input variables
1212
1213    integer,  intent(in   )   ::  isice,i,j,nroot,ktau,nzs ,      &
1214                                  nddzs                             !nddzs=2*(nzs-2)
1215
1216    real,     intent(in   )   ::  delt,conflx,meltfactor
1217    real,     intent(in   )   ::  c1sn,c2sn
1218    logical,    intent(in   )    ::     myj
1219 !--- 3-d atmospheric variables
1220    real                                                        , &
1221             intent(in   )    ::                            patm, &
1222                                                            tabs, &
1223                                                           qvatm, &
1224                                                           qcatm
1225    real                                                        , &
1226             intent(in   )    ::                             glw, &
1227                                                             gsw, &
1228                                                              pc, &
1229                                                          vegfra, &
1230                                                   alb_snow_free, &
1231                                                             lai, &
1232                                                          seaice, &
1233                                                           xland, &
1234                                                             rho, &
1235                                                            qkms, &
1236                                                            tkms
1237
1238    integer,   intent(in   )  ::                          ivgtyp, isltyp
1239 !--- 2-d variables
1240    real                                                        , &
1241             intent(inout)    ::                           emiss, &
1242                                                          mavail, &
1243                                                        snowfrac, &
1244                                                        alb_snow, &
1245                                                             alb, &
1246                                                             cst
1247
1248 !--- soil properties
1249    real                      ::                                  &
1250                                                           rhocs, &
1251                                                            bclh, &
1252                                                             dqm, &
1253                                                            ksat, &
1254                                                            psis, &
1255                                                            qmin, &
1256                                                           qwrtz, &
1257                                                             ref, &
1258                                                             sat, &
1259                                                            wilt
1260
1261    real,     intent(in   )   ::                              cn, &
1262                                                              cw, &
1263                                                              cp, &
1264                                                           rovcp, &
1265                                                              g0, &
1266                                                              lv, &
1267                                                          stbolt, &
1268                                                          kqwrtz, &
1269                                                            kice, &
1270                                                             kwt
1271
1272    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
1273                                                          zshalf, &
1274                                                          dtdzs2
1275
1276    real,     dimension(1:nzs), intent(in)  ::          rstochcol
1277    real,     dimension(1:nzs), intent(inout) ::     fieldcol_sf
1278
1279
1280    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
1281
1282    real,     dimension(1:5001), intent(in)  ::              tbq
1283
1284
1285 !--- input/output variables
1286 !-------- 3-d soil moisture and temperature
1287    real,     dimension( 1:nzs )                                , &
1288              intent(inout)   ::                            ts1d, &
1289                                                         soilm1d, &
1290                                                        smfrkeep
1291    real,  dimension( 1:nzs )                                   , &
1292              intent(inout)   ::                          keepfr
1293
1294    real,  dimension(1:nzs), intent(inout)  ::          soilice, &
1295                                                        soiliqw
1296
1297
1298    integer, intent(inout)    ::                     iland,isoil
1299    integer                   ::                     ilands
1300
1301 !-------- 2-d variables
1302    real                                                        , &
1303              intent(inout)   ::                             dew, &
1304                                                           edir1, &
1305                                                             ec1, &
1306                                                            ett1, &
1307                                                            eeta, &
1308                                                           evapl, &
1309                                                         infiltr, &
1310                                                           rhosn, &
1311                                                        rhonewsn, &
1312                                                       rhosnfall, &
1313                                                         snowrat, &
1314                                                        grauprat, &
1315                                                          icerat, &
1316                                                           curat, &
1317                                                          sublim, &
1318                                                           prcpl, &
1319                                                             qvg, &
1320                                                             qsg, &
1321                                                             qcg, &
1322                                                             qfx, &
1323                                                             hfx, &
1324                                                           fltot, &
1325                                                             smf, &
1326                                                               s, &
1327                                                         runoff1, &
1328                                                         runoff2, &
1329                                                          acsnow, &
1330                                                      snowfallac, &
1331                                                            snwe, &
1332                                                           snhei, &
1333                                                           smelt, &
1334                                                            snom, &
1335                                                            snoh, &
1336                                                           snflx, &
1337                                                           soilt, &
1338                                                          soilt1, &
1339                                                           tsnav, &
1340                                                             znt
1341
1342    real,     dimension(1:nzs)              ::                    &
1343                                                            tice, &
1344                                                         rhosice, &
1345                                                          capice, &
1346                                                        thdifice, &
1347                                                           ts1ds, &
1348                                                        soilm1ds, &
1349                                                       smfrkeeps, &
1350                                                        soiliqws, &
1351                                                        soilices, &
1352                                                         keepfrs
1353 !-------- 1-d variables
1354    real :: &
1355                                                             dews, &
1356                                                         mavails,  &
1357                                                           edir1s, &
1358                                                             ec1s, &
1359                                                             csts, &
1360                                                            ett1s, &
1361                                                            eetas, &
1362                                                           evapls, &
1363                                                         infiltrs, &
1364                                                           prcpls, &
1365                                                             qvgs, &
1366                                                             qsgs, &
1367                                                             qcgs, &
1368                                                             qfxs, &
1369                                                             hfxs, &
1370                                                           fltots, &
1371                                                         runoff1s, &
1372                                                         runoff2s, &
1373                                                               ss, &
1374                                                           soilts
1375
1376
1377
1378
1379    real,  intent(inout)                     ::              rsm, &
1380                                                       snweprint, &
1381                                                      snheiprint
1382    integer,   intent(in)                    ::     spp_lsm
1383 !--- local variables
1384
1385    integer ::  k,ilnb
1386
1387    real    ::  bsn, xsn                                        , &
1388                rainf, snth, newsn, prcpms, newsnms             , &
1389                t3, upflux, xinet
1390    real    ::  snhei_crit, snhei_crit_newsn, keep_snow_albedo, snowfracnewsn
1391    real    ::  newsnowratio, dd1, snowfrac2, m
1392
1393    real    ::  rhonewgr,rhonewice
1394
1395    real    ::  rnet,gswnew,gswin,emissn,zntsn,emiss_snowfree
1396    real    ::  vegfrac, snow_mosaic, snfr, vgfr
1397    real    ::  cice, albice, albsn, drip, dripsn, dripliq
1398    real    ::  interw, intersn, infwater, intwratio
1399
1400 !-----------------------------------------------------------------
1401         integer,   parameter      ::      ilsnow=99
1402
1403     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1404         print *,' in sfctmp',i,j,nzs,nddzs,nroot,                 &
1405                  snwe,rhosn,snom,smelt,ts1d
1406     endif
1407
1408      !-- snow fraction options
1409      !-- option 1: original formulation using critical snow depth to compute
1410      !-- snow fraction
1411      !-- option 2: the tanh formulation from niu,g.-y.,and yang,z.-l.
1412      !2007,jgr,doi:10.1029/2007jd008674.
1413      !-- option 3: the tanh formulation from niu,g.-y.,and yang,z.-l.
1414      !2007,jgr,doi:10.1029/2007jd008674.
1415      !   with vegetation dependent parameters from noah mp (personal
1416      !   communication with mike barlage)
1417      !-- snhei_crit is a threshold for fractional snow in isncovr_opt=1
1418          snhei_crit=0.01601*rhowater/rhosn
1419          snhei_crit_newsn=0.0005*rhowater/rhosn
1420      !--
1421         zntsn = z0tbl(isice)
1422
1423         snow_mosaic=0.
1424         snfr = 1.
1425         newsn=0.
1426         newsnowratio = 0.
1427         snowfracnewsn=0.
1428         rhonewsn = 100.
1429         if(snhei == 0.) snowfrac=0.
1430         smelt = 0.
1431         rainf = 0.
1432         rsm=0.
1433         dd1=0.
1434         infiltr=0.
1435 ! jul 2016 -  Avissar and Pielke (1989)
1436 ! this formulation depending on lai defines relative contribution of the vegetation to
1437 ! the total heat fluxes between surface and atmosphere.
1438 ! with vegfra=100% and lai=3, vegfrac=0.86 meaning that vegetation contributes
1439 ! only 86% of the total surface fluxes.
1440 !        vgfr=0.01*vegfra ! % --> fraction
1441 !        vegfrac=2.*lai*vgfr/(1.+2.*lai*vgfr)
1442         vegfrac=0.01*vegfra
1443         drip = 0.
1444         dripsn = 0.
1445         dripliq = 0.
1446         smf = 0.
1447         interw=0.
1448         intersn=0.
1449         infwater=0.
1450
1451 !---initialize local arrays for sea ice
1452           do k=1,nzs
1453             tice(k) = 0.
1454             rhosice(k) = 0.
1455             cice = 0.
1456             capice(k) = 0.
1457             thdifice(k) = 0.
1458           enddo
1459
1460         gswnew=gsw
1461         gswin=gsw/(1.-alb)
1462         albice=alb_snow_free
1463         albsn=alb_snow
1464         emissn = 0.98
1465         emiss_snowfree = lemitbl(ivgtyp)
1466
1467 !--- sea ice properties
1468 !--- n.n Zubov "arctic ice"
1469 !--- no salinity dependence because we consider the ice pack
1470 !--- to be old and to have low salinity (0.0002)
1471        if(seaice.ge.0.5) then
1472           do k=1,nzs
1473             tice(k) = ts1d(k) - 273.15
1474             rhosice(k) = 917.6/(1-0.000165*tice(k))
1475             cice = 2115.85 +7.7948*tice(k)
1476             capice(k) = cice*rhosice(k)
1477             thdifice(k) = 2.260872/capice(k)
1478            enddo
1479 !-- sea ice alb dependence on ice temperature. when ice temperature is
1480 !-- below critical value of -10c - no change to albedo.
1481 !-- if temperature is higher that -10c then albedo is decreasing.
1482 !-- the minimum albedo at t=0c for ice is 0.1 less.
1483        albice = min(alb_snow_free,max(alb_snow_free - 0.05,   &
1484                alb_snow_free - 0.1*(tice(1)+10.)/10. ))
1485        endif
1486
1487     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1488         print *,'alb_snow_free',alb_snow_free
1489         print *,'gsw,gswnew,glw,soilt,emiss,alb,albice,snwe',&
1490                  gsw,gswnew,glw,soilt,emiss,alb,albice,snwe
1491     endif
1492
1493         if(snhei.gt.0.0081*1.e3/rhosn) then
1494 !*** update snow density for current temperature (koren et al. 1999)
1495         bsn=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3)
1496        if(bsn*snwe*100..lt.1.e-4) goto 777
1497         xsn=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.)
1498         rhosn=min(max(58.8,xsn),500.) ! 13mar18 - switch from 76.9 to 58.8
1499  777   continue
1500
1501       endif
1502
1503       !-- snow_mosaic from the previous time step
1504       if(snowfrac < 0.75) snow_mosaic = 1.
1505
1506            newsn=newsnms*delt
1507
1508        if(newsn.gt.0.) then
1509 !       if(newsn.ge.1.e-8) then
1510
1511     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1512       print *, 'there is new snow, newsn', newsn
1513     endif
1514
1515         newsnowratio = min(1.,newsn/(snwe+newsn))
1516
1517 !--- 27 feb 2014 - empirical formulations from john m. brown
1518 !        rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-tabs)*0.3333))))
1519 !--- 13 mar 2018 - formulation from trevor alcott
1520         rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-tabs)*0.15))))
1521         rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-tabs)*0.3333))))
1522         rhonewice=rhonewsn
1523
1524 !--- compute density of "snowfall" from weighted contribution
1525 !                 of snow, graupel and ice fractions
1526
1527          rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat +  &  ! 13mar18-switch from 76.9 to 58.8
1528                      rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat)))
1529
1530 ! from now on rhonewsn is the density of falling frozen precipitation
1531          rhonewsn=rhosnfall
1532
1533 !*** define average snow density of the snow pack considering
1534 !*** the amount of fresh snow (eq. 9 in koren et al.(1999)
1535 !*** without snow melt )
1536          xsn=(rhosn*snwe+rhonewsn*newsn)/                         &
1537              (snwe+newsn)
1538          rhosn=min(max(58.8,xsn),500.) ! 13mar18 - switch from 76.9 to 58.8
1539
1540        endif ! end newsn > 0.
1541
1542        if(prcpms.ne.0.) then
1543
1544 ! prcpms is liquid precipitation rate
1545 ! rainf is a flag used for calculation of rain water
1546 ! heat content contribution into heat budget equation. rain's temperature
1547 ! is set equal to air temperature at the first atmospheric
1548 ! level.
1549
1550            rainf=1.
1551        endif
1552
1553         drip = 0.
1554         intwratio=0.
1555      if(vegfrac > 0.01) then
1556 ! compute intercepted precipitation - eq. 1 Lawrence et al.,
1557 ! j. of hydrometeorology, 2006, clm.
1558          interw=0.25*delt*prcpms*(1.-exp(-0.5*lai))*vegfrac
1559          intersn=0.25*newsn*(1.-exp(-0.5*lai))*vegfrac
1560          infwater=prcpms - interw/delt
1561     if((interw+intersn) > 0.) then
1562        intwratio=interw/(interw+intersn)
1563     endif
1564
1565 ! update water/snow intercepted by the canopy
1566          dd1=cst + interw + intersn
1567          cst=dd1
1568         if(cst.gt.sat) then
1569           cst=sat
1570           drip=dd1-sat
1571         endif
1572      else
1573          cst=0.
1574          drip=0.
1575          interw=0.
1576          intersn=0.
1577          infwater=prcpms
1578      endif ! vegfrac > 0.01
1579
1580        if(newsn.gt.0.) then
1581 !update snow on the ground
1582          snwe=max(0.,snwe+newsn-intersn)
1583 ! add drip to snow on the ground
1584       if(drip > 0.) then
1585        if (snow_mosaic==1.) then
1586          dripliq=drip*intwratio
1587          dripsn = drip - dripliq
1588          snwe=snwe+dripsn
1589          infwater=infwater+dripliq
1590          dripliq=0.
1591          dripsn = 0.
1592        else
1593          snwe=snwe+drip
1594        endif
1595       endif
1596          snhei=snwe*rhowater/rhosn
1597          newsn=newsn*rhowater/rhonewsn
1598        endif
1599
1600    if(snhei.gt.0.0) then
1601 !-- snow on the ground
1602 !--- land-use category should be changed to snow/ice for grid points with snow>0
1603          iland=isice
1604 !24nov15 - based on field exp on pleasant view soccer fields
1605 !    if(meltfactor > 1.5) then ! all veg. types, except forests
1606 !         snhei_crit=0.01601*1.e3/rhosn
1607 ! petzold - 1 cm of fresh snow overwrites effects from old snow.
1608 ! need to test snhei_crit_newsn=0.01
1609 !         snhei_crit_newsn=0.01
1610 !    else  ! forests
1611 !         snhei_crit=0.02*1.e3/rhosn
1612 !         snhei_crit_newsn=0.001*1.e3/rhosn
1613 !    endif
1614
1615       if(isncovr_opt == 1) then
1616          snowfrac=min(1.,snhei/(2.*snhei_crit))
1617       elseif(isncovr_opt == 2) then
1618         snowfrac=min(1.,snhei/(2.*snhei_crit))
1619         !if(ivgtyp == glacier .or. ivgtyp == bare) then
1620         !-- sparsely vegetated or land ice
1621         !  snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**1.))
1622         !else
1623           !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests
1624           !  on 3-km scale use actual roughness, but not higher than 0.2 m.
1625           !  the factor is 20 for forests (~100/dx = 33., dx=3 km)
1626         snowfrac2 = tanh( snhei/(2.5 * min(0.2,znt) *(rhosn/rhonewsn)**1.))
1627         !endif
1628         !-- snow fraction is average between method 1 and 2
1629         snowfrac = 0.5*(snowfrac+snowfrac2)
1630       else
1631       !-- isncovr_opt=3
1632         !m = mfsno(ivgtyp) ! vegetation dependent facsnf/msnf from noah mp
1633         m = 1.
1634         !-- for rrfs a factor 10. was added to 'facsnf' to get reasonal values of
1635         !   snow cover fractions on the 3-km scale.
1636         !   this factor is scale dependent.
1637         snowfrac = tanh( snhei/(10. * sncovfac(ivgtyp)*(rhosn/rhonewsn)**m))
1638       endif
1639
1640        if(newsn > 0. ) then
1641          snowfracnewsn=min(1.,snowfallac*1.e-3/snhei_crit_newsn)
1642        endif
1643
1644 !24nov15 - snowfrac for urban category < 0.75
1645       if(ivgtyp == urban) snowfrac=min(0.75,snowfrac)
1646 !      if(meltfactor > 1.5) then
1647 !         if(isltyp > 9 .and. isltyp < 13) then
1648 !24nov15 clay soil types - snofrac < 0.9
1649 !           snowfrac=min(0.9,snowfrac)
1650 !         endif
1651 !      else
1652 !24nov15 - snowfrac for forests < 0.75
1653 !         snowfrac=min(0.85,snowfrac)
1654 !      endif
1655
1656        if(snowfrac < 0.75) snow_mosaic = 1.
1657
1658          keep_snow_albedo = 0.
1659        if (snowfracnewsn > 0.99 .and. rhosnfall < 450.) then
1660 ! new snow
1661              keep_snow_albedo = 1.
1662              snow_mosaic=0.
1663      endif
1664
1665     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1666       print *,'snhei_crit,snowfrac,snhei_crit_newsn,snowfracnewsn', &
1667                snhei_crit,snowfrac,snhei_crit_newsn,snowfracnewsn
1668     endif
1669
1670 !-- set znt for snow from VEGPARM table (snow/ice landuse), except for
1671 !-- land-use types with higher roughness (forests, urban).
1672       if(newsn.eq.0. .and. znt.le.0.2 .and. ivgtyp.ne.isice) then
1673          if( snhei .le. 2.*znt)then
1674            znt=0.55*znt+0.45*z0tbl(iland)
1675          elseif( snhei .gt. 2.*znt .and. snhei .le. 4.*znt)then
1676            znt=0.2*znt+0.8*z0tbl(iland)
1677          elseif(snhei > 4.*znt) then
1678            znt=z0tbl(iland)
1679          endif
1680        endif
1681
1682     if(seaice .lt. 0.5) then
1683 !----- snow on soil
1684 !-- alb dependence on snow depth
1685 ! alb_snow across canada's forested areas is very low - 0.27-0.35, this
1686 ! causes significant warm biases. limiting alb in these areas to be higher than 0.4
1687 ! hwlps with these biases..
1688      if( snow_mosaic == 1.) then
1689          albsn=alb_snow
1690          if(keep_snow_albedo > 0.9 .and. albsn < 0.4) then
1691          !-- Albedo correction with fresh snow and deep snow pack
1692          !-- will reduce warm bias in western Canada
1693          !-- and US West coast, where max snow albedo is low (0.3-0.5).
1694            !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j
1695            albsn = 0.7
1696          endif
1697
1698          emiss= emissn
1699      else
1700          albsn   = max(keep_snow_albedo*alb_snow,               &
1701                    min((alb_snow_free +                         &
1702            (alb_snow - alb_snow_free) * snowfrac), alb_snow))
1703             if(newsn > 0. .and. keep_snow_albedo > 0.9 .and. albsn < 0.4) then
1704             !-- Albedo correction with fresh snow and deep snow pack
1705             !-- will reduce warm bias in western Canada
1706             !-- and US West coast, where max snow albedo is low (0.3-0.5).
1707             !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j
1708               albsn = 0.7
1709             !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j
1710             endif
1711
1712          emiss   = max(keep_snow_albedo*emissn,                 &
1713                    min((emiss_snowfree +                         &
1714            (emissn - emiss_snowfree) * snowfrac), emissn))
1715      endif
1716     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1717   print *,'snow on soil albsn,emiss,snow_mosaic',i,j,albsn,emiss,snow_mosaic
1718     endif
1719 !28mar11  if canopy is covered with snow to 95% of its capacity and snow depth is
1720 ! higher than patchy snow treshold - then snow albedo is not less than 0.55
1721 ! (inspired by the flight from fairbanks to seatle)
1722 !test      if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then
1723 !        albsn=max(alb_snow,0.55)
1724 !      endif
1725
1726 !-- alb dependence on snow temperature. when snow temperature is
1727 !-- below critical value of -10c - no change to albedo.
1728 !-- if temperature is higher that -10c then albedo is decreasing.
1729 !-- the minimum albedo at t=0c for snow on land is 15% less than
1730 !-- albedo of temperatures below -10c.
1731      if(albsn.lt.0.4 .or. keep_snow_albedo==1) then
1732         alb=albsn
1733       else
1734 !-- change albedo when no fresh snow and snow albedo is higher than 0.5
1735         alb = min(albsn,max(albsn - 0.1*(soilt - 263.15)/       &
1736                 (273.15-263.15)*albsn, albsn - 0.05))
1737       endif
1738     else
1739 !----- snow on ice
1740      if( snow_mosaic == 1.) then
1741          albsn=alb_snow
1742          emiss= emissn
1743      else
1744          albsn   = max(keep_snow_albedo*alb_snow,               &
1745                    min((albice + (alb_snow - albice) * snowfrac), alb_snow))
1746          emiss   = max(keep_snow_albedo*emissn,                 &
1747                    min((emiss_snowfree +                        &
1748            (emissn - emiss_snowfree) * snowfrac), emissn))
1749      endif
1750
1751     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1752   print *,'snow on ice snow_mosaic,albsn,emiss',i,j,albsn,emiss,snow_mosaic
1753     endif
1754 !-- alb dependence on snow temperature. when snow temperature is
1755 !-- below critical value of -10c - no change to albedo.
1756 !-- if temperature is higher that -10c then albedo is decreasing.
1757       if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.1.)then
1758        alb=albsn
1759       else
1760 !-- change albedo when no fresh snow
1761        alb = min(albsn,max(albsn - 0.15*albsn*(soilt - 263.15)/  &
1762                 (273.15-263.15), albsn - 0.1))
1763       endif
1764
1765     endif
1766
1767     if (snow_mosaic==1.) then
1768 !may 2014 - treat separately snow-free and snow-covered areas
1769
1770        if(seaice .lt. 0.5) then
1771 !  land
1772 ! portion not covered with snow
1773 ! compute absorbed gsw for snow-free portion
1774
1775          gswnew=gswin*(1.-alb_snow_free)
1776 !--------------
1777          t3      = stbolt*soilt*soilt*soilt
1778          upflux  = t3 *soilt
1779          xinet   = emiss_snowfree*(glw-upflux)
1780          rnet    = gswnew + xinet
1781     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1782      print *,'fractional snow - snowfrac=',snowfrac
1783      print *,'snowfrac<1 gswin,gswnew -',gswin,gswnew,'soilt, rnet',soilt,rnet
1784     endif
1785            do k=1,nzs
1786           soilm1ds(k) = soilm1d(k)
1787           ts1ds(k) = ts1d(k)
1788           smfrkeeps(k) = smfrkeep(k)
1789           keepfrs(k) = keepfr(k)
1790           soilices(k) = soilice(k)
1791           soiliqws(k) = soiliqw(k)
1792             enddo
1793           soilts = soilt
1794           qvgs = qvg
1795           qsgs = qsg
1796           qcgs = qcg
1797           csts = cst
1798           mavails = mavail
1799           smelt=0.
1800           runoff1s=0.
1801           runoff2s=0.
1802
1803           ilands = ivgtyp
1804          call soil(spp_lsm,rstochcol,fieldcol_sf,               &
1805 !--- input variables
1806             i,j,ilands,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
1807             prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,gswin,     &
1808             emiss_snowfree,rnet,qkms,tkms,pc,csts,dripliq,      &
1809             infwater,rho,vegfrac,lai,myj,                       &
1810 !--- soil fixed fields
1811             qwrtz,rhocs,dqm,qmin,ref,wilt,                      &
1812             psis,bclh,ksat,sat,cn,                              &
1813             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
1814 !--- constants
1815             lv,cp,rovcp,g0,cw,stbolt,tabs,                      &
1816             kqwrtz,kice,kwt,                                    &
1817 !--- output variables for snow-free portion
1818             soilm1ds,ts1ds,smfrkeeps,keepfrs,                   &
1819             dews,soilts,qvgs,qsgs,qcgs,edir1s,ec1s,             &
1820             ett1s,eetas,qfxs,hfxs,ss,evapls,prcpls,fltots,runoff1s, &
1821             runoff2s,mavails,soilices,soiliqws,                 &
1822             infiltrs,smf)
1823         else
1824 ! sea ice
1825 ! portion not covered with snow
1826 ! compute absorbed gsw for snow-free portion
1827
1828          gswnew=gswin*(1.-albice)
1829 !--------------
1830          t3      = stbolt*soilt*soilt*soilt
1831          upflux  = t3 *soilt
1832          xinet   = emiss_snowfree*(glw-upflux)
1833          rnet    = gswnew + xinet
1834     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1835      print *,'fractional snow - snowfrac=',snowfrac
1836      print *,'snowfrac<1 gswin,gswnew -',gswin,gswnew,'soilt, rnet',soilt,rnet
1837     endif
1838             do k=1,nzs
1839           ts1ds(k) = ts1d(k)
1840             enddo
1841           soilts = soilt
1842           qvgs = qvg
1843           qsgs = qsg
1844           qcgs = qcg
1845           smelt=0.
1846           runoff1s=0.
1847           runoff2s=0.
1848
1849           call sice(                                            &
1850 !--- input variables
1851             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
1852             prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,           &
1853             0.98,rnet,qkms,tkms,rho,myj,                        &
1854 !--- sea ice parameters
1855             tice,rhosice,capice,thdifice,                       &
1856             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
1857 !--- constants
1858             lv,cp,rovcp,cw,stbolt,tabs,                         &
1859 !--- output variable
1860             ts1ds,dews,soilts,qvgs,qsgs,qcgs,                   &
1861             eetas,qfxs,hfxs,ss,evapls,prcpls,fltots             &
1862                                                                 )
1863            edir1 = eeta*1.e-3
1864            ec1 = 0.
1865            ett1 = 0.
1866            runoff1 = prcpms
1867            runoff2 = 0.
1868            mavail = 1.
1869            infiltr=0.
1870            cst=0.
1871             do k=1,nzs
1872                soilm1d(k)=1.
1873                soiliqw(k)=0.
1874                soilice(k)=1.
1875                smfrkeep(k)=1.
1876                keepfr(k)=0.
1877             enddo
1878         endif ! seaice < 0.5
1879
1880 !return gswnew to incoming solar
1881     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1882      print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb
1883     endif
1884
1885     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1886        print *,'incoming gswnew snowfrac<1 -',gswnew
1887     endif
1888     endif ! snow_mosaic=1.
1889
1890 !--- recompute absorbed solar radiation and net radiation
1891 !--- for updated value of snow albedo - alb
1892          gswnew=gswin*(1.-alb)
1893 !      print *,'snow fraction gswnew',gswnew,'alb=',alb
1894 !--------------
1895          t3      = stbolt*soilt*soilt*soilt
1896          upflux  = t3 *soilt
1897          xinet   = emiss*(glw-upflux)
1898          rnet    = gswnew + xinet
1899     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1900         print *,'rnet=',rnet
1901         print *,'snow - i,j,newsn,snwe,snhei,gsw,gswnew,glw,upflux,alb',&
1902                  i,j,newsn,snwe,snhei,gsw,gswnew,glw,upflux,alb
1903     endif
1904
1905       if (seaice .lt. 0.5) then
1906 ! land
1907            if(snow_mosaic==1.)then
1908               snfr=1.
1909            else
1910               snfr=snowfrac
1911            endif
1912          call snowsoil (spp_lsm,rstochcol,fieldcol_sf,     & !--- input variables
1913             i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot,         &
1914             meltfactor,rhonewsn,snhei_crit,                     &  ! new
1915             iland,prcpms,rainf,newsn,snhei,snwe,snfr,           &
1916             rhosn,patm,qvatm,qcatm,                             &
1917             glw,gswnew,gswin,emiss,rnet,ivgtyp,                 &
1918             qkms,tkms,pc,cst,dripsn,infwater,                   &
1919             rho,vegfrac,alb,znt,lai,                            &
1920             myj,                                                &
1921 !--- soil fixed fields
1922             qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,       &
1923             sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq,              &
1924 !--- constants
1925             lv,cp,rovcp,g0,cw,stbolt,tabs,                      &
1926             kqwrtz,kice,kwt,                                    &
1927 !--- output variables
1928             ilnb,snweprint,snheiprint,rsm,                      &
1929             soilm1d,ts1d,smfrkeep,keepfr,                       &
1930             dew,soilt,soilt1,tsnav,qvg,qsg,qcg,                 &
1931             smelt,snoh,snflx,snom,edir1,ec1,ett1,eeta,          &
1932             qfx,hfx,s,sublim,prcpl,fltot,runoff1,runoff2,       &
1933             mavail,soilice,soiliqw,infiltr                      )
1934        else
1935 ! sea ice
1936            if(snow_mosaic==1.)then
1937               snfr=1.
1938            else
1939               snfr=snowfrac
1940            endif
1941
1942          call snowseaice (                                      &
1943             i,j,isoil,delt,ktau,conflx,nzs,nddzs,               &
1944             meltfactor,rhonewsn,snhei_crit,                     &  ! new
1945             iland,prcpms,rainf,newsn,snhei,snwe,snfr,           &
1946             rhosn,patm,qvatm,qcatm,                             &
1947             glw,gswnew,emiss,rnet,                              &
1948             qkms,tkms,rho,myj,                                  &
1949 !--- sea ice parameters
1950             alb,znt,                                            &
1951             tice,rhosice,capice,thdifice,                       &
1952             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
1953 !--- constants
1954             lv,cp,rovcp,cw,stbolt,tabs,                         &
1955 !--- output variables
1956             ilnb,snweprint,snheiprint,rsm,ts1d,                 &
1957             dew,soilt,soilt1,tsnav,qvg,qsg,qcg,                 &
1958             smelt,snoh,snflx,snom,eeta,                         &
1959             qfx,hfx,s,sublim,prcpl,fltot                        &
1960                                                                 )
1961            edir1 = eeta*1.e-3
1962            ec1 = 0.
1963            ett1 = 0.
1964            runoff1 = smelt
1965            runoff2 = 0.
1966            mavail = 1.
1967            infiltr=0.
1968            cst=0.
1969             do k=1,nzs
1970                soilm1d(k)=1.
1971                soiliqw(k)=0.
1972                soilice(k)=1.
1973                smfrkeep(k)=1.
1974                keepfr(k)=0.
1975             enddo
1976        endif
1977
1978
1979      if (snow_mosaic==1.) then
1980 ! may 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist,
1981 ! etc.
1982         if(seaice .lt. 0.5) then
1983 ! land
1984    if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
1985       print *,'soilt snow on land', ktau, i,j,soilt
1986       print *,'soilt on snow-free land', i,j,soilts
1987       print *,'ts1d,ts1ds',i,j,ts1d,ts1ds
1988       print *,' snow flux',i,j, snflx
1989       print *,' ground flux on snow-covered land',i,j, s
1990       print *,' ground flux on snow-free land', i,j,ss
1991       print *,' csts, cst', i,j,csts,cst
1992    endif
1993             do k=1,nzs
1994           soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac
1995           ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac
1996           smfrkeep(k) = smfrkeeps(k)*(1.-snowfrac) + smfrkeep(k)*snowfrac
1997        if(snowfrac > 0.5) then
1998           keepfr(k) = keepfr(k)
1999        else
2000           keepfr(k) = keepfrs(k)
2001        endif
2002           soilice(k) = soilices(k)*(1.-snowfrac) + soilice(k)*snowfrac
2003           soiliqw(k) = soiliqws(k)*(1.-snowfrac) + soiliqw(k)*snowfrac
2004             enddo
2005           dew = dews*(1.-snowfrac) + dew*snowfrac
2006           soilt = soilts*(1.-snowfrac) + soilt*snowfrac
2007           qvg = qvgs*(1.-snowfrac) + qvg*snowfrac
2008           qsg = qsgs*(1.-snowfrac) + qsg*snowfrac
2009           qcg = qcgs*(1.-snowfrac) + qcg*snowfrac
2010           edir1 = edir1s*(1.-snowfrac) + edir1*snowfrac
2011           ec1 = ec1s*(1.-snowfrac) + ec1*snowfrac
2012           cst = csts*(1.-snowfrac) + cst*snowfrac
2013           ett1 = ett1s*(1.-snowfrac) + ett1*snowfrac
2014           eeta = eetas*(1.-snowfrac) + eeta*snowfrac
2015           qfx = qfxs*(1.-snowfrac) + qfx*snowfrac
2016           hfx = hfxs*(1.-snowfrac) + hfx*snowfrac
2017           s = ss*(1.-snowfrac) + s*snowfrac
2018           evapl = evapls*(1.-snowfrac)
2019           sublim = sublim*snowfrac
2020           prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac
2021           fltot = fltots*(1.-snowfrac) + fltot*snowfrac
2022 !alb
2023           alb   = max(keep_snow_albedo*alb,              &
2024                   min((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb))
2025
2026           emiss = max(keep_snow_albedo*emissn,           &
2027                   min((emiss_snowfree +                  &
2028               (emissn - emiss_snowfree) * snowfrac), emissn))
2029
2030           runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac
2031           runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac
2032           mavail = mavails*(1.-snowfrac) + 1.*snowfrac
2033           infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac
2034
2035     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2036       print *,' ground flux combined', i,j, s
2037       print *,'soilt combined on land', soilt
2038       print *,'ts combined on land', ts1d
2039     endif
2040        else
2041 ! sea ice
2042 ! now combine fluxes for snow-free sea ice and snow-covered area
2043     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2044       print *,'soilt snow on ice', soilt
2045     endif
2046             do k=1,nzs
2047           ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac
2048             enddo
2049           dew = dews*(1.-snowfrac) + dew*snowfrac
2050           soilt = soilts*(1.-snowfrac) + soilt*snowfrac
2051           qvg = qvgs*(1.-snowfrac) + qvg*snowfrac
2052           qsg = qsgs*(1.-snowfrac) + qsg*snowfrac
2053           qcg = qcgs*(1.-snowfrac) + qcg*snowfrac
2054           eeta = eetas*(1.-snowfrac) + eeta*snowfrac
2055           qfx = qfxs*(1.-snowfrac) + qfx*snowfrac
2056           hfx = hfxs*(1.-snowfrac) + hfx*snowfrac
2057           s = ss*(1.-snowfrac) + s*snowfrac
2058           sublim = eeta
2059           prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac
2060           fltot = fltots*(1.-snowfrac) + fltot*snowfrac
2061 !alb
2062           alb   = max(keep_snow_albedo*alb,              &
2063                   min((albice + (alb - alb_snow_free) * snowfrac), alb))
2064
2065           emiss = max(keep_snow_albedo*emissn,           &
2066                   min((emiss_snowfree +                  &
2067               (emissn - emiss_snowfree) * snowfrac), emissn))
2068
2069           runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac
2070           runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac
2071     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2072       print *,'soilt combined on ice', soilt
2073     endif
2074        endif
2075      endif ! snow_mosaic = 1.
2076
2077      if(snhei.eq.0.) then
2078      !-- all snow is melted
2079        alb=alb_snow_free
2080        iland=ivgtyp
2081      else
2082      !-- snow on the ground
2083       if(isncovr_opt == 1) then
2084          snowfrac=min(1.,snhei/(2.*snhei_crit))
2085       elseif(isncovr_opt == 2) then
2086         snowfrac=min(1.,snhei/(2.*snhei_crit))
2087         !if(ivgtyp == glacier .or. ivgtyp == bare) then
2088         !-- sparsely vegetated or land ice
2089         !  snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**1.))
2090         !else
2091           !-- niu&yang: znt=0.01 m for 1 degree (100km) resolution tests
2092           !  on 3-km scale use actual roughness, but not higher than 0.2 m.
2093           !  the factor is 20 for forests (~100/dx = 33.)
2094         snowfrac2 = tanh( snhei/(2.5 * min(0.2,znt) *(rhosn/rhonewsn)**1.))
2095         !endif
2096         !-- snow fraction is average between method 1 and 2
2097         snowfrac = 0.5*(snowfrac+snowfrac2)
2098       else
2099       !-- isncovr_opt=3
2100         !m = mfsno(ivgtyp) ! vegetation dependent facsnf/msnf from noah mp
2101         m = 1.
2102         !-- for rrfs a factor 10. was added to 'facsnf' to get reasonal values
2103         !of
2104         !   snow cover fractions on the 3-km scale.
2105         !   this factor is scale dependent.
2106         snowfrac = tanh( snhei/(10. * sncovfac(ivgtyp)*(rhosn/rhonewsn)**m))
2107       endif
2108
2109      endif
2110
2111      if(ivgtyp == urban) snowfrac=min(0.75,snowfrac)
2112
2113 !  run-total accumulated snow based on snowfall and snowmelt in [m]
2114
2115       snowfallac = snowfallac + newsn * 1.e3    ! accumulated snow depth [mm], using variable snow den
2116       !snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))
2117
2118    else
2119 !--- no snow
2120            snheiprint=0.
2121            snweprint=0.
2122            smelt=0.
2123
2124 !--------------
2125          t3      = stbolt*soilt*soilt*soilt
2126          upflux  = t3 *soilt
2127          xinet   = emiss*(glw-upflux)
2128          rnet    = gswnew + xinet
2129     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2130      print *,'no snow on the ground gswnew -',gswnew,'rnet=',rnet
2131     endif
2132
2133        if(seaice .lt. 0.5) then
2134 !  land
2135          call soil(spp_lsm,rstochcol,fieldcol_sf,               &
2136 !--- input variables
2137             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
2138             prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,gswin,     &
2139             emiss,rnet,qkms,tkms,pc,cst,drip,infwater,          &
2140             rho,vegfrac,lai,myj,                                &
2141 !--- soil fixed fields
2142             qwrtz,rhocs,dqm,qmin,ref,wilt,                      &
2143             psis,bclh,ksat,sat,cn,                              &
2144             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
2145 !--- constants
2146             lv,cp,rovcp,g0,cw,stbolt,tabs,                      &
2147             kqwrtz,kice,kwt,                                    &
2148 !--- output variables
2149             soilm1d,ts1d,smfrkeep,keepfr,                       &
2150             dew,soilt,qvg,qsg,qcg,edir1,ec1,                    &
2151             ett1,eeta,qfx,hfx,s,evapl,prcpl,fltot,runoff1,      &
2152             runoff2,mavail,soilice,soiliqw,                     &
2153             infiltr,smf)
2154         else
2155 ! sea ice
2156 ! if current ice albedo is not the same as from the previous time step, then
2157 ! update gsw, alb and rnet for surface energy budget
2158          if(alb.ne.albice) gswnew=gsw/(1.-alb)*(1.-albice)
2159          alb=albice
2160          rnet    = gswnew + xinet
2161
2162           call sice(                                            &
2163 !--- input variables
2164             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
2165             prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,           &
2166             emiss,rnet,qkms,tkms,rho,myj,                       &
2167 !--- sea ice parameters
2168             tice,rhosice,capice,thdifice,                       &
2169             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
2170 !--- constants
2171             lv,cp,rovcp,cw,stbolt,tabs,                         &
2172 !--- output variables
2173             ts1d,dew,soilt,qvg,qsg,qcg,                         &
2174             eeta,qfx,hfx,s,evapl,prcpl,fltot                          &
2175                                                                 )
2176            edir1 = eeta*1.e-3
2177            ec1 = 0.
2178            ett1 = 0.
2179            runoff1 = prcpms
2180            runoff2 = 0.
2181            mavail = 1.
2182            infiltr=0.
2183            cst=0.
2184             do k=1,nzs
2185                soilm1d(k)=1.
2186                soiliqw(k)=0.
2187                soilice(k)=1.
2188                smfrkeep(k)=1.
2189                keepfr(k)=0.
2190             enddo
2191         endif
2192
2193         endif
2194
2195 !      return
2196 !       end
2197 !---------------------------------------------------------------
2198    end subroutine sfctmp
2199 !---------------------------------------------------------------
2200
2201
2202        function qsn(tn,t)
2203 !****************************************************************
2204    real,     dimension(1:5001),  intent(in   )   ::  t
2205    real,     intent(in  )   ::  tn
2206
2207       real    qsn, r,r1,r2
2208       integer i
2209
2210        r=(tn-173.15)/.05+1.
2211        i=int(r)
2212        if(i.ge.1) goto 10
2213        i=1
2214        r=1.
2215   10   if(i.le.5000) goto 20
2216        i=5000
2217        r=5001.
2218   20   r1=t(i)
2219        r2=r-i
2220        qsn=(t(i+1)-r1)*r2 + r1
2221 !       print *,' in qsn, i,r,r1,r2,t(i+1),tn, qsn', i,r,r1,r2,t(i+1),tn,qsn
2222 !       return
2223 !       end
2224 !-----------------------------------------------------------------------
2225   end function qsn
2226 !------------------------------------------------------------------------
2227
2228
2229         subroutine soil (spp_lsm,rstochcol, fieldcol_sf,     &
2230 !--- input variables
2231             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,&
2232             prcpms,rainf,patm,qvatm,qcatm,                   &
2233             glw,gsw,gswin,emiss,rnet,                        &
2234             qkms,tkms,pc,cst,drip,infwater,rho,vegfrac,lai,  &
2235             myj,                                             &
2236 !--- soil fixed fields
2237             qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,    &
2238             sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq,           &
2239 !--- constants
2240             xlv,cp,rovcp,g0_p,cw,stbolt,tabs,                &
2241             kqwrtz,kice,kwt,                                 &
2242 !--- output variables
2243             soilmois,tso,smfrkeep,keepfr,                    &
2244             dew,soilt,qvg,qsg,qcg,                           &
2245             edir1,ec1,ett1,eeta,qfx,hfx,s,evapl,             &
2246             prcpl,fltot,runoff1,runoff2,mavail,soilice,      &
2247             soiliqw,infiltrp,smf)
2248
2249 !*************************************************************
2250 !   energy and moisture budget for vegetated surfaces
2251 !   without snow, heat diffusion and richards eqns. in
2252 !   soil
2253 !
2254 !     delt - time step (s)
2255 !     ktau - numver of time step
2256 !     conflx - depth of constant flux layer (m)
2257 !     j,i - the location of grid point
2258 !     ime, jme, kme, nzs - dimensions of the domain
2259 !     nroot - number of levels within the root zone
2260 !     prcpms - precipitation rate in m/s
2261 !     patm - pressure [bar]
2262 !     qvatm,qcatm - cloud and water vapor mixing ratio (kg/kg)
2263 !                   at the first atm. level
2264 !     glw, gsw - incoming longwave and absorbed shortwave
2265 !                radiation at the surface (w/m^2)
2266 !     emiss,rnet - emissivity of the ground surface (0-1) and net
2267 !                  radiation at the surface (w/m^2)
2268 !     qkms - exchange coefficient for water vapor in the
2269 !              surface layer (m/s)
2270 !     tkms - exchange coefficient for heat in the surface
2271 !              layer (m/s)
2272 !     pc - plant coefficient (resistance) (0-1)
2273 !     rho - density of atmosphere near sueface (kg/m^3)
2274 !     vegfrac - greeness fraction
2275 !     rhocs - volumetric heat capacity of dry soil
2276 !     dqm, qmin - porosity minus residual soil moisture qmin (m^3/m^3)
2277 !     ref, wilt - field capacity soil moisture and the
2278 !                 wilting point (m^3/m^3)
2279 !     psis - matrix potential at saturation (m)
2280 !     bclh - exponent for clapp-hornberger parameterization
2281 !     ksat - saturated hydraulic conductivity (m/s)
2282 !     sat - maximum value of water intercepted by canopy (m)
2283 !     cn - exponent for calculation of canopy water
2284 !     zsmain - main levels in soil (m)
2285 !     zshalf - middle of the soil layers (m)
2286 !     dtdzs,dtdzs2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil
2287 !     tbq - table to define saturated mixing ration
2288 !           of water vapor for given temperature and pressure
2289 !     soilmois,tso - soil moisture (m^3/m^3) and temperature (k)
2290 !     dew -  dew in kg/m^2s
2291 !     soilt - skin temperature (k)
2292 !     qsg,qvg,qcg - saturated mixing ratio, mixing ratio of
2293 !                   water vapor and cloud at the ground
2294 !                   surface, respectively (kg/kg)
2295 !     edir1, ec1, ett1, eeta - direct evaporation, evaporation of
2296 !            canopy water, transpiration in kg m-2 s-1 and total
2297 !            evaporation in m s-1.
2298 !     qfx, hfx - latent and sensible heat fluxes (w/m^2)
2299 !     s - soil heat flux in the top layer (w/m^2)
2300 !     runoff - surface runoff (m/s)
2301 !     runoff2 - underground runoff (m)
2302 !     mavail - moisture availability in the top soil layer (0-1)
2303 !     infiltrp - infiltration flux from the top of soil domain (m/s)
2304 !
2305 !*****************************************************************
2306         implicit none
2307 !-----------------------------------------------------------------
2308
2309 !--- input variables
2310
2311    integer,  intent(in   )   ::  nroot,ktau,nzs                , &
2312                                  nddzs                    !nddzs=2*(nzs-2)
2313    integer,  intent(in   )   ::  i,j,iland,isoil
2314    real,     intent(in   )   ::  delt,conflx
2315    logical,  intent(in   )   ::  myj
2316 !--- 3-d atmospheric variables
2317    real,                                                         &
2318             intent(in   )    ::                            patm, &
2319                                                           qvatm, &
2320                                                           qcatm
2321 !--- 2-d variables
2322    real,                                                         &
2323             intent(in   )    ::                             glw, &
2324                                                             gsw, &
2325                                                           gswin, &
2326                                                           emiss, &
2327                                                             rho, &
2328                                                              pc, &
2329                                                         vegfrac, &
2330                                                             lai, &
2331                                                        infwater, &
2332                                                            qkms, &
2333                                                            tkms
2334
2335 !--- soil properties
2336    real,                                                         &
2337             intent(in   )    ::                           rhocs, &
2338                                                            bclh, &
2339                                                             dqm, &
2340                                                            ksat, &
2341                                                            psis, &
2342                                                            qmin, &
2343                                                           qwrtz, &
2344                                                             ref, &
2345                                                            wilt
2346
2347    real,     intent(in   )   ::                              cn, &
2348                                                              cw, &
2349                                                          kqwrtz, &
2350                                                            kice, &
2351                                                             kwt, &
2352                                                             xlv, &
2353                                                             g0_p
2354
2355
2356    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
2357                                                          zshalf, &
2358                                                          dtdzs2
2359
2360    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
2361
2362    real,     dimension(1:5001), intent(in)  ::              tbq
2363
2364
2365 !--- input/output variables
2366 !-------- 3-d soil moisture and temperature
2367    real,     dimension( 1:nzs )                                , &
2368              intent(inout)   ::                             tso, &
2369                                                        soilmois, &
2370                                                        smfrkeep
2371
2372    real,     dimension(1:nzs), intent(in)  ::          rstochcol
2373    real,     dimension(1:nzs), intent(inout) ::     fieldcol_sf
2374
2375
2376    real,     dimension( 1:nzs )                                , &
2377              intent(inout)   ::                          keepfr
2378
2379 !-------- 2-d variables
2380    real,                                                         &
2381              intent(inout)   ::                             dew, &
2382                                                             cst, &
2383                                                            drip, &
2384                                                           edir1, &
2385                                                             ec1, &
2386                                                            ett1, &
2387                                                            eeta, &
2388                                                           evapl, &
2389                                                           prcpl, &
2390                                                          mavail, &
2391                                                             qvg, &
2392                                                             qsg, &
2393                                                             qcg, &
2394                                                            rnet, &
2395                                                             qfx, &
2396                                                             hfx, &
2397                                                               s, &
2398                                                             sat, &
2399                                                         runoff1, &
2400                                                         runoff2, &
2401                                                           soilt
2402
2403 !-------- 1-d variables
2404    integer                   , intent(in)  ::      spp_lsm
2405    real,     dimension(1:nzs), intent(out)  ::          soilice, &
2406                                                         soiliqw
2407
2408 !--- local variables
2409
2410    real    ::  infiltrp, transum                               , &
2411                rainf,  prcpms                                  , &
2412                tabs, t3, upflux, xinet
2413    real    ::  cp,rovcp,g0,lv,stbolt,xlmelt,dzstop             , &
2414                can,epot,fac,fltot,ft,fq,hft                    , &
2415                q1,ras,rhoice,sph                               , &
2416                trans,zn,ci,cvw,tln,tavln,pi                    , &
2417                dd1,cmc2ms,drycan,wetcan                        , &
2418                infmax,riw, x
2419    real,     dimension(1:nzs)  ::  transp,cap,diffu,hydro      , &
2420                                    thdif,tranf,tav,soilmoism   , &
2421                                    soilicem,soiliqwm,detal     , &
2422                                    fwsat,lwsat,told,smold
2423
2424    real                        ::  soiltold,smf
2425    real    :: soilres, alfa, fex, fex_fc, fc, psit
2426
2427    integer ::  nzs1,nzs2,k
2428
2429 !-----------------------------------------------------------------
2430
2431 !-- define constants
2432         rhoice=900.
2433         ci=rhoice*2100.
2434         xlmelt=3.35e+5
2435         cvw=cw
2436
2437         prcpl=prcpms
2438
2439         smf=0.
2440         soiltold = soilt
2441
2442         wetcan=0.
2443         drycan=1.
2444
2445 !--- initializing local arrays
2446         do k=1,nzs
2447           transp   (k)=0.
2448           soilmoism(k)=0.
2449           soilice  (k)=0.
2450           soiliqw  (k)=0.
2451           soilicem (k)=0.
2452           soiliqwm (k)=0.
2453           lwsat    (k)=0.
2454           fwsat    (k)=0.
2455           tav      (k)=0.
2456           cap      (k)=0.
2457           thdif    (k)=0.
2458           diffu    (k)=0.
2459           hydro    (k)=0.
2460           tranf    (k)=0.
2461           detal    (k)=0.
2462           told     (k)=0.
2463           smold    (k)=0.
2464         enddo
2465
2466           nzs1=nzs-1
2467           nzs2=nzs-2
2468         dzstop=1./(zsmain(2)-zsmain(1))
2469         ras=rho*1.e-3
2470         riw=rhoice*1.e-3
2471
2472 !--- computation of volumetric content of ice in soil
2473
2474          do k=1,nzs
2475 !- main levels
2476          tln=log(tso(k)/273.15)
2477          if(tln.lt.0.) then
2478            soiliqw(k)=(dqm+qmin)*(xlmelt*                        &
2479          (tso(k)-273.15)/tso(k)/9.81/psis)                       &
2480           **(-1./bclh)-qmin
2481            soiliqw(k)=max(0.,soiliqw(k))
2482            soiliqw(k)=min(soiliqw(k),soilmois(k))
2483            soilice(k)=(soilmois(k)-soiliqw(k))/riw
2484
2485 !---- melting and freezing is balanced, soil ice cannot increase
2486        if(keepfr(k).eq.1.) then
2487            soilice(k)=min(soilice(k),smfrkeep(k))
2488            soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw)
2489        endif
2490
2491          else
2492            soilice(k)=0.
2493            soiliqw(k)=soilmois(k)
2494          endif
2495
2496           enddo
2497
2498           do k=1,nzs1
2499 !- middle of soil layers
2500          tav(k)=0.5*(tso(k)+tso(k+1))
2501          soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1))
2502          tavln=log(tav(k)/273.15)
2503
2504          if(tavln.lt.0.) then
2505            soiliqwm(k)=(dqm+qmin)*(xlmelt*                       &
2506          (tav(k)-273.15)/tav(k)/9.81/psis)                       &
2507           **(-1./bclh)-qmin
2508            fwsat(k)=dqm-soiliqwm(k)
2509            lwsat(k)=soiliqwm(k)+qmin
2510            soiliqwm(k)=max(0.,soiliqwm(k))
2511            soiliqwm(k)=min(soiliqwm(k), soilmoism(k))
2512            soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw
2513 !---- melting and freezing is balanced, soil ice cannot increase
2514        if(keepfr(k).eq.1.) then
2515            soilicem(k)=min(soilicem(k),                          &
2516                    0.5*(smfrkeep(k)+smfrkeep(k+1)))
2517            soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw)
2518            fwsat(k)=dqm-soiliqwm(k)
2519            lwsat(k)=soiliqwm(k)+qmin
2520        endif
2521
2522          else
2523            soilicem(k)=0.
2524            soiliqwm(k)=soilmoism(k)
2525            lwsat(k)=dqm+qmin
2526            fwsat(k)=0.
2527          endif
2528
2529           enddo
2530
2531           do k=1,nzs
2532            if(soilice(k).gt.0.) then
2533              smfrkeep(k)=soilice(k)
2534            else
2535              smfrkeep(k)=soilmois(k)/riw
2536            endif
2537           enddo
2538 !******************************************************************
2539 ! soilprop computes thermal diffusivity, and diffusional and
2540 !          hydraulic condeuctivities
2541 !******************************************************************
2542           call soilprop(spp_lsm,rstochcol,fieldcol_sf,       &
2543 !--- input variables
2544                nzs,fwsat,lwsat,tav,keepfr,                        &
2545                soilmois,soiliqw,soilice,                          &
2546                soilmoism,soiliqwm,soilicem,                       &
2547 !--- soil fixed fields
2548                qwrtz,rhocs,dqm,qmin,psis,bclh,ksat,               &
2549 !--- constants
2550                riw,xlmelt,cp,g0_p,cvw,ci,                         &
2551                kqwrtz,kice,kwt,                                   &
2552 !--- output variables
2553                thdif,diffu,hydro,cap)
2554
2555 !********************************************************************
2556 !--- calculation of canopy water (Smirnova et al., 1996, eq.16) and dew
2557
2558 !        drip=0.
2559 !        dd1=0.
2560
2561         fq=qkms
2562
2563         q1=-qkms*ras*(qvatm - qsg)
2564
2565         dew=0.
2566         if(qvatm.ge.qsg)then
2567           dew=fq*(qvatm-qsg)
2568         endif
2569
2570 !        if(dew.ne.0.)then
2571 !          dd1=cst+delt*(prcpms +dew*ras)
2572 !        else
2573 !          dd1=cst+                                          &
2574 !            delt*(prcpms+ras*fq*(qvatm-qsg)                 &
2575 !           *(cst/sat)**cn)
2576 !        endif
2577
2578 !          dd1=cst+delt*prcpms
2579
2580 !       if(dd1.lt.0.) dd1=0.
2581 !        if(vegfrac.eq.0.)then
2582 !          cst=0.
2583 !          drip=0.
2584 !        endif
2585 !        if (vegfrac.gt.0.) then
2586 !          cst=dd1
2587 !        if(cst.gt.sat) then
2588 !          cst=sat
2589 !          drip=dd1-sat
2590 !        endif
2591 !        endif
2592 !
2593 !--- wetcan is the fraction of vegetated area covered by canopy
2594 !--- water, and drycan is the fraction of vegetated area where
2595 !--- transpiration may take place.
2596
2597           wetcan=min(0.25,max(0.,(cst/sat))**cn)
2598 !          if(lai > 1.) wetcan=wetcan/lai
2599           drycan=1.-wetcan
2600
2601 !**************************************************************
2602 !  transf computes transpiration function
2603 !**************************************************************
2604            call transf(i,j,                                   &
2605 !--- input variables
2606               nzs,nroot,soiliqw,tabs,lai,gswin,               &
2607 !--- soil fixed fields
2608               dqm,qmin,ref,wilt,zshalf,pc,iland,              &
2609 !--- output variables
2610               tranf,transum)
2611
2612
2613 !--- save soil temp and moisture from the beginning of time step
2614           do k=1,nzs
2615            told(k)=tso(k)
2616            smold(k)=soilmois(k)
2617           enddo
2618
2619 ! sakaguchi and zeng (2009) - dry soil resistance to evaporation
2620 !      if (vgtype==11) then   ! modis wetland
2621         alfa=1.
2622 !      else
2623         fex=min(1.,soilmois(1)/dqm)
2624         fex=max(fex,0.01)
2625         psit=psis*fex ** (-bclh)
2626         psit = max(-1.e5, psit)
2627         alfa=min(1.,exp(g*psit/r_v/soilt))
2628 !      endif
2629         alfa=1.
2630 ! field capacity
2631         fc=max(qmin,ref*0.5)
2632         fex_fc=1.
2633       if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then
2634         soilres = 1.
2635       else
2636         fex_fc=min(1.,(soilmois(1)+qmin)/fc)
2637         fex_fc=max(fex_fc,0.01)
2638         soilres=0.25*(1.-cos(piconst*fex_fc))**2.
2639       endif
2640     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2641 !    if (i==421.and.j==280) then
2642      print *,'fex,psit,psis,bclh,g,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc', &
2643               fex,psit,psis,bclh,g,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc
2644     endif
2645
2646 !**************************************************************
2647 !  soiltemp soilves heat budget and diffusion eqn. in soil
2648 !**************************************************************
2649
2650         call soiltemp(                                        &
2651 !--- input variables
2652              i,j,iland,isoil,                                 &
2653              delt,ktau,conflx,nzs,nddzs,nroot,                &
2654              prcpms,rainf,                                    &
2655              patm,tabs,qvatm,qcatm,emiss,rnet,                &
2656              qkms,tkms,pc,rho,vegfrac, lai,                   &
2657              thdif,cap,drycan,wetcan,                         &
2658              transum,dew,mavail,soilres,alfa,                 &
2659 !--- soil fixed fields
2660              dqm,qmin,bclh,zsmain,zshalf,dtdzs,tbq,           &
2661 !--- constants
2662              xlv,cp,g0_p,cvw,stbolt,                          &
2663 !--- output variables
2664              tso,soilt,qvg,qsg,qcg,x)
2665
2666 !************************************************************************
2667
2668 !--- calculation of dew using new value of qsg or transp if no dew
2669         ett1=0.
2670         dew=0.
2671
2672         if(qvatm.ge.qsg)then
2673           dew=qkms*(qvatm-qsg)
2674           ett1=0.
2675           do k=1,nzs
2676             transp(k)=0.
2677           enddo
2678         else
2679
2680           do k=1,nroot
2681             transp(k)=vegfrac*ras*qkms*                       &
2682                     (qvatm-qsg)*                              &
2683                     tranf(k)*drycan/zshalf(nroot+1)
2684                if(transp(k).gt.0.) transp(k)=0.
2685             ett1=ett1-transp(k)
2686           enddo
2687           do k=nroot+1,nzs
2688             transp(k)=0.
2689           enddo
2690         endif
2691
2692 !-- recalculate volumetric content of frozen water in soil
2693          do k=1,nzs
2694 !- main levels
2695            tln=log(tso(k)/273.15)
2696          if(tln.lt.0.) then
2697            soiliqw(k)=(dqm+qmin)*(xlmelt*                     &
2698           (tso(k)-273.15)/tso(k)/9.81/psis)                   &
2699            **(-1./bclh)-qmin
2700            soiliqw(k)=max(0.,soiliqw(k))
2701            soiliqw(k)=min(soiliqw(k),soilmois(k))
2702            soilice(k)=(soilmois(k)-soiliqw(k))/riw
2703 !---- melting and freezing is balanced, soil ice cannot increase
2704        if(keepfr(k).eq.1.) then
2705            soilice(k)=min(soilice(k),smfrkeep(k))
2706            soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw)
2707        endif
2708
2709          else
2710            soilice(k)=0.
2711            soiliqw(k)=soilmois(k)
2712          endif
2713          enddo
2714
2715 !*************************************************************************
2716 ! soilmoist solves moisture budget (Smirnova et al., 1996, eq.22,28)
2717 !           and richards eqn.
2718 !*************************************************************************
2719           call soilmoist (                                     &
2720 !-- input
2721                delt,nzs,nddzs,dtdzs,dtdzs2,riw,                &
2722                zsmain,zshalf,diffu,hydro,                      &
2723                qsg,qvg,qcg,qcatm,qvatm,-infwater,              &
2724                qkms,transp,drip,dew,0.,soilice,vegfrac,        &
2725                0.,soilres,                                     &
2726 !-- soil properties
2727                dqm,qmin,ref,ksat,ras,infmax,                   &
2728 !-- output
2729                soilmois,soiliqw,mavail,runoff1,                &
2730                runoff2,infiltrp)
2731
2732 !--- keepfr is 1 when the temperature and moisture in soil
2733 !--- are both increasing. in this case soil ice should not
2734 !--- be increasing according to the freezing curve.
2735 !--- some part of ice is melted, but additional water is
2736 !--- getting frozen. thus, only structure of frozen soil is
2737 !--- changed, and phase changes are not affecting the heat
2738 !--- transfer. this situation may happen when it rains on the
2739 !--- frozen soil.
2740
2741         do k=1,nzs
2742        if (soilice(k).gt.0.) then
2743           if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then
2744               keepfr(k)=1.
2745           else
2746               keepfr(k)=0.
2747           endif
2748        endif
2749         enddo
2750
2751 !--- the diagnostics of surface fluxes
2752
2753           t3      = stbolt*soiltold*soiltold*soiltold
2754           upflux  = t3 * 0.5*(soiltold+soilt)
2755           xinet   = emiss*(glw-upflux)
2756           hft=-tkms*cp*rho*(tabs-soilt)
2757           hfx=-tkms*cp*rho*(tabs-soilt)                        &
2758                *(p1000mb*0.00001/patm)**rovcp
2759           q1=-qkms*ras*(qvatm - qsg)
2760
2761           cmc2ms = 0.
2762         if (q1.le.0.) then
2763 ! ---  condensation
2764           ec1=0.
2765           edir1=0.
2766           ett1=0.
2767      if(myj) then
2768 !-- moisture flux for coupling with myj pbl
2769           eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3
2770           cst= cst-eeta*delt*vegfrac
2771     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2772         print *,'cond myj eeta',eeta,eeta*xlv, i,j
2773     endif
2774      else ! myj
2775 !-- actual moisture flux from ruc lsm
2776           eeta= - rho*dew
2777           cst=cst+delt*dew*ras * vegfrac
2778     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2779        print *,'cond ruc lsm eeta',eeta,eeta*xlv, i,j
2780     endif
2781      endif ! myj
2782           qfx= xlv*eeta
2783           eeta= - rho*dew
2784         else
2785 ! ---  evaporation
2786           edir1 =-soilres*(1.-vegfrac)*qkms*ras*                      &
2787                   (qvatm-qvg)
2788           cmc2ms=cst/delt*ras
2789           ec1 = q1 * wetcan * vegfrac
2790     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2791        print *,'cst before update=',cst
2792        print *,'ec1=',ec1,'cmc2ms=',cmc2ms
2793      endif
2794 !    endif
2795
2796           cst=max(0.,cst-ec1 * delt)
2797
2798      if (myj) then
2799 !-- moisture flux for coupling with myj pbl
2800           eeta=-soilres*qkms*ras*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*1.e3
2801      else ! myj
2802     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2803        print *,'qkms,ras,qvatm/(1.+qvatm),qvg/(1.+qvg),qsg ', &
2804                 qkms,ras,qvatm/(1.+qvatm),qvg/(1.+qvg),qsg
2805        print *,'q1*(1.-vegfrac),edir1',q1*(1.-vegfrac),edir1
2806        print *,'cst,wetcan,drycan',cst,wetcan,drycan
2807        print *,'ec1=',ec1,'ett1=',ett1,'cmc2ms=',cmc2ms,'cmc2ms*ras=',cmc2ms*ras
2808     endif
2809 !-- actual moisture flux from ruc lsm
2810           eeta = (edir1 + ec1 + ett1)*1.e3
2811     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2812         print *,'ruc lsm eeta',eeta,eeta*xlv
2813     endif
2814      endif ! myj
2815           qfx= xlv * eeta
2816           eeta = (edir1 + ec1 + ett1)*1.e3
2817         endif
2818     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2819      print *,'potential temp hft ',hft
2820      print *,'abs temp hfx ',hfx
2821     endif
2822
2823           evapl=eeta
2824           s=thdif(1)*cap(1)*dzstop*(tso(1)-tso(2))
2825 ! energy budget
2826           fltot=rnet-hft-xlv*eeta-s-x
2827     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2828        print *,'soil - fltot,rnet,hft,qfx,s,x=',i,j,fltot,rnet,hft,xlv*eeta,s,x
2829        print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac',&
2830                 edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac
2831     endif
2832     if(detal(1) .ne. 0.) then
2833 ! smf - energy of phase change in the first soil layer
2834 !        smf=xlmelt*1.e3*(soiliqwm(1)-soiliqwmold(1))/delt
2835          smf=fltot
2836     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
2837      print *,'detal(1),xlmelt,soiliqwm(1),delt',detal(1),xlmelt,soiliqwm(1),delt
2838      print *,'implicit phase change in the first layer - smf=',smf
2839     endif
2840     endif
2841
2842
2843  222    continue
2844
2845  1123    format(i5,8f12.3)
2846  1133    format(i7,8e12.4)
2847   123   format(i6,f6.2,7f8.1)
2848   122   format(1x,2i3,6f8.1,f8.3,f8.2)
2849 !-------------------------------------------------------------------
2850    end subroutine soil
2851 !-------------------------------------------------------------------
2852
2853         subroutine sice (                                       &
2854 !--- input variables
2855             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
2856             prcpms,rainf,patm,qvatm,qcatm,glw,gsw,              &
2857             emiss,rnet,qkms,tkms,rho,myj,                       &
2858 !--- sea ice parameters
2859             tice,rhosice,capice,thdifice,                       &
2860             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
2861 !--- constants
2862             xlv,cp,rovcp,cw,stbolt,tabs,                        &
2863 !--- output variables
2864             tso,dew,soilt,qvg,qsg,qcg,                          &
2865             eeta,qfx,hfx,s,evapl,prcpl,fltot                          &
2866                                                                 )
2867
2868 !*****************************************************************
2869 !   energy budget and  heat diffusion eqns. for
2870 !   sea ice
2871 !*************************************************************
2872
2873         implicit none
2874 !-----------------------------------------------------------------
2875
2876 !--- input variables
2877
2878    integer,  intent(in   )   ::  nroot,ktau,nzs                , &
2879                                  nddzs                    !nddzs=2*(nzs-2)
2880    integer,  intent(in   )   ::  i,j,iland,isoil
2881    real,     intent(in   )   ::  delt,conflx
2882    logical,  intent(in   )   ::  myj
2883 !--- 3-d atmospheric variables
2884    real,                                                         &
2885             intent(in   )    ::                            patm, &
2886                                                           qvatm, &
2887                                                           qcatm
2888 !--- 2-d variables
2889    real,                                                         &
2890             intent(in   )    ::                             glw, &
2891                                                             gsw, &
2892                                                           emiss, &
2893                                                             rho, &
2894                                                            qkms, &
2895                                                            tkms
2896 !--- sea ice properties
2897    real,    dimension(1:nzs)                                   , &
2898             intent(in   )    ::                                  &
2899                                                            tice, &
2900                                                         rhosice, &
2901                                                          capice, &
2902                                                        thdifice
2903
2904
2905    real,     intent(in   )   ::                                  &
2906                                                              cw, &
2907                                                             xlv
2908
2909
2910    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
2911                                                          zshalf, &
2912                                                          dtdzs2
2913
2914    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
2915
2916    real,     dimension(1:5001), intent(in)  ::              tbq
2917
2918
2919 !--- input/output variables
2920 !----soil temperature
2921    real,     dimension( 1:nzs ),  intent(inout)   ::        tso
2922 !-------- 2-d variables
2923    real,                                                         &
2924              intent(inout)   ::                             dew, &
2925                                                            eeta, &
2926                                                           evapl, &
2927                                                           prcpl, &
2928                                                             qvg, &
2929                                                             qsg, &
2930                                                             qcg, &
2931                                                            rnet, &
2932                                                             qfx, &
2933                                                             hfx, &
2934                                                               s, &
2935                                                           soilt
2936
2937 !--- local variables
2938    real    ::  x,x1,x2,x4,tn,denom
2939    real    ::  rainf,  prcpms                                  , &
2940                tabs, t3, upflux, xinet
2941
2942    real    ::  cp,rovcp,g0,lv,stbolt,xlmelt,dzstop             , &
2943                epot,fltot,ft,fq,hft,ras,cvw
2944
2945    real    ::  fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11     , &
2946                pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2       , &
2947                tdenom,qgold,snoh
2948
2949    real    ::  aa1,rhcs, icemelt
2950
2951
2952    real,     dimension(1:nzs)  ::   cotso,rhtso
2953
2954    integer ::  nzs1,nzs2,k,k1,kn,kk
2955
2956 !-----------------------------------------------------------------
2957
2958 !-- define constants
2959         xlmelt=3.35e+5
2960         cvw=cw
2961
2962         prcpl=prcpms
2963
2964           nzs1=nzs-1
2965           nzs2=nzs-2
2966         dzstop=1./(zsmain(2)-zsmain(1))
2967         ras=rho*1.e-3
2968
2969         do k=1,nzs
2970            cotso(k)=0.
2971            rhtso(k)=0.
2972         enddo
2973
2974         cotso(1)=0.
2975         rhtso(1)=tso(nzs)
2976
2977         do 33 k=1,nzs2
2978           kn=nzs-k
2979           k1=2*kn-3
2980           x1=dtdzs(k1)*thdifice(kn-1)
2981           x2=dtdzs(k1+1)*thdifice(kn)
2982           ft=tso(kn)+x1*(tso(kn-1)-tso(kn))                             &
2983              -x2*(tso(kn)-tso(kn+1))
2984           denom=1.+x1+x2-x2*cotso(k)
2985           cotso(k+1)=x1/denom
2986           rhtso(k+1)=(ft+x2*rhtso(k))/denom
2987    33  continue
2988
2989 !************************************************************************
2990 !--- the heat balance equation (Smirnova et al., 1996, eq. 21,26)
2991         rhcs=capice(1)
2992         h=1.
2993         fkt=tkms
2994         d1=cotso(nzs1)
2995         d2=rhtso(nzs1)
2996         tn=soilt
2997         d9=thdifice(1)*rhcs*dzstop
2998         d10=tkms*cp*rho
2999         r211=.5*conflx/delt
3000         r21=r211*cp*rho
3001         r22=.5/(thdifice(1)*delt*dzstop**2)
3002         r6=emiss *stbolt*.5*tn**4
3003         r7=r6/tn
3004         d11=rnet+r6
3005         tdenom=d9*(1.-d1+r22)+d10+r21+r7                              &
3006               +rainf*cvw*prcpms
3007         fkq=qkms*rho
3008         r210=r211*rho
3009         aa=xls*(fkq+r210)/tdenom
3010         bb=(d10*tabs+r21*tn+xls*(qvatm*fkq                            &
3011         +r210*qvg)+d11+d9*(d2+r22*tn)                                 &
3012         +rainf*cvw*prcpms*max(273.15,tabs)                            &
3013          )/tdenom
3014         aa1=aa
3015         pp=patm*1.e3
3016         aa1=aa1/pp
3017     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3018         print *,' vilka-seaice1'
3019         print *,'d10,tabs,r21,tn,qvatm,fkq',                          &
3020                  d10,tabs,r21,tn,qvatm,fkq
3021         print *,'rnet, emiss, stbolt, soilt',rnet, emiss, stbolt, soilt
3022         print *,'r210,qvg,d11,d9,d2,r22,rainf,cvw,prcpms,tdenom',     &
3023                  r210,qvg,d11,d9,d2,r22,rainf,cvw,prcpms,tdenom
3024         print *,'tn,aa1,bb,pp,fkq,r210',                              &
3025                  tn,aa1,bb,pp,fkq,r210
3026     endif
3027         qgold=qsg
3028         call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil)
3029 !--- it is saturation over sea ice
3030         qvg=qs1
3031         qsg=qs1
3032         tso(1)=min(271.4,ts1)
3033         qcg=0.
3034 !--- sea ice melting is not included in this simple approach
3035 !--- soilt - skin temperature
3036           soilt=tso(1)
3037 !---- final solution for soil temperature - tso
3038           do k=2,nzs
3039             kk=nzs-k+1
3040             tso(k)=min(271.4,rhtso(kk)+cotso(kk)*tso(k-1))
3041           end do
3042 !--- calculation of dew using new value of qsg or transp if no dew
3043         dew=0.
3044
3045 !--- the diagnostics of surface fluxes
3046           t3      = stbolt*tn*tn*tn
3047           upflux  = t3 *0.5*(tn+soilt)
3048           xinet   = emiss*(glw-upflux)
3049           hft=-tkms*cp*rho*(tabs-soilt)
3050           hfx=-tkms*cp*rho*(tabs-soilt)                        &
3051                *(p1000mb*0.00001/patm)**rovcp
3052           q1=-qkms*ras*(qvatm - qsg)
3053         if (q1.le.0.) then
3054 ! ---  condensation
3055      if(myj) then
3056 !-- moisture flux for coupling with myj pbl
3057           eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3
3058     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3059        print *,'myj eeta',eeta
3060     endif
3061      else ! myj
3062 !-- actual moisture flux from ruc lsm
3063           dew=qkms*(qvatm-qsg)
3064           eeta= - rho*dew
3065     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3066        print *,'ruc lsm eeta',eeta
3067     endif
3068      endif ! myj
3069           qfx= xls*eeta
3070           eeta= - rho*dew
3071         else
3072 ! ---  evaporation
3073      if(myj) then
3074 !-- moisture flux for coupling with myj pbl
3075           eeta=-qkms*ras*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*1.e3
3076     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3077        print *,'myj eeta',eeta
3078     endif
3079      else ! myj
3080 ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
3081 !-- actual moisture flux from ruc lsm
3082           eeta = q1*1.e3
3083     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3084        print *,'ruc lsm eeta',eeta
3085     endif
3086      endif ! myj
3087           qfx= xls * eeta
3088           eeta = q1*1.e3
3089         endif
3090           evapl=eeta
3091
3092           s=thdifice(1)*capice(1)*dzstop*(tso(1)-tso(2))
3093 ! heat storage in surface layer
3094         snoh=0.
3095 ! there is ice melt
3096          x= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn) +   &
3097             xls*rho*r211*(qsg-qgold)
3098          x=x &
3099 ! "heat" from rain
3100         -rainf*cvw*prcpms*(max(273.15,tabs)-soilt)
3101
3102 !-- excess energy spent on sea ice melt
3103         icemelt=rnet-xls*eeta -hft -s -x
3104     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3105         print *,'icemelt=',icemelt
3106     endif
3107
3108           fltot=rnet-xls*eeta-hft-s-x-icemelt
3109     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3110        print *,'sice - fltot,rnet,hft,qfx,s,snoh,x=', &
3111                        fltot,rnet,hft,xls*eeta,s,icemelt,x
3112     endif
3113
3114 !-------------------------------------------------------------------
3115    end subroutine sice
3116 !-------------------------------------------------------------------
3117
3118
3119
3120         subroutine snowsoil (spp_lsm,rstochcol,fieldcol_sf,&
3121 !--- input variables
3122              i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot,       &
3123              meltfactor,rhonewsn,snhei_crit,                   & ! new
3124              iland,prcpms,rainf,newsnow,snhei,snwe,snowfrac,   &
3125              rhosn,                                            &
3126              patm,qvatm,qcatm,                                 &
3127              glw,gsw,gswin,emiss,rnet,ivgtyp,                  &
3128              qkms,tkms,pc,cst,drip,infwater,                   &
3129              rho,vegfrac,alb,znt,lai,                          &
3130              myj,                                              &
3131 !--- soil fixed fields
3132              qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,     &
3133              sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq,            &
3134 !--- constants
3135              xlv,cp,rovcp,g0_p,cw,stbolt,tabs,                 &
3136              kqwrtz,kice,kwt,                                  &
3137 !--- output variables
3138              ilnb,snweprint,snheiprint,rsm,                    &
3139              soilmois,tso,smfrkeep,keepfr,                     &
3140              dew,soilt,soilt1,tsnav,                           &
3141              qvg,qsg,qcg,smelt,snoh,snflx,snom,                &
3142              edir1,ec1,ett1,eeta,qfx,hfx,s,sublim,             &
3143              prcpl,fltot,runoff1,runoff2,mavail,soilice,             &
3144              soiliqw,infiltrp                                  )
3145
3146 !***************************************************************
3147 !   energy and moisture budget for snow, heat diffusion eqns.
3148 !   in snow and soil, richards eqn. for soil covered with snow
3149 !
3150 !     delt - time step (s)
3151 !     ktau - numver of time step
3152 !     conflx - depth of constant flux layer (m)
3153 !     j,i - the location of grid point
3154 !     ime, jme,  nzs - dimensions of the domain
3155 !     nroot - number of levels within the root zone
3156 !     prcpms - precipitation rate in m/s
3157 !     newsnow - pcpn in soilid form (m)
3158 !     snhei, snwe - snow height and snow water equivalent (m)
3159 !     rhosn - snow density (kg/m-3)
3160 !     patm - pressure (bar)
3161 !     qvatm,qcatm - cloud and water vapor mixing ratio
3162 !                   at the first atm. level (kg/kg)
3163 !     glw, gsw - incoming longwave and absorbed shortwave
3164 !                radiation at the surface (w/m^2)
3165 !     emiss,rnet - emissivity (0-1) of the ground surface and net
3166 !                  radiation at the surface (w/m^2)
3167 !     qkms - exchange coefficient for water vapor in the
3168 !              surface layer (m/s)
3169 !     tkms - exchange coefficient for heat in the surface
3170 !              layer (m/s)
3171 !     pc - plant coefficient (resistance) (0-1)
3172 !     rho - density of atmosphere near surface (kg/m^3)
3173 !     vegfrac - greeness fraction (0-1)
3174 !     rhocs - volumetric heat capacity of dry soil (j/m^3/k)
3175 !     dqm, qmin - porosity minus residual soil moisture qmin (m^3/m^3)
3176 !     ref, wilt - field capacity soil moisture and the
3177 !                 wilting point (m^3/m^3)
3178 !     psis - matrix potential at saturation (m)
3179 !     bclh - exponent for clapp-hornberger parameterization
3180 !     ksat - saturated hydraulic conductivity (m/s)
3181 !     sat - maximum value of water intercepted by canopy (m)
3182 !     cn - exponent for calculation of canopy water
3183 !     zsmain - main levels in soil (m)
3184 !     zshalf - middle of the soil layers (m)
3185 !     dtdzs,dtdzs2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil
3186 !     tbq - table to define saturated mixing ration
3187 !           of water vapor for given temperature and pressure
3188 !     ilnb - number of layers in snow
3189 !     rsm - liquid water inside snow pack (m)
3190 !     soilmois,tso - soil moisture (m^3/m^3) and temperature (k)
3191 !     dew -  dew in (kg/m^2 s)
3192 !     soilt - skin temperature (k)
3193 !     soilt1 - snow temperature at 7.5 cm depth (k)
3194 !     tsnav - average temperature of snow pack (c)
3195 !     qsg,qvg,qcg - saturated mixing ratio, mixing ratio of
3196 !                   water vapor and cloud at the ground
3197 !                   surface, respectively (kg/kg)
3198 !     edir1, ec1, ett1, eeta - direct evaporation, evaporation of
3199 !            canopy water, transpiration (kg m-2 s-1) and total
3200 !            evaporation in (m s-1).
3201 !     qfx, hfx - latent and sensible heat fluxes (w/m^2)
3202 !     s - soil heat flux in the top layer (w/m^2)
3203 !     sublim - snow sublimation (kg/m^2/s)
3204 !     runoff1 - surface runoff (m/s)
3205 !     runoff2 - underground runoff (m)
3206 !     mavail - moisture availability in the top soil layer (0-1)
3207 !     soilice - content of soil ice in soil layers (m^3/m^3)
3208 !     soiliqw - lliquid water in soil layers (m^3/m^3)
3209 !     infiltrp - infiltration flux from the top of soil domain (m/s)
3210 !     xinet - net long-wave radiation (w/m^2)
3211 !
3212 !*******************************************************************
3213
3214         implicit none
3215 !-------------------------------------------------------------------
3216 !--- input variables
3217
3218    integer,  intent(in   )   ::  nroot,ktau,nzs     ,            &
3219                                  nddzs                         !nddzs=2*(nzs-2)
3220    integer,  intent(in   )   ::  i,j,isoil
3221
3222    real,     intent(in   )   ::  delt,conflx,prcpms            , &
3223                                  rainf,newsnow,rhonewsn,         &
3224                                  snhei_crit,meltfactor
3225
3226    logical,    intent(in   )    ::     myj
3227
3228 !--- 3-d atmospheric variables
3229    real,                                                         &
3230             intent(in   )    ::                            patm, &
3231                                                           qvatm, &
3232                                                           qcatm
3233 !--- 2-d variables
3234    real                                                        , &
3235             intent(in   )    ::                             glw, &
3236                                                             gsw, &
3237                                                           gswin, &
3238                                                             rho, &
3239                                                              pc, &
3240                                                         vegfrac, &
3241                                                             lai, &
3242                                                        infwater, &
3243                                                            qkms, &
3244                                                            tkms
3245
3246    integer,  intent(in   )   ::                          ivgtyp
3247 !--- soil properties
3248    real                                                        , &
3249             intent(in   )    ::                           rhocs, &
3250                                                            bclh, &
3251                                                             dqm, &
3252                                                            ksat, &
3253                                                            psis, &
3254                                                            qmin, &
3255                                                           qwrtz, &
3256                                                             ref, &
3257                                                             sat, &
3258                                                            wilt
3259
3260    real,     intent(in   )   ::                              cn, &
3261                                                              cw, &
3262                                                             xlv, &
3263                                                            g0_p, &
3264                                                          kqwrtz, &
3265                                                            kice, &
3266                                                             kwt
3267
3268
3269    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
3270                                                          zshalf, &
3271                                                          dtdzs2
3272
3273    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
3274
3275    real,     dimension(1:5001), intent(in)  ::              tbq
3276
3277    real,     dimension(1:nzs), intent(in)  ::          rstochcol
3278    real,     dimension(1:nzs), intent(inout) ::     fieldcol_sf
3279
3280 !--- input/output variables
3281 !-------- 3-d soil moisture and temperature
3282    real,     dimension(  1:nzs )                               , &
3283              intent(inout)   ::                             tso, &
3284                                                        soilmois, &
3285                                                        smfrkeep
3286
3287    real,  dimension( 1:nzs )                                   , &
3288              intent(inout)   ::                          keepfr
3289
3290
3291    integer,  intent(inout)    ::                           iland
3292
3293
3294 !-------- 2-d variables
3295    real                                                        , &
3296              intent(inout)   ::                             dew, &
3297                                                             cst, &
3298                                                            drip, &
3299                                                           edir1, &
3300                                                             ec1, &
3301                                                            ett1, &
3302                                                            eeta, &
3303                                                           rhosn, &
3304                                                          sublim, &
3305                                                           prcpl, &
3306                                                             alb, &
3307                                                           emiss, &
3308                                                             znt, &
3309                                                          mavail, &
3310                                                             qvg, &
3311                                                             qsg, &
3312                                                             qcg, &
3313                                                             qfx, &
3314                                                             hfx, &
3315                                                               s, &
3316                                                         runoff1, &
3317                                                         runoff2, &
3318                                                            snwe, &
3319                                                           snhei, &
3320                                                           smelt, &
3321                                                            snom, &
3322                                                            snoh, &
3323                                                           snflx, &
3324                                                           soilt, &
3325                                                          soilt1, &
3326                                                        snowfrac, &
3327                                                           tsnav
3328
3329    integer, intent(inout)    ::                            ilnb
3330
3331 !-------- 1-d variables
3332    real,     dimension(1:nzs), intent(out)  ::          soilice, &
3333                                                         soiliqw
3334
3335    real,     intent(out)                    ::              rsm, &
3336                                                       snweprint, &
3337                                                      snheiprint
3338    integer,  intent(in)                    ::       spp_lsm
3339 !--- local variables
3340
3341
3342    integer ::  nzs1,nzs2,k
3343
3344    real    ::  infiltrp, transum                               , &
3345                snth, newsn                                     , &
3346                tabs, t3, upflux, xinet                         , &
3347                beta, snwepr,epdt,pp
3348    real    ::  cp,rovcp,g0,lv,xlvm,stbolt,xlmelt,dzstop        , &
3349                can,epot,fac,fltot,ft,fq,hft                    , &
3350                q1,ras,rhoice,sph                               , &
3351                trans,zn,ci,cvw,tln,tavln,pi                    , &
3352                dd1,cmc2ms,drycan,wetcan                        , &
3353                infmax,riw,deltsn,h,umveg
3354
3355    real,     dimension(1:nzs)  ::  transp,cap,diffu,hydro      , &
3356                                    thdif,tranf,tav,soilmoism   , &
3357                                    soilicem,soiliqwm,detal     , &
3358                                    fwsat,lwsat,told,smold
3359    real                        ::  soiltold, qgold
3360
3361    real                        ::  rnet, x
3362
3363 !-----------------------------------------------------------------
3364
3365         cvw=cw
3366         xlmelt=3.35e+5
3367 !-- heat of water vapor sublimation
3368         xlvm=xlv+xlmelt
3369
3370 !--- snow flag -- isice
3371 !         iland=isice
3372
3373 !--- deltsn - is the threshold for splitting the snow layer into 2 layers.
3374 !--- with snow density 400 kg/m^3, this threshold is equal to 7.5 cm,
3375 !--- equivalent to 0.03 m snwe. for other snow densities the threshold is
3376 !--- computed using snwe=0.03 m and current snow density.
3377 !--- snth - the threshold below which the snow layer is combined with
3378 !--- the top soil layer. snth is computed using snwe=0.016 m, and
3379 !--- equals 4 cm for snow density 400 kg/m^3.
3380
3381 !save soilt and qvg
3382        soiltold=soilt
3383        qgold=qvg
3384
3385        x=0.
3386
3387            deltsn=0.05*1.e3/rhosn
3388            snth=0.01*1.e3/rhosn
3389 !      print *,'deltsn,snhei,snth',i,j,deltsn,snhei,snth
3390
3391 ! for 2-layer snow model when the snow depth is marginally higher than deltsn,
3392 ! reset deltsn to half of snow depth.
3393         if(snhei.ge.deltsn+snth) then
3394           if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth)
3395     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3396       print *,'deltsn is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth
3397     endif
3398         endif
3399
3400         rhoice=900.
3401         ci=rhoice*2100.
3402         ras=rho*1.e-3
3403         riw=rhoice*1.e-3
3404         rsm=0.
3405
3406         do k=1,nzs
3407           transp     (k)=0.
3408           soilmoism  (k)=0.
3409           soiliqwm   (k)=0.
3410           soilice    (k)=0.
3411           soilicem   (k)=0.
3412           lwsat      (k)=0.
3413           fwsat      (k)=0.
3414           tav        (k)=0.
3415           cap        (k)=0.
3416           diffu      (k)=0.
3417           hydro      (k)=0.
3418           thdif      (k)=0.
3419           tranf      (k)=0.
3420           detal      (k)=0.
3421           told       (k)=0.
3422           smold      (k)=0.
3423         enddo
3424
3425         snweprint=0.
3426         snheiprint=0.
3427         prcpl=prcpms
3428
3429 !*** deltsn is the depth of the top layer of snow where
3430 !*** there is a temperature gradient, the rest of the snow layer
3431 !*** is considered to have constant temperature
3432
3433
3434           nzs1=nzs-1
3435           nzs2=nzs-2
3436         dzstop=1./(zsmain(2)-zsmain(1))
3437
3438 !----- the calculation of thermal diffusivity, diffusional and ---
3439 !----- hydraulic conductivity (Smirnova et al. 1996, eq.2,5,6) ---
3440 !tgs - the following loop is added to define the amount of frozen
3441 !tgs - water in soil if there is any
3442          do k=1,nzs
3443
3444          tln=log(tso(k)/273.15)
3445          if(tln.lt.0.) then
3446            soiliqw(k)=(dqm+qmin)*(xlmelt*                          &
3447          (tso(k)-273.15)/tso(k)/9.81/psis)                         &
3448           **(-1./bclh)-qmin
3449            soiliqw(k)=max(0.,soiliqw(k))
3450            soiliqw(k)=min(soiliqw(k),soilmois(k))
3451            soilice(k)=(soilmois(k)-soiliqw(k))/riw
3452
3453 !---- melting and freezing is balanced, soil ice cannot increase
3454        if(keepfr(k).eq.1.) then
3455            soilice(k)=min(soilice(k),smfrkeep(k))
3456            soiliqw(k)=max(0.,soilmois(k)-soilice(k)*rhoice*1.e-3)
3457        endif
3458
3459          else
3460            soilice(k)=0.
3461            soiliqw(k)=soilmois(k)
3462          endif
3463
3464           enddo
3465
3466           do k=1,nzs1
3467
3468          tav(k)=0.5*(tso(k)+tso(k+1))
3469          soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1))
3470          tavln=log(tav(k)/273.15)
3471
3472          if(tavln.lt.0.) then
3473            soiliqwm(k)=(dqm+qmin)*(xlmelt*                         &
3474          (tav(k)-273.15)/tav(k)/9.81/psis)                         &
3475           **(-1./bclh)-qmin
3476            fwsat(k)=dqm-soiliqwm(k)
3477            lwsat(k)=soiliqwm(k)+qmin
3478            soiliqwm(k)=max(0.,soiliqwm(k))
3479            soiliqwm(k)=min(soiliqwm(k), soilmoism(k))
3480            soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw
3481 !---- melting and freezing is balanced, soil ice cannot increase
3482        if(keepfr(k).eq.1.) then
3483            soilicem(k)=min(soilicem(k),                            &
3484                     0.5*(smfrkeep(k)+smfrkeep(k+1)))
3485            soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw)
3486            fwsat(k)=dqm-soiliqwm(k)
3487            lwsat(k)=soiliqwm(k)+qmin
3488        endif
3489
3490          else
3491            soilicem(k)=0.
3492            soiliqwm(k)=soilmoism(k)
3493            lwsat(k)=dqm+qmin
3494            fwsat(k)=0.
3495
3496          endif
3497           enddo
3498
3499           do k=1,nzs
3500            if(soilice(k).gt.0.) then
3501              smfrkeep(k)=soilice(k)
3502            else
3503              smfrkeep(k)=soilmois(k)/riw
3504            endif
3505           enddo
3506 !******************************************************************
3507 ! soilprop computes thermal diffusivity, and diffusional and
3508 !          hydraulic condeuctivities
3509 !******************************************************************
3510           call soilprop(spp_lsm,rstochcol,fieldcol_sf,      &
3511 !--- input variables
3512                nzs,fwsat,lwsat,tav,keepfr,                       &
3513                soilmois,soiliqw,soilice,                         &
3514                soilmoism,soiliqwm,soilicem,                      &
3515 !--- soil fixed fields
3516                qwrtz,rhocs,dqm,qmin,psis,bclh,ksat,              &
3517 !--- constants
3518                riw,xlmelt,cp,g0_p,cvw,ci,                        &
3519                kqwrtz,kice,kwt,                                  &
3520 !--- output variables
3521                thdif,diffu,hydro,cap)
3522
3523 !********************************************************************
3524 !--- calculation of canopy water (Smirnova et al., 1996, eq.16) and dew
3525
3526         smelt=0.
3527         h=mavail
3528
3529         fq=qkms
3530
3531
3532 !--- if vegfrac.ne.0. then part of falling snow can be
3533 !--- intercepted by the canopy.
3534
3535         dew=0.
3536         umveg=1.-vegfrac
3537         epot = -fq*(qvatm-qsg)
3538
3539     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3540       print *,'snwe after subtracting intercepted snow - snwe=',snwe,vegfrac,cst
3541     endif
3542           snwepr=snwe
3543
3544 !  check if all snow can evaporate during dt
3545          beta=1.
3546          epdt = epot * ras *delt*umveg
3547          if(epdt.gt.0. .and. snwepr.le.epdt) then
3548             beta=snwepr/max(1.e-8,epdt)
3549             snwe=0.
3550          endif
3551
3552           wetcan=min(0.25,max(0.,(cst/sat))**cn)
3553 !          if(lai > 1.) wetcan=wetcan/lai
3554           drycan=1.-wetcan
3555
3556 !**************************************************************
3557 !  transf computes transpiration function
3558 !**************************************************************
3559            call transf(i,j,                                   &
3560 !--- input variables
3561               nzs,nroot,soiliqw,tabs,lai,gswin,               &
3562 !--- soil fixed fields
3563               dqm,qmin,ref,wilt,zshalf,pc,iland,              &
3564 !--- output variables
3565               tranf,transum)
3566
3567 !--- save soil temp and moisture from the beginning of time step
3568           do k=1,nzs
3569            told(k)=tso(k)
3570            smold(k)=soilmois(k)
3571           enddo
3572
3573 !**************************************************************
3574 ! snowtemp solves heat budget and diffusion eqn. in soil
3575 !**************************************************************
3576
3577     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3578 print *, 'tso before calling snowtemp: ', tso
3579     endif
3580         call snowtemp(                                        &
3581 !--- input variables
3582              i,j,iland,isoil,                                 &
3583              delt,ktau,conflx,nzs,nddzs,nroot,                &
3584              snwe,snwepr,snhei,newsnow,snowfrac,              &
3585              beta,deltsn,snth,rhosn,rhonewsn,meltfactor,      &  ! add meltfactor
3586              prcpms,rainf,                                    &
3587              patm,tabs,qvatm,qcatm,                           &
3588              glw,gsw,emiss,rnet,                              &
3589              qkms,tkms,pc,rho,vegfrac,                        &
3590              thdif,cap,drycan,wetcan,cst,                     &
3591              tranf,transum,dew,mavail,                        &
3592 !--- soil fixed fields
3593              dqm,qmin,psis,bclh,                              &
3594              zsmain,zshalf,dtdzs,tbq,                         &
3595 !--- constants
3596              xlvm,cp,rovcp,g0_p,cvw,stbolt,                   &
3597 !--- output variables
3598              snweprint,snheiprint,rsm,                        &
3599              tso,soilt,soilt1,tsnav,qvg,qsg,qcg,              &
3600              smelt,snoh,snflx,s,ilnb,x)
3601
3602 !************************************************************************
3603 !--- recalculation of dew using new value of qsg or transp if no dew
3604          dew=0.
3605          ett1=0.
3606          pp=patm*1.e3
3607          epot = -fq*(qvatm-qsg)
3608        if(epot.gt.0.) then
3609 ! evaporation
3610           do k=1,nroot
3611             transp(k)=vegfrac*ras*fq*(qvatm-qsg)              &
3612                      *tranf(k)*drycan/zshalf(nroot+1)
3613             ett1=ett1-transp(k)
3614           enddo
3615           do k=nroot+1,nzs
3616             transp(k)=0.
3617           enddo
3618
3619         else
3620 ! sublimation
3621           dew=-epot
3622           do k=1,nzs
3623             transp(k)=0.
3624           enddo
3625         ett1=0.
3626         endif
3627
3628 !-- recalculating of frozen water in soil
3629          do k=1,nzs
3630          tln=log(tso(k)/273.15)
3631          if(tln.lt.0.) then
3632            soiliqw(k)=(dqm+qmin)*(xlmelt*                    &
3633          (tso(k)-273.15)/tso(k)/9.81/psis)                   &
3634           **(-1./bclh)-qmin
3635            soiliqw(k)=max(0.,soiliqw(k))
3636            soiliqw(k)=min(soiliqw(k),soilmois(k))
3637            soilice(k)=(soilmois(k)-soiliqw(k))/riw
3638 !---- melting and freezing is balanced, soil ice cannot increase
3639        if(keepfr(k).eq.1.) then
3640            soilice(k)=min(soilice(k),smfrkeep(k))
3641            soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw)
3642        endif
3643
3644          else
3645            soilice(k)=0.
3646            soiliqw(k)=soilmois(k)
3647          endif
3648          enddo
3649
3650 !*************************************************************************
3651 !--- tqcan for solution of moisture balance (Smirnova et al. 1996, eq.22,28)
3652 !    and tso,eta profiles
3653 !*************************************************************************
3654                 call soilmoist (                                   &
3655 !-- input
3656                delt,nzs,nddzs,dtdzs,dtdzs2,riw,                    &
3657                zsmain,zshalf,diffu,hydro,                          &
3658                qsg,qvg,qcg,qcatm,qvatm,-infwater,                  &
3659                qkms,transp,0.,                                     &
3660                0.,smelt,soilice,vegfrac,                           &
3661                snowfrac,1.,                                        &
3662 !-- soil properties
3663                dqm,qmin,ref,ksat,ras,infmax,                       &
3664 !-- output
3665                soilmois,soiliqw,mavail,runoff1,                    &
3666                runoff2,infiltrp)
3667
3668 !        endif
3669
3670 !-- restore land-use parameters if all snow is melted
3671          if(snhei.eq.0.)  then
3672           tsnav=soilt-273.15
3673          endif
3674
3675 ! 21apr2009
3676 ! snom [mm] goes into the passed-in acsnom variable in the grid derived type
3677         snom=snom+smelt*delt*1.e3
3678 !
3679 !--- keepfr is 1 when the temperature and moisture in soil
3680 !--- are both increasing. in this case soil ice should not
3681 !--- be increasing according to the freezing curve.
3682 !--- some part of ice is melted, but additional water is
3683 !--- getting frozen. thus, only structure of frozen soil is
3684 !--- changed, and phase changes are not affecting the heat
3685 !--- transfer. this situation may happen when it rains on the
3686 !--- frozen soil.
3687
3688         do k=1,nzs
3689        if (soilice(k).gt.0.) then
3690           if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then
3691               keepfr(k)=1.
3692           else
3693               keepfr(k)=0.
3694           endif
3695        endif
3696         enddo
3697 !--- the diagnostics of surface fluxes
3698
3699         t3      = stbolt*soiltold*soiltold*soiltold
3700         upflux  = t3 *0.5*(soiltold+soilt)
3701         xinet   = emiss*(glw-upflux)
3702         hfx=-tkms*cp*rho*(tabs-soilt)                        &
3703                *(p1000mb*0.00001/patm)**rovcp
3704     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3705       print *,'potential temp hfx',hfx
3706     endif
3707         hft=-tkms*cp*rho*(tabs-soilt)
3708     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3709       print *,'abs temp hfx',hft
3710     endif
3711         q1 = - fq*ras* (qvatm - qsg)
3712         cmc2ms=0.
3713         if (q1.lt.0.) then
3714 ! ---  condensation
3715         edir1=0.
3716         ec1=0.
3717         ett1=0.
3718 ! ---  condensation
3719      if(myj) then
3720 !-- moisture flux for coupling with myj pbl
3721           eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3
3722           cst= cst-eeta*delt*vegfrac
3723     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3724       print *,'myj eeta cond', eeta
3725     endif
3726      else ! myj
3727 !-- actual moisture flux from ruc lsm
3728           dew=qkms*(qvatm-qsg)
3729           eeta= - rho*dew
3730           cst=cst+delt*dew*ras * vegfrac
3731     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3732       print *,'ruc lsm eeta cond',eeta
3733     endif
3734      endif ! myj
3735           qfx= xlvm*eeta
3736           eeta= - rho*dew
3737         else
3738 ! ---  evaporation
3739         edir1 = q1*umveg *beta
3740         cmc2ms=cst/delt*ras
3741         ec1 = q1 * wetcan * vegfrac
3742
3743         cst=max(0.,cst-ec1 * delt)
3744
3745     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3746      print*,'q1,umveg,beta',q1,umveg,beta
3747      print *,'wetcan,vegfrac',wetcan,vegfrac
3748      print *,'ec1,cmc2ms',ec1,cmc2ms
3749     endif
3750
3751      if(myj) then
3752 !-- moisture flux for coupling with myj pbl
3753         eeta=-(qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3)*beta
3754     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3755       print *,'myj eeta', eeta*xlvm,eeta
3756     endif
3757      else ! myj
3758 ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
3759 !-- actual moisture flux from ruc lsm
3760         eeta = (edir1 + ec1 + ett1)*1.e3
3761     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3762       print *,'ruc lsm eeta',eeta*xlvm,eeta
3763     endif
3764      endif ! myj
3765         qfx= xlvm * eeta
3766         eeta = (edir1 + ec1 + ett1)*1.e3
3767        endif
3768         s=snflx
3769         sublim=edir1*1.e3
3770 ! energy budget
3771         fltot=rnet-hft-xlvm*eeta-s-snoh-x
3772     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3773        print *,'snowsoil - fltot,rnet,hft,qfx,s,snoh,x=',fltot,rnet,hft,xlvm*eeta,s,snoh,x
3774        print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta',&
3775                 edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta
3776     endif
3777
3778  222     continue
3779
3780  1123    format(i5,8f12.3)
3781  1133    format(i7,8e12.4)
3782   123   format(i6,f6.2,7f8.1)
3783  122    format(1x,2i3,6f8.1,f8.3,f8.2)
3784
3785 !-------------------------------------------------------------------
3786    end subroutine snowsoil
3787 !-------------------------------------------------------------------
3788
3789            subroutine snowseaice(                               &
3790             i,j,isoil,delt,ktau,conflx,nzs,nddzs,               &
3791             meltfactor,rhonewsn,snhei_crit,                     &  ! new
3792             iland,prcpms,rainf,newsnow,snhei,snwe,snowfrac,     &
3793             rhosn,patm,qvatm,qcatm,                             &
3794             glw,gsw,emiss,rnet,                                 &
3795             qkms,tkms,rho,myj,                                  &
3796 !--- sea ice parameters
3797             alb,znt,                                            &
3798             tice,rhosice,capice,thdifice,                       &
3799             zsmain,zshalf,dtdzs,dtdzs2,tbq,                     &
3800 !--- constants
3801             xlv,cp,rovcp,cw,stbolt,tabs,                        &
3802 !--- output variables
3803             ilnb,snweprint,snheiprint,rsm,tso,                  &
3804             dew,soilt,soilt1,tsnav,qvg,qsg,qcg,                 &
3805             smelt,snoh,snflx,snom,eeta,                         &
3806             qfx,hfx,s,sublim,prcpl,fltot                        &
3807                                                                 )
3808 !***************************************************************
3809 !   solving energy budget for snow on sea ice and heat diffusion
3810 !   eqns. in snow and sea ice
3811 !***************************************************************
3812
3813
3814         implicit none
3815 !-------------------------------------------------------------------
3816 !--- input variables
3817
3818    integer,  intent(in   )   ::  ktau,nzs     ,                  &
3819                                  nddzs                         !nddzs=2*(nzs-2)
3820    integer,  intent(in   )   ::  i,j,isoil
3821
3822    real,     intent(in   )   ::  delt,conflx,prcpms            , &
3823                                  rainf,newsnow,rhonewsn,         &
3824                                  meltfactor, snhei_crit
3825    real                      ::  rhonewcsn
3826
3827    logical,  intent(in   )   ::  myj
3828 !--- 3-d atmospheric variables
3829    real,                                                         &
3830             intent(in   )    ::                            patm, &
3831                                                           qvatm, &
3832                                                           qcatm
3833 !--- 2-d variables
3834    real                                                        , &
3835             intent(in   )    ::                             glw, &
3836                                                             gsw, &
3837                                                             rho, &
3838                                                            qkms, &
3839                                                            tkms
3840
3841 !--- sea ice properties
3842    real,     dimension(1:nzs)                                  , &
3843             intent(in   )    ::                                  &
3844                                                            tice, &
3845                                                         rhosice, &
3846                                                          capice, &
3847                                                        thdifice
3848
3849    real,     intent(in   )   ::                                  &
3850                                                              cw, &
3851                                                             xlv
3852
3853    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
3854                                                          zshalf, &
3855                                                          dtdzs2
3856
3857    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
3858
3859    real,     dimension(1:5001), intent(in)  ::              tbq
3860
3861 !--- input/output variables
3862 !-------- 3-d soil moisture and temperature
3863    real,     dimension(  1:nzs )                               , &
3864              intent(inout)   ::                             tso
3865
3866    integer,  intent(inout)    ::                           iland
3867
3868
3869 !-------- 2-d variables
3870    real                                                        , &
3871              intent(inout)   ::                             dew, &
3872                                                            eeta, &
3873                                                           rhosn, &
3874                                                          sublim, &
3875                                                           prcpl, &
3876                                                             alb, &
3877                                                           emiss, &
3878                                                             znt, &
3879                                                             qvg, &
3880                                                             qsg, &
3881                                                             qcg, &
3882                                                             qfx, &
3883                                                             hfx, &
3884                                                               s, &
3885                                                            snwe, &
3886                                                           snhei, &
3887                                                           smelt, &
3888                                                            snom, &
3889                                                            snoh, &
3890                                                           snflx, &
3891                                                           soilt, &
3892                                                          soilt1, &
3893                                                        snowfrac, &
3894                                                           tsnav
3895
3896    integer, intent(inout)    ::                            ilnb
3897
3898    real,     intent(out)                    ::              rsm, &
3899                                                       snweprint, &
3900                                                      snheiprint
3901 !--- local variables
3902
3903
3904    integer ::  nzs1,nzs2,k,k1,kn,kk
3905    real    ::  x,x1,x2,dzstop,ft,tn,denom
3906
3907    real    ::  snth, newsn                                     , &
3908                tabs, t3, upflux, xinet                         , &
3909                beta, snwepr,epdt,pp
3910    real    ::  cp,rovcp,g0,lv,xlvm,stbolt,xlmelt               , &
3911                epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw          , &
3912                riw,deltsn,h
3913
3914    real    ::  rhocsn,thdifsn,                                   &
3915                xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn
3916
3917    real    ::  cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn
3918    real    ::  fso,fsn,                                          &
3919                fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11,      &
3920                fkq,r210,aa,bb,qs1,ts1,tq2,tx2,                   &
3921                tdenom,aa1,rhcs,h1,tsob, snprim,                  &
3922                snodif,soh,tnold,qgold,snohgnew
3923    real,     dimension(1:nzs)  ::  cotso,rhtso
3924
3925    real                   :: rnet,rsmfrac,soiltfrac,hsn,icemelt,rr
3926    integer                ::      nmelt
3927
3928
3929 !-----------------------------------------------------------------
3930         xlmelt=3.35e+5
3931 !-- heat of sublimation of water vapor
3932         xlvm=xlv+xlmelt
3933
3934 !--- snow flag -- isice
3935 !         iland=isice
3936
3937 !--- deltsn - is the threshold for splitting the snow layer into 2 layers.
3938 !--- with snow density 400 kg/m^3, this threshold is equal to 7.5 cm,
3939 !--- equivalent to 0.03 m snwe. for other snow densities the threshold is
3940 !--- computed using snwe=0.03 m and current snow density.
3941 !--- snth - the threshold below which the snow layer is combined with
3942 !--- the top sea ice layer. snth is computed using snwe=0.016 m, and
3943 !--- equals 4 cm for snow density 400 kg/m^3.
3944
3945            deltsn=0.05*1.e3/rhosn
3946            snth=0.01*1.e3/rhosn
3947
3948 ! for 2-layer snow model when the snow depth is marginlly higher than deltsn,
3949 ! reset deltsn to half of snow depth.
3950         if(snhei.ge.deltsn+snth) then
3951           if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth)
3952     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
3953         print *,'deltsn ice is changed,deltsn,snhei,snth', &
3954                                   i,j, deltsn,snhei,snth
3955     endif
3956         endif
3957
3958         rhoice=900.
3959         ci=rhoice*2100.
3960         ras=rho*1.e-3
3961         riw=rhoice*1.e-3
3962         rsm=0.
3963
3964         xlmelt=3.35e+5
3965         rhocsn=2090.* rhosn
3966 !18apr08 - add rhonewcsn
3967         rhonewcsn=2090.* rhonewsn
3968         thdifsn = 0.265/rhocsn
3969         ras=rho*1.e-3
3970
3971         soiltfrac=soilt
3972
3973         smelt=0.
3974         soh=0.
3975         snodif=0.
3976         snoh=0.
3977         snohgnew=0.
3978         rsm = 0.
3979         rsmfrac = 0.
3980         fsn=1.
3981         fso=0.
3982         cvw=cw
3983
3984           nzs1=nzs-1
3985           nzs2=nzs-2
3986
3987         qgold=qsg
3988         tnold=soilt
3989         dzstop=1./(zsmain(2)-zsmain(1))
3990
3991         snweprint=0.
3992         snheiprint=0.
3993         prcpl=prcpms
3994
3995 !*** deltsn is the depth of the top layer of snow where
3996 !*** there is a temperature gradient, the rest of the snow layer
3997 !*** is considered to have constant temperature
3998
3999
4000         h=1.
4001         smelt=0.
4002
4003         fq=qkms
4004         snhei=snwe*1.e3/rhosn
4005           snwepr=snwe
4006
4007 !  check if all snow can evaporate during dt
4008          beta=1.
4009          epot = -fq*(qvatm-qsg)
4010          epdt = epot * ras *delt
4011          if(epdt.gt.0. .and. snwepr.le.epdt) then
4012             beta=snwepr/max(1.e-8,epdt)
4013             snwe=0.
4014          endif
4015
4016 !******************************************************************************
4017 !       coefficients for thomas algorithm for tso
4018 !******************************************************************************
4019
4020         cotso(1)=0.
4021         rhtso(1)=tso(nzs)
4022         do 33 k=1,nzs2
4023           kn=nzs-k
4024           k1=2*kn-3
4025           x1=dtdzs(k1)*thdifice(kn-1)
4026           x2=dtdzs(k1+1)*thdifice(kn)
4027           ft=tso(kn)+x1*(tso(kn-1)-tso(kn))                           &
4028              -x2*(tso(kn)-tso(kn+1))
4029           denom=1.+x1+x2-x2*cotso(k)
4030           cotso(k+1)=x1/denom
4031           rhtso(k+1)=(ft+x2*rhtso(k))/denom
4032    33  continue
4033 !--- the nzs element in cotso and rhtso will be for snow
4034 !--- there will be 2 layers in snow if it is deeper than deltsn+snth
4035        if(snhei.ge.snth) then
4036         if(snhei.le.deltsn+snth) then
4037 !-- 1-layer snow model
4038          ilnb=1
4039          snprim=max(snth,snhei)
4040          soilt1=tso(1)
4041          tsob=tso(1)
4042          xsn = delt/2./(zshalf(2)+0.5*snprim)
4043          ddzsn = xsn / snprim
4044          x1sn = ddzsn * thdifsn
4045          x2 = dtdzs(1)*thdifice(1)
4046          ft = tso(1)+x1sn*(soilt-tso(1))                              &
4047               -x2*(tso(1)-tso(2))
4048          denom = 1. + x1sn + x2 -x2*cotso(nzs1)
4049          cotso(nzs)=x1sn/denom
4050          rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
4051          cotsn=cotso(nzs)
4052          rhtsn=rhtso(nzs)
4053 !*** average temperature of snow pack (c)
4054          tsnav=0.5*(soilt+tso(1))                                     &
4055                      -273.15
4056
4057         else
4058 !-- 2 layers in snow, soilt1 is temperasture at deltsn depth
4059          ilnb=2
4060          snprim=deltsn
4061          tsob=soilt1
4062          xsn = delt/2./(0.5*snhei)
4063          xsn1= delt/2./(zshalf(2)+0.5*(snhei-deltsn))
4064          ddzsn = xsn / deltsn
4065          ddzsn1 = xsn1 / (snhei-deltsn)
4066          x1sn = ddzsn * thdifsn
4067          x1sn1 = ddzsn1 * thdifsn
4068          x2 = dtdzs(1)*thdifice(1)
4069          ft = tso(1)+x1sn1*(soilt1-tso(1))                            &
4070               -x2*(tso(1)-tso(2))
4071          denom = 1. + x1sn1 + x2 - x2*cotso(nzs1)
4072          cotso(nzs)=x1sn1/denom
4073          rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
4074          ftsnow = soilt1+x1sn*(soilt-soilt1)                          &
4075                -x1sn1*(soilt1-tso(1))
4076          denomsn = 1. + x1sn + x1sn1 - x1sn1*cotso(nzs)
4077          cotsn=x1sn/denomsn
4078          rhtsn=(ftsnow+x1sn1*rhtso(nzs))/denomsn
4079 !*** average temperature of snow pack (c)
4080          tsnav=0.5/snhei*((soilt+soilt1)*deltsn                       &
4081                      +(soilt1+tso(1))*(snhei-deltsn))                 &
4082                      -273.15
4083         endif
4084        endif
4085
4086        if(snhei.lt.snth.and.snhei.gt.0.) then
4087 !--- snow is too thin to be treated separately, therefore it
4088 !--- is combined with the first sea ice layer.
4089          snprim=snhei+zsmain(2)
4090          fsn=snhei/snprim
4091          fso=1.-fsn
4092          soilt1=tso(1)
4093          tsob=tso(2)
4094          xsn = delt/2./((zshalf(3)-zsmain(2))+0.5*snprim)
4095          ddzsn = xsn /snprim
4096          x1sn = ddzsn * (fsn*thdifsn+fso*thdifice(1))
4097          x2=dtdzs(2)*thdifice(2)
4098          ft=tso(2)+x1sn*(soilt-tso(2))-                              &
4099                        x2*(tso(2)-tso(3))
4100          denom = 1. + x1sn + x2 - x2*cotso(nzs-2)
4101          cotso(nzs1) = x1sn/denom
4102          rhtso(nzs1)=(ft+x2*rhtso(nzs-2))/denom
4103          tsnav=0.5*(soilt+tso(1))                                    &
4104                      -273.15
4105          cotso(nzs)=cotso(nzs1)
4106          rhtso(nzs)=rhtso(nzs1)
4107          cotsn=cotso(nzs)
4108          rhtsn=rhtso(nzs)
4109        endif
4110
4111 !************************************************************************
4112 !--- the heat balance equation
4113 !18apr08 nmelt is the flag for melting, and snoh is heat of snow phase changes
4114        nmelt=0
4115        snoh=0.
4116
4117         epot=-qkms*(qvatm-qsg)
4118         rhcs=capice(1)
4119         h=1.
4120         fkt=tkms
4121         d1=cotso(nzs1)
4122         d2=rhtso(nzs1)
4123         tn=soilt
4124         d9=thdifice(1)*rhcs*dzstop
4125         d10=tkms*cp*rho
4126         r211=.5*conflx/delt
4127         r21=r211*cp*rho
4128         r22=.5/(thdifice(1)*delt*dzstop**2)
4129         r6=emiss *stbolt*.5*tn**4
4130         r7=r6/tn
4131         d11=rnet+r6
4132
4133       if(snhei.ge.snth) then
4134         if(snhei.le.deltsn+snth) then
4135 !--- 1-layer snow
4136           d1sn = cotso(nzs)
4137           d2sn = rhtso(nzs)
4138         else
4139 !--- 2-layer snow
4140           d1sn = cotsn
4141           d2sn = rhtsn
4142         endif
4143         d9sn= thdifsn*rhocsn / snprim
4144         r22sn = snprim*snprim*0.5/(thdifsn*delt)
4145       endif
4146
4147        if(snhei.lt.snth.and.snhei.gt.0.) then
4148 !--- thin snow is combined with sea ice
4149          d1sn = d1
4150          d2sn = d2
4151          d9sn = (fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)/           &
4152                  snprim
4153          r22sn = snprim*snprim*0.5                                   &
4154                  /((fsn*thdifsn+fso*thdifice(1))*delt)
4155       endif
4156
4157       if(snhei.eq.0.)then
4158 !--- all snow is sublimated
4159         d9sn = d9
4160         r22sn = r22
4161         d1sn = d1
4162         d2sn = d2
4163       endif
4164
4165
4166 !---- tdenom for snow
4167         tdenom = d9sn*(1.-d1sn +r22sn)+d10+r21+r7                    &
4168               +rainf*cvw*prcpms                                      &
4169               +rhonewcsn*newsnow/delt
4170
4171         fkq=qkms*rho
4172         r210=r211*rho
4173         aa=xlvm*(beta*fkq+r210)/tdenom
4174         bb=(d10*tabs+r21*tn+xlvm*(qvatm*                             &
4175         (beta*fkq)                                                   &
4176         +r210*qvg)+d11+d9sn*(d2sn+r22sn*tn)                          &
4177         +rainf*cvw*prcpms*max(273.15,tabs)                           &
4178         + rhonewcsn*newsnow/delt*min(273.15,tabs)                    &
4179          )/tdenom
4180         aa1=aa
4181         pp=patm*1.e3
4182         aa1=aa1/pp
4183 !18apr08  - the iteration start point
4184  212    continue
4185         bb=bb-snoh/tdenom
4186     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4187         print *,'vilka-snow on seaice'
4188         print *,'tn,aa1,bb,pp,fkq,r210',                             &
4189                  tn,aa1,bb,pp,fkq,r210
4190         print *,'tabs,qvatm,tn,qvg=',tabs,qvatm,tn,qvg
4191     endif
4192
4193         call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil)
4194 !--- it is saturation over snow
4195         qvg=qs1
4196         qsg=qs1
4197         qcg=0.
4198
4199 !--- soilt - skin temperature
4200         soilt=ts1
4201
4202     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4203         print *,' after vilka-snow on seaice'
4204         print *,' ts1,qs1: ', ts1,qs1
4205     endif
4206 ! solution for temperature at 7.5 cm depth and snow-seaice interface
4207        if(snhei.ge.snth) then
4208         if(snhei.gt.deltsn+snth) then
4209 !-- 2-layer snow model
4210           soilt1=min(273.15,rhtsn+cotsn*soilt)
4211           tso(1)=min(271.4,(rhtso(nzs)+cotso(nzs)*soilt1))
4212           tsob=soilt1
4213         else
4214 !-- 1 layer in snow
4215           tso(1)=min(271.4,(rhtso(nzs)+cotso(nzs)*soilt))
4216           soilt1=tso(1)
4217           tsob=tso(1)
4218         endif
4219        elseif  (snhei > 0. .and. snhei < snth) then
4220 ! blended
4221          tso(2)=min(271.4,(rhtso(nzs1)+cotso(nzs1)*soilt))
4222          tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso))
4223          soilt1=tso(1)
4224          tsob=tso(2)
4225        else
4226 ! snow is melted
4227          tso(1)=min(271.4,soilt)
4228          soilt1=min(271.4,soilt)
4229          tsob=tso(1)
4230        endif
4231 !---- final solution for tso in sea ice
4232        if (snhei > 0. .and. snhei < snth) then
4233 ! blended or snow is melted
4234           do k=3,nzs
4235             kk=nzs-k+1
4236             tso(k)=min(271.4,rhtso(kk)+cotso(kk)*tso(k-1))
4237           end do
4238        else
4239           do k=2,nzs
4240             kk=nzs-k+1
4241             tso(k)=min(271.4,rhtso(kk)+cotso(kk)*tso(k-1))
4242           end do
4243        endif
4244 !--- for thin snow layer combined with the top soil layer
4245 !--- tso(i,j,1) is computed by linear interpolation between soilt
4246 !--- and tso(i,j,2)
4247 !       if(snhei.lt.snth.and.snhei.gt.0.)then
4248 !          tso(1)=min(271.4,tso(2)+(soilt-tso(2))*fso)
4249 !          soilt1=tso(1)
4250 !          tsob = tso(2)
4251 !       endif
4252
4253       if(nmelt.eq.1) go to 220
4254
4255 !--- if soilt > 273.15 f then melting of snow can happen
4256 ! if all snow can evaporate, then there is nothing to melt
4257    if(soilt.gt.273.15.and.snwepr-beta*epot*ras*delt.gt.0..and.snhei.gt.0.) then
4258 !
4259         nmelt = 1
4260         soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,soilt)
4261
4262         qsg= qsn(soiltfrac,tbq)/pp
4263         t3      = stbolt*tnold*tnold*tnold
4264         upflux  = t3 * 0.5*(tnold+soiltfrac)
4265         xinet   = emiss*(glw-upflux)
4266          epot = -qkms*(qvatm-qsg)
4267          q1=epot*ras
4268
4269         if (q1.le.0.) then
4270 ! ---  condensation
4271           dew=-epot
4272
4273         qfx= xlvm*rho*dew
4274         eeta=qfx/xlvm
4275        else
4276 ! ---  evaporation
4277         eeta = q1 * beta *1.e3
4278 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
4279         qfx= - xlvm * eeta
4280        endif
4281
4282          hfx=d10*(tabs-soiltfrac)
4283
4284        if(snhei.ge.snth)then
4285          soh=thdifsn*rhocsn*(soiltfrac-tsob)/snprim
4286          snflx=soh
4287        else
4288          soh=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)*                &
4289               (soiltfrac-tsob)/snprim
4290          snflx=soh
4291        endif
4292          x= (r21+d9sn*r22sn)*(soiltfrac-tnold) +                        &
4293             xlvm*r210*(qsg-qgold)
4294 !-- snoh is energy flux of snow phase change
4295         snoh=rnet+qfx +hfx                                              &
4296                   +rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac)  &
4297                   -soh-x+rainf*cvw*prcpms*                              &
4298                   (max(273.15,tabs)-soiltfrac)
4299
4300     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4301      print *,'snowseaice melt i,j,snoh,rnet,qfx,hfx,soh,x',i,j,snoh,rnet,qfx,hfx,soh,x
4302      print *,'rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac)',     &
4303               rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac)
4304      print *,'rainf*cvw*prcpms*(max(273.15,tabs)-soiltfrac)',           &
4305               rainf*cvw*prcpms*(max(273.15,tabs)-soiltfrac)
4306     endif
4307         snoh=amax1(0.,snoh)
4308 !-- smelt is speed of melting in m/s
4309         smelt= snoh /xlmelt*1.e-3
4310         smelt=amin1(smelt,snwepr/delt-beta*epot*ras)
4311         smelt=amax1(0.,smelt)
4312
4313     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4314        print *,'1-smelt i,j',smelt,i,j
4315     endif
4316 !18apr08 - egglston limit
4317 !        smelt= amin1 (smelt, 5.6e-7*meltfactor*max(1.,(soilt-273.15)))
4318         smelt= amin1 (smelt, 5.6e-8*meltfactor*max(1.,(soilt-273.15)))
4319     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4320        print *,'2-smelt i,j',smelt,i,j
4321     endif
4322
4323 ! rr - potential melting
4324         rr=snwepr/delt-beta*epot*ras
4325         smelt=min(smelt,rr)
4326     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4327       print *,'3- smelt i,j,smelt,rr',i,j,smelt,rr
4328     endif
4329         snohgnew=smelt*xlmelt*1.e3
4330         snodif=amax1(0.,(snoh-snohgnew))
4331
4332         snoh=snohgnew
4333
4334     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4335        print*,'soiltfrac,soilt,snohgnew,snodif=', &
4336             i,j,soiltfrac,soilt,snohgnew,snodif
4337        print *,'snoh,snodif',snoh,snodif
4338     endif
4339
4340 !*** from koren et al. (1999) 13% of snow melt stays in the snow pack
4341         rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13)))
4342        if(snhei > 0.01) then
4343         rsm=rsmfrac*smelt*delt
4344        else
4345 ! do not keep melted water if snow depth is less that 1 cm
4346         rsm=0.
4347        endif
4348 !18apr08 rsm is part of melted water that stays in snow as liquid
4349         smelt=amax1(0.,smelt-rsm/delt)
4350     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4351        print *,'4-smelt i,j,smelt,rsm,snwepr,rsmfrac', &
4352                     i,j,smelt,rsm,snwepr,rsmfrac
4353     endif
4354
4355 !-- update liquid equivalent of snow depth
4356 !-- for evaporation and snow melt
4357         snwe = amax1(0.,(snwepr-                                      &
4358                     (smelt+beta*epot*ras)*delt                        &
4359                                          ) )
4360         soilt=soiltfrac
4361 !--- if there is no snow melting then just evaporation
4362 !--- or condensation changes snwe
4363       else
4364        if(snhei.ne.0.) then
4365                epot=-qkms*(qvatm-qsg)
4366                snwe = amax1(0.,(snwepr-                               &
4367                     beta*epot*ras*delt))
4368        endif
4369
4370       endif
4371
4372 ! no iteration for snow on sea ice, because it will produce
4373 ! skin temperature higher than it is possible with snow on sea ice
4374 !      if(nmelt.eq.1) goto 212  ! second iteration
4375  220  continue
4376
4377        if(smelt > 0..and.  rsm > 0.) then
4378         if(snwe.le.rsm) then
4379     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4380      print *,'seaice snwe<rsm snwe,rsm,smelt*delt,epot*ras*delt,beta', &
4381                               snwe,rsm,smelt*delt,epot*ras*delt,beta
4382     endif
4383         else
4384 !*** update snow density on effect of snow melt, melted
4385 !*** from the top of the snow. 13% of melted water
4386 !*** remains in the pack and changes its density.
4387 !*** eq. 9 (with my correction) in koren et al. (1999)
4388
4389          xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/                            &
4390              snwe
4391          rhosn=min(max(58.8,xsn),500.)
4392
4393         rhocsn=2090.* rhosn
4394         thdifsn = 0.265/rhocsn
4395         endif
4396       endif
4397
4398         snweprint=snwe
4399 !                                              &
4400 !--- if vegfrac.ne.0. then some snow stays on the canopy
4401 !--- and should be added to snwe for water conservation
4402 ! 4 nov 07                    +vegfrac*cst
4403         snheiprint=snweprint*1.e3 / rhosn
4404
4405     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4406 print *, 'snweprint : ',snweprint
4407 print *, 'd9sn,soilt,tsob : ', d9sn,soilt,tsob
4408     endif
4409       if(snhei.gt.0.) then
4410         if(ilnb.gt.1) then
4411           tsnav=0.5/snhei*((soilt+soilt1)*deltsn                     &
4412                     +(soilt1+tso(1))*(snhei-deltsn))                 &
4413                        -273.15
4414         else
4415           tsnav=0.5*(soilt+tso(1)) - 273.15
4416         endif
4417       endif
4418 !--- recalculation of dew using new value of qsg
4419          dew=0.
4420          pp=patm*1.e3
4421          qsg= qsn(soilt,tbq)/pp
4422          epot = -fq*(qvatm-qsg)
4423        if(epot.lt.0.) then
4424 ! sublimation
4425           dew=-epot
4426         endif
4427
4428         snom=snom+smelt*delt*1.e3
4429
4430 !--- the diagnostics of surface fluxes
4431
4432         t3      = stbolt*tnold*tnold*tnold
4433         upflux  = t3 *0.5*(soilt+tnold)
4434         xinet   = emiss*(glw-upflux)
4435 !        rnet    = gsw + xinet
4436         hft=-tkms*cp*rho*(tabs-soilt)
4437         hfx=-tkms*cp*rho*(tabs-soilt)                        &
4438                *(p1000mb*0.00001/patm)**rovcp
4439         q1 = - fq*ras* (qvatm - qsg)
4440         if (q1.lt.0.) then
4441 ! ---  condensation
4442       if(myj) then
4443 !-- moisture flux for coupling with myj pbl
4444           eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3
4445       else ! myj
4446 !-- actual moisture flux from ruc lsm
4447           dew=qkms*(qvatm-qsg)
4448           eeta= - rho*dew
4449       endif ! myj
4450           qfx= xlvm*eeta
4451           eeta= - rho*dew
4452           sublim = eeta
4453         else
4454 ! ---  evaporation
4455       if(myj) then
4456 !-- moisture flux for coupling with myj pbl
4457           eeta=-qkms*ras*beta*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*1.e3
4458       else ! myj
4459 ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
4460 !-- actual moisture flux from ruc lsm
4461           eeta = q1*beta*1.e3
4462       endif ! myj
4463           qfx= xlvm * eeta
4464           eeta = q1*beta*1.e3
4465           sublim = eeta
4466         endif
4467
4468         icemelt=0.
4469       if(snhei.ge.snth)then
4470          s=thdifsn*rhocsn*(soilt-tsob)/snprim
4471          snflx=s
4472        elseif(snhei.lt.snth.and.snhei.gt.0.) then
4473          s=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)*                &
4474               (soilt-tsob)/snprim
4475          snflx=s
4476     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4477       print *,'snow is thin, snflx',i,j,snflx
4478     endif
4479        else
4480          snflx=d9sn*(soilt-tsob)
4481     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4482       print *,'snow is gone, snflx',i,j,snflx
4483     endif
4484        endif
4485
4486         snhei=snwe *1.e3 / rhosn
4487
4488     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4489        print *,'snhei,snoh',i,j,snhei,snoh
4490     endif
4491 !
4492          x= (r21+d9sn*r22sn)*(soilt-tnold) +              &
4493             xlvm*r210*(qsg-qgold)
4494     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4495      print *,'snowseaice storage ',i,j,x
4496      print *,'r21,d9sn,r22sn,soiltfrac,tnold,qsg,qgold,snprim', &
4497               r21,d9sn,r22sn,soiltfrac,tnold,qsg,qgold,snprim
4498     endif
4499          x=x &
4500         -rhonewcsn*newsnow/delt*(min(273.15,tabs)-soilt)        &
4501         -rainf*cvw*prcpms*(max(273.15,tabs)-soilt)
4502
4503 ! -- excess energy is spent on ice melt
4504         icemelt = rnet-hft-xlvm*eeta-s-snoh-x
4505     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4506         print *,'snowseaice icemelt=',icemelt
4507     endif
4508
4509         fltot=rnet-hft-xlvm*eeta-s-snoh-x-icemelt
4510     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4511        print *,'i,j,snhei,qsg,soilt,soilt1,tso,tabs,qvatm', &
4512                 i,j,snhei,qsg,soilt,soilt1,tso,tabs,qvatm
4513        print *,'snowseaice - fltot,rnet,hft,qfx,s,snoh,icemelt,snodif,x,soilt=' &
4514                       ,fltot,rnet,hft,xlvm*eeta,s,snoh,icemelt,snodif,x,soilt
4515     endif
4516 !-- restore sea-ice parameters if snow is less than threshold
4517          if(snhei.eq.0.)  then
4518           tsnav=soilt-273.15
4519           emiss=0.98
4520           znt=0.011
4521           alb=0.55
4522          endif
4523
4524 !------------------------------------------------------------------------
4525 !------------------------------------------------------------------------
4526    end subroutine snowseaice
4527 !------------------------------------------------------------------------
4528
4529
4530            subroutine soiltemp(                             &
4531 !--- input variables
4532            i,j,iland,isoil,                                 &
4533            delt,ktau,conflx,nzs,nddzs,nroot,                &
4534            prcpms,rainf,patm,tabs,qvatm,qcatm,              &
4535            emiss,rnet,                                      &
4536            qkms,tkms,pc,rho,vegfrac,lai,                    &
4537            thdif,cap,drycan,wetcan,                         &
4538            transum,dew,mavail,soilres,alfa,                 &
4539 !--- soil fixed fields
4540            dqm,qmin,bclh,                                   &
4541            zsmain,zshalf,dtdzs,tbq,                         &
4542 !--- constants
4543            xlv,cp,g0_p,cvw,stbolt,                          &
4544 !--- output variables
4545            tso,soilt,qvg,qsg,qcg,x)
4546
4547 !*************************************************************
4548 !   energy budget equation and heat diffusion eqn are
4549 !   solved here and
4550 !
4551 !     delt - time step (s)
4552 !     ktau - numver of time step
4553 !     conflx - depth of constant flux layer (m)
4554 !     ime, jme, kme, nzs - dimensions of the domain
4555 !     nroot - number of levels within the root zone
4556 !     prcpms - precipitation rate in m/s
4557 !     cotso, rhtso - coefficients for implicit solution of
4558 !                     heat diffusion equation
4559 !     thdif - thermal diffusivity (m^2/s)
4560 !     qsg,qvg,qcg - saturated mixing ratio, mixing ratio of
4561 !                   water vapor and cloud at the ground
4562 !                   surface, respectively (kg/kg)
4563 !     patm -  pressure [bar]
4564 !     qc3d,qv3d - cloud and water vapor mixing ratio
4565 !                   at the first atm. level (kg/kg)
4566 !     emiss,rnet - emissivity (0-1) of the ground surface and net
4567 !                  radiation at the surface (w/m^2)
4568 !     qkms - exchange coefficient for water vapor in the
4569 !              surface layer (m/s)
4570 !     tkms - exchange coefficient for heat in the surface
4571 !              layer (m/s)
4572 !     pc - plant coefficient (resistance)
4573 !     rho - density of atmosphere near surface (kg/m^3)
4574 !     vegfrac - greeness fraction (0-1)
4575 !     cap - volumetric heat capacity (j/m^3/k)
4576 !     drycan - dry fraction of vegetated area where
4577 !              transpiration may take place (0-1)
4578 !     wetcan - fraction of vegetated area covered by canopy
4579 !              water (0-1)
4580 !     transum - transpiration function integrated over the
4581 !               rooting zone (m)
4582 !     dew -  dew in kg/m^2s
4583 !     mavail - fraction of maximum soil moisture in the top
4584 !               layer (0-1)
4585 !     zsmain - main levels in soil (m)
4586 !     zshalf - middle of the soil layers (m)
4587 !     dtdzs - dt/(2.*dzshalf*dzmain)
4588 !     tbq - table to define saturated mixing ration
4589 !           of water vapor for given temperature and pressure
4590 !     tso - soil temperature (k)
4591 !     soilt - skin temperature (k)
4592 !
4593 !****************************************************************
4594
4595         implicit none
4596 !-----------------------------------------------------------------
4597
4598 !--- input variables
4599
4600    integer,  intent(in   )   ::  nroot,ktau,nzs                , &
4601                                  nddzs                         !nddzs=2*(nzs-2)
4602    integer,  intent(in   )   ::  i,j,iland,isoil
4603    real,     intent(in   )   ::  delt,conflx,prcpms, rainf
4604    real,     intent(inout)   ::  drycan,wetcan,transum
4605 !--- 3-d atmospheric variables
4606    real,                                                         &
4607             intent(in   )    ::                            patm, &
4608                                                           qvatm, &
4609                                                           qcatm
4610 !--- 2-d variables
4611    real                                                        , &
4612             intent(in   )    ::                                  &
4613                                                           emiss, &
4614                                                             rho, &
4615                                                            rnet, &
4616                                                              pc, &
4617                                                         vegfrac, &
4618                                                             lai, &
4619                                                             dew, &
4620                                                            qkms, &
4621                                                            tkms
4622
4623 !--- soil properties
4624    real                                                        , &
4625             intent(in   )    ::                                  &
4626                                                            bclh, &
4627                                                             dqm, &
4628                                                            qmin
4629    real                                                        , &
4630             intent(in   )    ::                                  &
4631                                                    soilres,alfa
4632
4633
4634    real,     intent(in   )   ::                              cp, &
4635                                                             cvw, &
4636                                                             xlv, &
4637                                                          stbolt, &
4638                                                            tabs, &
4639                                                            g0_p
4640
4641
4642    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
4643                                                          zshalf, &
4644                                                           thdif, &
4645                                                             cap
4646
4647    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
4648
4649    real,     dimension(1:5001), intent(in)  ::              tbq
4650
4651
4652 !--- input/output variables
4653 !-------- 3-d soil moisture and temperature
4654    real,     dimension( 1:nzs )                                , &
4655              intent(inout)   ::                             tso
4656
4657 !-------- 2-d variables
4658    real                                                        , &
4659              intent(inout)   ::                                  &
4660                                                          mavail, &
4661                                                             qvg, &
4662                                                             qsg, &
4663                                                             qcg, &
4664                                                           soilt
4665
4666
4667 !--- local variables
4668
4669    real    ::  x,x1,x2,x4,dzstop,can,ft,sph                    , &
4670                tn,trans,umveg,denom,fex
4671
4672    real    ::  fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11     , &
4673                pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2       , &
4674                tdenom
4675
4676    real    ::  c,cc,aa1,rhcs,h1, qgold
4677
4678    real,     dimension(1:nzs)  ::                   cotso,rhtso
4679
4680    integer ::  nzs1,nzs2,k,k1,kn,kk, iter
4681
4682
4683 !-----------------------------------------------------------------
4684
4685         iter=0
4686
4687           nzs1=nzs-1
4688           nzs2=nzs-2
4689         dzstop=1./(zsmain(2)-zsmain(1))
4690
4691         qgold=qvg
4692
4693         do k=1,nzs
4694            cotso(k)=0.
4695            rhtso(k)=0.
4696         enddo
4697 !******************************************************************************
4698 !       coefficients for thomas algorithm for tso
4699 !******************************************************************************
4700 !         did=2.*(zsmain(nzs)-zshalf(nzs))
4701 !         h1=dtdzs(8)*thdif(nzs-1)*(zshalf(nzs)-zshalf(nzs-1))/did
4702 !         cotso(1)=h1/(1.+h1)
4703 !         rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/
4704 !     1         (1.+h1)
4705         cotso(1)=0.
4706         rhtso(1)=tso(nzs)
4707         do 33 k=1,nzs2
4708           kn=nzs-k
4709           k1=2*kn-3
4710           x1=dtdzs(k1)*thdif(kn-1)
4711           x2=dtdzs(k1+1)*thdif(kn)
4712           ft=tso(kn)+x1*(tso(kn-1)-tso(kn))                             &
4713              -x2*(tso(kn)-tso(kn+1))
4714           denom=1.+x1+x2-x2*cotso(k)
4715           cotso(k+1)=x1/denom
4716           rhtso(k+1)=(ft+x2*rhtso(k))/denom
4717    33  continue
4718
4719 !************************************************************************
4720 !--- the heat balance equation (Smirnova et al., 1996, eq. 21,26)
4721
4722         rhcs=cap(1)
4723
4724         h=mavail
4725
4726         trans=transum*drycan/zshalf(nroot+1)
4727         can=wetcan+trans
4728         umveg=(1.-vegfrac) * soilres
4729  2111   continue
4730         fkt=tkms
4731         d1=cotso(nzs1)
4732         d2=rhtso(nzs1)
4733         tn=soilt
4734         d9=thdif(1)*rhcs*dzstop
4735         d10=tkms*cp*rho
4736         r211=.5*conflx/delt
4737         r21=r211*cp*rho
4738         r22=.5/(thdif(1)*delt*dzstop**2)
4739         r6=emiss *stbolt*.5*tn**4
4740         r7=r6/tn
4741         d11=rnet+r6
4742         tdenom=d9*(1.-d1+r22)+d10+r21+r7                              &
4743               +rainf*cvw*prcpms
4744         fkq=qkms*rho
4745         r210=r211*rho
4746         c=vegfrac*fkq*can
4747         cc=c*xlv/tdenom
4748         aa=xlv*(fkq*umveg+r210)/tdenom
4749         bb=(d10*tabs+r21*tn+xlv*(qvatm*                               &
4750         (fkq*umveg+c)                                                 &
4751         +r210*qvg)+d11+d9*(d2+r22*tn)                                 &
4752         +rainf*cvw*prcpms*max(273.15,tabs)                            &
4753          )/tdenom
4754         aa1=aa+cc
4755 !        aa1=aa*alfa+cc
4756         pp=patm*1.e3
4757         aa1=aa1/pp
4758         call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil)
4759         tq2=qvatm
4760         tx2=tq2*(1.-h)
4761         q1=tx2+h*qs1
4762 !        q1=alfa*qs1
4763     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4764         print *,'vilka1 - ts1,qs1,tq2,h,tx2,q1',ts1,qs1,tq2,h,tx2,q1
4765     endif
4766 !with alfa        go to 100
4767         if(q1.lt.qs1) goto 100
4768 !--- if no saturation - goto 100
4769 !--- if saturation - goto 90
4770    90   qvg=qs1
4771         qsg=qs1
4772         tso(1)=ts1
4773         qcg=max(0.,q1-qs1)
4774     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4775         print *,'90 qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1)
4776     endif
4777         goto 200
4778   100   bb=bb-aa*tx2
4779         aa=(aa*h+cc)/pp
4780         call vilka(tn,aa,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil)
4781         q1=tx2+h*qs1
4782     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4783         print *,'vilka2 - ts1,qs1,tq2,h,tx2,q1',ts1,qs1,tq2,h,tx2,q1
4784     endif
4785         if(q1.ge.qs1) goto 90
4786 !with alfa  100  continue
4787         qsg=qs1
4788         qvg=q1
4789 !   if( qs1>qvatm .and. qvatm > qvg) then
4790 ! very dry soil
4791 !     print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1
4792 !        qvg = qvatm
4793 !   endif
4794         tso(1)=ts1
4795         qcg=0.
4796     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4797        print *,'q1,qsg,qvg,qvatm,alfa,h',q1,qsg,qvg,qvatm,alfa,h
4798     endif
4799   200   continue
4800     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4801         print *,'200 qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1)
4802     endif
4803
4804 !--- soilt - skin temperature
4805           soilt=ts1
4806
4807 !---- final solution for soil temperature - tso
4808           do k=2,nzs
4809             kk=nzs-k+1
4810             tso(k)=rhtso(kk)+cotso(kk)*tso(k-1)
4811           end do
4812
4813          x= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn) + &
4814             xlv*rho*r211*(qvg-qgold)
4815 !
4816     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4817         print*,'soiltemp storage, i,j,x,soilt,tn,qvg,qvgold', &
4818                                   i,j,x,soilt,tn,qvg,qgold
4819         print *,'temp term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn)',&
4820                  (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn)
4821         print *,'qv term xlv*rho*r211*(qvg-qgold)',xlv*rho*r211*(qvg-qgold)
4822     endif
4823          x=x &
4824 ! "heat" from rain
4825         -rainf*cvw*prcpms*(max(273.15,tabs)-soilt)
4826
4827     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
4828         print *,'x=',x
4829     endif
4830
4831 !--------------------------------------------------------------------
4832    end subroutine soiltemp
4833 !--------------------------------------------------------------------
4834
4835
4836            subroutine snowtemp(                                    &
4837 !--- input variables
4838            i,j,iland,isoil,                                        &
4839            delt,ktau,conflx,nzs,nddzs,nroot,                       &
4840            snwe,snwepr,snhei,newsnow,snowfrac,                     &
4841            beta,deltsn,snth,rhosn,rhonewsn,meltfactor,             &  ! add meltfactor
4842            prcpms,rainf,                                           &
4843            patm,tabs,qvatm,qcatm,                                  &
4844            glw,gsw,emiss,rnet,                                     &
4845            qkms,tkms,pc,rho,vegfrac,                               &
4846            thdif,cap,drycan,wetcan,cst,                            &
4847            tranf,transum,dew,mavail,                               &
4848 !--- soil fixed fields
4849            dqm,qmin,psis,bclh,                                     &
4850            zsmain,zshalf,dtdzs,tbq,                                &
4851 !--- constants
4852            xlvm,cp,rovcp,g0_p,cvw,stbolt,                          &
4853 !--- output variables
4854            snweprint,snheiprint,rsm,                               &
4855            tso,soilt,soilt1,tsnav,qvg,qsg,qcg,                     &
4856            smelt,snoh,snflx,s,ilnb,x)
4857
4858 !********************************************************************
4859 !   energy budget equation and heat diffusion eqn are
4860 !   solved here to obtain snow and soil temperatures
4861 !
4862 !     delt - time step (s)
4863 !     ktau - numver of time step
4864 !     conflx - depth of constant flux layer (m)
4865 !     ime, jme, kme, nzs - dimensions of the domain
4866 !     nroot - number of levels within the root zone
4867 !     prcpms - precipitation rate in m/s
4868 !     cotso, rhtso - coefficients for implicit solution of
4869 !                     heat diffusion equation
4870 !     thdif - thermal diffusivity (w/m/k)
4871 !     qsg,qvg,qcg - saturated mixing ratio, mixing ratio of
4872 !                   water vapor and cloud at the ground
4873 !                   surface, respectively (kg/kg)
4874 !     patm - pressure [bar]
4875 !     qcatm,qvatm - cloud and water vapor mixing ratio
4876 !                   at the first atm. level (kg/kg)
4877 !     emiss,rnet - emissivity (0-1) of the ground surface and net
4878 !                  radiation at the surface (w/m^2)
4879 !     qkms - exchange coefficient for water vapor in the
4880 !              surface layer (m/s)
4881 !     tkms - exchange coefficient for heat in the surface
4882 !              layer (m/s)
4883 !     pc - plant coefficient (resistance)
4884 !     rho - density of atmosphere near surface (kg/m^3)
4885 !     vegfrac - greeness fraction (0-1)
4886 !     cap - volumetric heat capacity (j/m^3/k)
4887 !     drycan - dry fraction of vegetated area where
4888 !              transpiration may take place (0-1)
4889 !     wetcan - fraction of vegetated area covered by canopy
4890 !              water (0-1)
4891 !     transum - transpiration function integrated over the
4892 !               rooting zone (m)
4893 !     dew -  dew in kg/m^2/s
4894 !     mavail - fraction of maximum soil moisture in the top
4895 !               layer (0-1)
4896 !     zsmain - main levels in soil (m)
4897 !     zshalf - middle of the soil layers (m)
4898 !     dtdzs - dt/(2.*dzshalf*dzmain)
4899 !     tbq - table to define saturated mixing ration
4900 !           of water vapor for given temperature and pressure
4901 !     tso - soil temperature (k)
4902 !     soilt - skin temperature (k)
4903 !
4904 !*********************************************************************
4905
4906         implicit none
4907 !---------------------------------------------------------------------
4908 !--- input variables
4909
4910    integer,  intent(in   )   ::  nroot,ktau,nzs                , &
4911                                  nddzs                             !nddzs=2*(nzs-2)
4912
4913    integer,  intent(in   )   ::  i,j,iland,isoil
4914    real,     intent(in   )   ::  delt,conflx,prcpms            , &
4915                                  rainf,newsnow,deltsn,snth     , &
4916                                  tabs,transum,snwepr           , &
4917                                  rhonewsn,meltfactor
4918    real                      ::  rhonewcsn
4919
4920 !--- 3-d atmospheric variables
4921    real,                                                         &
4922             intent(in   )    ::                            patm, &
4923                                                           qvatm, &
4924                                                           qcatm
4925 !--- 2-d variables
4926    real                                                        , &
4927             intent(in   )    ::                             glw, &
4928                                                             gsw, &
4929                                                             rho, &
4930                                                              pc, &
4931                                                         vegfrac, &
4932                                                            qkms, &
4933                                                            tkms
4934
4935 !--- soil properties
4936    real                                                        , &
4937             intent(in   )    ::                                  &
4938                                                            bclh, &
4939                                                             dqm, &
4940                                                            psis, &
4941                                                            qmin
4942
4943    real,     intent(in   )   ::                              cp, &
4944                                                           rovcp, &
4945                                                             cvw, &
4946                                                          stbolt, &
4947                                                            xlvm, &
4948                                                             g0_p
4949
4950
4951    real,     dimension(1:nzs), intent(in)  ::            zsmain, &
4952                                                          zshalf, &
4953                                                           thdif, &
4954                                                             cap, &
4955                                                           tranf
4956
4957    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
4958
4959    real,     dimension(1:5001), intent(in)  ::              tbq
4960
4961
4962 !--- input/output variables
4963 !-------- 3-d soil moisture and temperature
4964    real,     dimension(  1:nzs )                               , &
4965              intent(inout)   ::                             tso
4966
4967
4968 !-------- 2-d variables
4969    real                                                        , &
4970              intent(inout)   ::                             dew, &
4971                                                             cst, &
4972                                                           rhosn, &
4973                                                           emiss, &
4974                                                          mavail, &
4975                                                             qvg, &
4976                                                             qsg, &
4977                                                             qcg, &
4978                                                            snwe, &
4979                                                           snhei, &
4980                                                        snowfrac, &
4981                                                           smelt, &
4982                                                            snoh, &
4983                                                           snflx, &
4984                                                               s, &
4985                                                           soilt, &
4986                                                          soilt1, &
4987                                                           tsnav
4988
4989    real,     intent(inout)                  ::   drycan, wetcan
4990
4991    real,     intent(out)                    ::              rsm, &
4992                                                       snweprint, &
4993                                                      snheiprint
4994    integer,  intent(out)                    ::             ilnb
4995 !--- local variables
4996
4997
4998    integer ::  nzs1,nzs2,k,k1,kn,kk
4999
5000    real    ::  x,x1,x2,x4,dzstop,can,ft,sph,                     &
5001                tn,trans,umveg,denom
5002
5003    real    ::  cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn
5004
5005    real    ::  t3,upflux,xinet,ras,                              &
5006                xlmelt,rhocsn,thdifsn,                            &
5007                beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn
5008
5009    real    ::  fso,fsn,                                          &
5010                fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11,      &
5011                pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2,        &
5012                tdenom,c,cc,aa1,rhcs,h1,                          &
5013                tsob, snprim, sh1, sh2,                           &
5014                smeltg,snohg,snodif,soh,                          &
5015                cmc2ms,tnold,qgold,snohgnew
5016
5017    real,     dimension(1:nzs)  ::  transp,cotso,rhtso
5018    real                        ::                         edir1, &
5019                                                             ec1, &
5020                                                            ett1, &
5021                                                            eeta, &
5022                                                             qfx, &
5023                                                             hfx
5024
5025    real                        :: rnet,rsmfrac,soiltfrac,hsn,rr,keff,fact
5026    integer                     ::      nmelt, iter
5027
5028 !-----------------------------------------------------------------
5029
5030        iter = 0
5031
5032        do k=1,nzs
5033           transp   (k)=0.
5034           cotso    (k)=0.
5035           rhtso    (k)=0.
5036        enddo
5037        !-- options for snow conductivity:
5038        !-- 1 - constant
5039        !-- opt 2 -  Sturm et al., 1997
5040        keff = 0.265
5041
5042     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5043 print *, 'snowtemp: snhei,snth,soilt1: ',snhei,snth,soilt1,soilt
5044     endif
5045         xlmelt=3.35e+5
5046         rhocsn=2090.* rhosn
5047 !18apr08 - add rhonewcsn
5048         rhonewcsn=2090.* rhonewsn
5049
5050         if(isncond_opt == 1) then
5051         !-- old version thdifsn = 0.265/rhocsn
5052         thdifsn = 0.265/rhocsn
5053         else
5054         !-- 07jun19 - thermal conductivity (k_eff) from Sturm et al.(1997)
5055         !-- keff = 10. ** (2.650 * rhosn*1.e-3 - 1.652)
5056            fact = 1.
5057            if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then
5058              keff = 0.023 + 0.234 * rhosn * 1.e-3
5059            else
5060              keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6
5061            endif
5062            if(newsnow <= 0. .and. snhei > 1. .and. rhosn > 250.) then
5063            !-- some areas with large snow depth have unrealistically
5064            !-- low snow density (in the rockie's with snow depth > 1 m).
5065            !-- based on Sturm et al. keff=0.452 typical for hard snow slabs
5066            !-- with rhosn=488 kg/m^3. thdifsn = 0.452/(2090*488)=4.431718e-7
5067            !-- in future a better compaction scheme is needed for these areas.
5068              thdifsn = 4.431718e-7
5069            else
5070              thdifsn = keff/rhocsn * fact
5071            endif
5072          endif ! isncond_opt
5073
5074         ras=rho*1.e-3
5075
5076         soiltfrac=soilt
5077
5078         smelt=0.
5079         soh=0.
5080         smeltg=0.
5081         snohg=0.
5082         snodif=0.
5083         rsm = 0.
5084         rsmfrac = 0.
5085         fsn=1.
5086         fso=0.
5087
5088           nzs1=nzs-1
5089           nzs2=nzs-2
5090
5091         qgold=qvg
5092         dzstop=1./(zsmain(2)-zsmain(1))
5093
5094 !******************************************************************************
5095 !       coefficients for thomas algorithm for tso
5096 !******************************************************************************
5097 !         did=2.*(zsmain(nzs)-zshalf(nzs))
5098 !         h1=dtdzs(8)*thdif(nzs-1)*(zshalf(nzs)-zshalf(nzs-1))/did
5099 !         cotso(1)=h1/(1.+h1)
5100 !         rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/
5101 !     1         (1.+h1)
5102
5103         cotso(1)=0.
5104         rhtso(1)=tso(nzs)
5105         do 33 k=1,nzs2
5106           kn=nzs-k
5107           k1=2*kn-3
5108           x1=dtdzs(k1)*thdif(kn-1)
5109           x2=dtdzs(k1+1)*thdif(kn)
5110           ft=tso(kn)+x1*(tso(kn-1)-tso(kn))                           &
5111              -x2*(tso(kn)-tso(kn+1))
5112           denom=1.+x1+x2-x2*cotso(k)
5113           cotso(k+1)=x1/denom
5114           rhtso(k+1)=(ft+x2*rhtso(k))/denom
5115    33  continue
5116 !--- the nzs element in cotso and rhtso will be for snow
5117 !--- there will be 2 layers in snow if it is deeper than deltsn+snth
5118        if(snhei.ge.snth) then
5119         if(snhei.le.deltsn+snth) then
5120 !-- 1-layer snow model
5121     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5122       print *,'1-layer - snth,snhei,deltsn',snth,snhei,deltsn
5123     endif
5124          ilnb=1
5125          snprim=max(snth,snhei)
5126          tsob=tso(1)
5127          soilt1=tso(1)
5128          xsn = delt/2./(zshalf(2)+0.5*snprim)
5129          ddzsn = xsn / snprim
5130          x1sn = ddzsn * thdifsn
5131          x2 = dtdzs(1)*thdif(1)
5132          ft = tso(1)+x1sn*(soilt-tso(1))                              &
5133               -x2*(tso(1)-tso(2))
5134          denom = 1. + x1sn + x2 -x2*cotso(nzs1)
5135          cotso(nzs)=x1sn/denom
5136          rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
5137          cotsn=cotso(nzs)
5138          rhtsn=rhtso(nzs)
5139 !*** average temperature of snow pack (c)
5140          tsnav=0.5*(soilt+tso(1))                                     &
5141                      -273.15
5142
5143         else
5144 !-- 2 layers in snow, soilt1 is temperasture at deltsn depth
5145     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5146       print *,'2-layer - snth,snhei,deltsn',snth,snhei,deltsn
5147     endif
5148          ilnb=2
5149          snprim=deltsn
5150          tsob=soilt1
5151          xsn = delt/2./(0.5*deltsn)
5152          xsn1= delt/2./(zshalf(2)+0.5*(snhei-deltsn))
5153          ddzsn = xsn / deltsn
5154          ddzsn1 = xsn1 / (snhei-deltsn)
5155          x1sn = ddzsn * thdifsn
5156          x1sn1 = ddzsn1 * thdifsn
5157          x2 = dtdzs(1)*thdif(1)
5158          ft = tso(1)+x1sn1*(soilt1-tso(1))                            &
5159               -x2*(tso(1)-tso(2))
5160          denom = 1. + x1sn1 + x2 - x2*cotso(nzs1)
5161          cotso(nzs)=x1sn1/denom
5162          rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
5163          ftsnow = soilt1+x1sn*(soilt-soilt1)                          &
5164                -x1sn1*(soilt1-tso(1))
5165          denomsn = 1. + x1sn + x1sn1 - x1sn1*cotso(nzs)
5166          cotsn=x1sn/denomsn
5167          rhtsn=(ftsnow+x1sn1*rhtso(nzs))/denomsn
5168 !*** average temperature of snow pack (c)
5169          tsnav=0.5/snhei*((soilt+soilt1)*deltsn                       &
5170                      +(soilt1+tso(1))*(snhei-deltsn))                 &
5171                      -273.15
5172         endif
5173        endif
5174        if(snhei.lt.snth.and.snhei.gt.0.) then
5175 !--- snow is too thin to be treated separately, therefore it
5176 !--- is combined with the first soil layer.
5177          snprim=snhei+zsmain(2)
5178          fsn=snhei/snprim
5179          fso=1.-fsn
5180          soilt1=tso(1)
5181          tsob=tso(2)
5182          xsn = delt/2./((zshalf(3)-zsmain(2))+0.5*snprim)
5183          ddzsn = xsn /snprim
5184          x1sn = ddzsn * (fsn*thdifsn+fso*thdif(1))
5185          x2=dtdzs(2)*thdif(2)
5186          ft=tso(2)+x1sn*(soilt-tso(2))-                              &
5187                        x2*(tso(2)-tso(3))
5188          denom = 1. + x1sn + x2 - x2*cotso(nzs-2)
5189          cotso(nzs1) = x1sn/denom
5190          rhtso(nzs1)=(ft+x2*rhtso(nzs-2))/denom
5191          tsnav=0.5*(soilt+tso(1))                                    &
5192                      -273.15
5193          cotso(nzs)=cotso(nzs1)
5194          rhtso(nzs)=rhtso(nzs1)
5195          cotsn=cotso(nzs)
5196          rhtsn=rhtso(nzs)
5197
5198        endif
5199
5200 !************************************************************************
5201 !--- the heat balance equation (Smirnova et al. 1996, eq. 21,26)
5202 !18apr08 nmelt is the flag for melting, and snoh is heat of snow phase changes
5203        nmelt=0
5204        snoh=0.
5205
5206         ett1=0.
5207         epot=-qkms*(qvatm-qgold)
5208         rhcs=cap(1)
5209         h=1.
5210         trans=transum*drycan/zshalf(nroot+1)
5211         can=wetcan+trans
5212         umveg=1.-vegfrac
5213         fkt=tkms
5214         d1=cotso(nzs1)
5215         d2=rhtso(nzs1)
5216         tn=soilt
5217         d9=thdif(1)*rhcs*dzstop
5218         d10=tkms*cp*rho
5219         r211=.5*conflx/delt
5220         r21=r211*cp*rho
5221         r22=.5/(thdif(1)*delt*dzstop**2)
5222         r6=emiss *stbolt*.5*tn**4
5223         r7=r6/tn
5224         d11=rnet+r6
5225
5226       if(snhei.ge.snth) then
5227         if(snhei.le.deltsn+snth) then
5228 !--- 1-layer snow
5229           d1sn = cotso(nzs)
5230           d2sn = rhtso(nzs)
5231     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5232       print *,'1 layer d1sn,d2sn',i,j,d1sn,d2sn
5233     endif
5234         else
5235 !--- 2-layer snow
5236           d1sn = cotsn
5237           d2sn = rhtsn
5238     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5239       print *,'2 layers d1sn,d2sn',i,j,d1sn,d2sn
5240     endif
5241         endif
5242         d9sn= thdifsn*rhocsn / snprim
5243         r22sn = snprim*snprim*0.5/(thdifsn*delt)
5244     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5245       print *,'1 or 2 layers d9sn,r22sn',d9sn,r22sn
5246     endif
5247       endif
5248
5249        if(snhei.lt.snth.and.snhei.gt.0.) then
5250 !--- thin snow is combined with soil
5251          d1sn = d1
5252          d2sn = d2
5253          d9sn = (fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)/              &
5254                  snprim
5255          r22sn = snprim*snprim*0.5                                   &
5256                  /((fsn*thdifsn+fso*thdif(1))*delt)
5257     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5258        print *,' combined  d9sn,r22sn,d1sn,d2sn: ',d9sn,r22sn,d1sn,d2sn
5259     endif
5260       endif
5261       if(snhei.eq.0.)then
5262 !--- all snow is sublimated
5263         d9sn = d9
5264         r22sn = r22
5265         d1sn = d1
5266         d2sn = d2
5267     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5268         print *,' snhei = 0, d9sn,r22sn,d1sn,d2sn: ',d9sn,r22sn,d1sn,d2sn
5269     endif
5270       endif
5271
5272  2211   continue
5273
5274 !18apr08  - the snow melt iteration start point
5275  212    continue
5276
5277 !---- tdenom for snow
5278         tdenom = d9sn*(1.-d1sn +r22sn)+d10+r21+r7                    &
5279               +rainf*cvw*prcpms                                      &
5280               +rhonewcsn*newsnow/delt
5281
5282         fkq=qkms*rho
5283         r210=r211*rho
5284         c=vegfrac*fkq*can
5285         cc=c*xlvm/tdenom
5286         aa=xlvm*(beta*fkq*umveg+r210)/tdenom
5287         bb=(d10*tabs+r21*tn+xlvm*(qvatm*                             &
5288         (beta*fkq*umveg+c)                                           &
5289         +r210*qgold)+d11+d9sn*(d2sn+r22sn*tn)                        &
5290         +rainf*cvw*prcpms*max(273.15,tabs)                           &
5291         + rhonewcsn*newsnow/delt*min(273.15,tabs)                    &
5292          )/tdenom
5293         aa1=aa+cc
5294         pp=patm*1.e3
5295         aa1=aa1/pp
5296         bb=bb-snoh/tdenom
5297
5298         call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil)
5299         tq2=qvatm
5300         tx2=tq2*(1.-h)
5301         q1=tx2+h*qs1
5302     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5303      print *,'vilka1 - ts1,qs1,tq2,h,tx2,q1',ts1,qs1,tq2,h,tx2,q1
5304     endif
5305         if(q1.lt.qs1) goto 100
5306 !--- if no saturation - goto 100
5307 !--- if saturation - goto 90
5308    90   qvg=qs1
5309         qsg=qs1
5310         qcg=max(0.,q1-qs1)
5311     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5312      print *,'90 qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1)
5313     endif
5314         goto 200
5315   100   bb=bb-aa*tx2
5316         aa=(aa*h+cc)/pp
5317         call vilka(tn,aa,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil)
5318         q1=tx2+h*qs1
5319     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5320      print *,'vilka2 - ts1,qs1,h,tx2,q1',ts1,qs1,tq2,h,tx2,q1
5321     endif
5322         if(q1.gt.qs1) goto 90
5323         qsg=qs1
5324         qvg=q1
5325         qcg=0.
5326     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5327      print *,'no saturation qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1)
5328     endif
5329   200   continue
5330
5331 !--- soilt - skin temperature
5332         soilt=ts1
5333
5334      if(nmelt==1 .and. snowfrac==1. .and. snwe > 0. .and. soilt > 273.15) then
5335      !--7feb22 on the second iteration when snoh is known and snwe > 0. after melting,
5336      !-- check if the snow skin temperature is =<tfrzk
5337      !-- when a grid cell is fully covered with snow (snowfrac=1)
5338      !-- or with partial snow cover and snow_mosaic=1 (snowfrac=1).
5339          soilt = min(273.15,soilt)
5340      endif
5341
5342     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5343      if(i.eq.266.and.j.eq.447) then
5344             print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso
5345      endif
5346     endif
5347 ! solution for temperature at 7.5 cm depth and snow-soil interface
5348        if(snhei.ge.snth) then
5349         if(snhei.gt.deltsn+snth) then
5350 !-- 2-layer snow model
5351           soilt1=min(273.15,rhtsn+cotsn*soilt)
5352           tso(1)=rhtso(nzs)+cotso(nzs)*soilt1
5353           tsob=soilt1
5354         else
5355 !-- 1 layer in snow
5356           tso(1)=rhtso(nzs)+cotso(nzs)*soilt
5357           soilt1=tso(1)
5358           tsob=tso(1)
5359         endif
5360        elseif (snhei > 0. .and. snhei < snth) then
5361 ! blended
5362          tso(2)=rhtso(nzs1)+cotso(nzs1)*soilt
5363          tso(1)=(tso(2)+(soilt-tso(2))*fso)
5364          soilt1=tso(1)
5365          tsob=tso(2)
5366        else
5367 !-- very thin or zero snow. if snow is thin we suppose that
5368 !--- tso(i,j,1)=soilt, and later we recompute tso(i,j,1)
5369          tso(1)=soilt
5370          soilt1=soilt
5371          tsob=tso(1)
5372        endif
5373        if(nmelt==1.and.snowfrac==1.) then
5374        !-- second iteration with full snow cover
5375          soilt1= min(273.15,soilt1)
5376          tso(1)= min(273.15,tso(1))
5377          tsob  = min(273.15,tsob)
5378        endif
5379
5380
5381 !---- final solution for tso
5382        if (snhei > 0. .and. snhei < snth) then
5383 ! blended or snow is melted
5384           do k=3,nzs
5385             kk=nzs-k+1
5386             tso(k)=rhtso(kk)+cotso(kk)*tso(k-1)
5387           end do
5388
5389        else
5390           do k=2,nzs
5391             kk=nzs-k+1
5392             tso(k)=rhtso(kk)+cotso(kk)*tso(k-1)
5393           end do
5394        endif
5395 !--- for thin snow layer combined with the top soil layer
5396 !--- tso(1) is recomputed by linear interpolation between soilt
5397 !--- and tso(i,j,2)
5398 !       if(snhei.lt.snth.and.snhei.gt.0.)then
5399 !          tso(1)=tso(2)+(soilt-tso(2))*fso
5400 !          soilt1=tso(1)
5401 !          tsob = tso(2)
5402 !       endif
5403
5404
5405     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5406    print *,'soilt,soilt1,tso,tsob,qsg',i,j,soilt,soilt1,tso,tsob,qsg,'nmelt=',nmelt
5407     endif
5408
5409      if(nmelt.eq.1) go to 220
5410
5411 !--- if soilt > 273.15 f then melting of snow can happen
5412 !   if(soilt.gt.273.15.and.snhei.gt.0.) then
5413 ! if all snow can evaporate, then there is nothing to melt
5414    if(soilt.gt.273.15.and.beta==1..and.snhei.gt.0.) then
5415         nmelt = 1
5416         soiltfrac=snowfrac*273.15+(1.-snowfrac)*soilt
5417         qsg=min(qsg, qsn(soiltfrac,tbq)/pp)
5418         qvg=snowfrac*qsg+(1.-snowfrac)*qvg
5419         t3      = stbolt*tn*tn*tn
5420         upflux  = t3 * 0.5*(tn + soiltfrac)
5421         xinet   = emiss*(glw-upflux)
5422          epot = -qkms*(qvatm-qsg)
5423          q1=epot*ras
5424
5425         if (q1.le.0..or.iter==1) then
5426 ! ---  condensation
5427           dew=-epot
5428           do k=1,nzs
5429             transp(k)=0.
5430           enddo
5431
5432         qfx = -xlvm*rho*dew
5433         eeta = qfx/xlvm
5434        else
5435 ! ---  evaporation
5436           do k=1,nroot
5437             transp(k)=-vegfrac*q1                                     &
5438                       *tranf(k)*drycan/zshalf(nroot+1)
5439             ett1=ett1-transp(k)
5440           enddo
5441           do k=nroot+1,nzs
5442             transp(k)=0.
5443           enddo
5444
5445         edir1 = q1*umveg * beta
5446         ec1 = q1 * wetcan * vegfrac
5447         cmc2ms=cst/delt*ras
5448         eeta = (edir1 + ec1 + ett1)*1.e3
5449 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
5450         qfx=  xlvm * eeta
5451        endif
5452
5453          hfx=-d10*(tabs-soiltfrac)
5454
5455        if(snhei.ge.snth)then
5456          soh=thdifsn*rhocsn*(soiltfrac-tsob)/snprim
5457          snflx=soh
5458        else
5459          soh=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)*                   &
5460               (soiltfrac-tsob)/snprim
5461          snflx=soh
5462        endif
5463
5464 !
5465          x= (r21+d9sn*r22sn)*(soiltfrac-tn) +                        &
5466             xlvm*r210*(qvg-qgold)
5467     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5468       print *,'snowtemp storage ',i,j,x
5469       print *,'r21,d9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim', &
5470               r21,d9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim
5471     endif
5472
5473 !-- snoh is energy flux of snow phase change
5474         snoh=rnet-qfx -hfx - soh - x                                    &
5475                   +rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac)  &
5476                   +rainf*cvw*prcpms*(max(273.15,tabs)-soiltfrac)
5477         snoh=amax1(0.,snoh)
5478 !-- smelt is speed of melting in m/s
5479         smelt= snoh /xlmelt*1.e-3
5480     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5481       print *,'1- smelt',i,j,smelt
5482     endif
5483       if(epot.gt.0. .and. snwepr.le.epot*ras*delt) then
5484 !-- all snow can evaporate
5485         beta=snwepr/(epot*ras*delt)
5486         smelt=amin1(smelt,snwepr/delt-beta*epot*ras)
5487         snwe=0.
5488     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5489       print *,'2- smelt',i,j,smelt
5490     endif
5491           goto 88
5492       endif
5493
5494         smelt=amax1(0.,smelt)
5495
5496 !18apr08 - egglston limit
5497       !-- 22apr22 do not limit snow melting for hail (rhonewsn > 450), or dense snow
5498       !-- (rhosn > 350.) with very warm surface temperatures (>10c)
5499       if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then
5500 !        smelt= amin1 (smelt, 5.6e-7*meltfactor*max(1.,(soilt-273.15)))
5501         smelt= amin1 (smelt, delt/60.*5.6e-8*meltfactor*max(1.,(soilt-273.15)))
5502
5503     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5504       print *,'3- smelt',i,j,smelt
5505     endif
5506       endif
5507
5508 ! rr - potential melting
5509         rr=max(0.,snwepr/delt-beta*epot*ras)
5510         if(smelt > rr) then
5511         smelt=min(smelt,rr)
5512           snwe = 0.
5513     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5514       print *,'4- smelt i,j,smelt,rr',i,j,smelt,rr
5515     endif
5516         endif
5517
5518    88   continue
5519         snohgnew=smelt*xlmelt*1.e3
5520         snodif=amax1(0.,(snoh-snohgnew))
5521
5522         snoh=snohgnew
5523     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5524       print *,'snoh,snodif',snoh,snodif
5525     endif
5526
5527       if( smelt > 0.) then
5528 !*** from koren et al. (1999) 13% of snow melt stays in the snow pack
5529         rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13)))
5530        if(snhei > 0.01 .and. rhosn < 350.) then
5531         rsm=rsmfrac*smelt*delt
5532        else
5533 ! do not keep melted water if snow depth is less that 1 cm
5534         rsm=0.
5535        endif
5536 !18apr08 rsm is part of melted water that stays in snow as liquid
5537        if(rsm > 0.) then
5538         smelt=max(0.,smelt-rsm/delt)
5539     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5540       print *,'5- smelt i,j,smelt,rsm,snwepr,rsmfrac', &
5541                         i,j,smelt,rsm,snwepr,rsmfrac
5542     endif
5543        endif ! rsm
5544
5545       endif ! smelt > 0
5546
5547 !-- update of liquid equivalent of snow depth
5548 !-- due to evaporation and snow melt
5549       if(snwe > 0.) then
5550         snwe = amax1(0.,(snwepr-                                      &
5551                     (smelt+beta*epot*ras)*delt                        &
5552                                          ) )
5553       endif
5554
5555 !--- if there is no snow melting then just evaporation
5556 !--- or condensation cxhanges snwe
5557       else
5558        if(snhei.ne.0..and. beta == 1.) then
5559                epot=-qkms*(qvatm-qsg)
5560                snwe = amax1(0.,(snwepr-                               &
5561                     beta*epot*ras*delt))
5562        else
5563        !-- all snow is sublibated
5564          snwe = 0.
5565        endif
5566
5567       endif
5568 !18apr08 - if snow melt occurred then go into iteration for energy budget solution
5569      if(nmelt.eq.1) goto 212  ! second interation
5570  220  continue
5571
5572       if(smelt.gt.0..and.rsm.gt.0.) then
5573        if(snwe.le.rsm) then
5574     if ( 1==1 ) then
5575      print *,'snwe<rsm snwe,rsm,smelt*delt,epot*ras*delt,beta', &
5576                      snwe,rsm,smelt*delt,epot*ras*delt,beta
5577     endif
5578        else
5579 !*** update snow density on effect of snow melt, melted
5580 !*** from the top of the snow. 13% of melted water
5581 !*** remains in the pack and changes its density.
5582 !*** eq. 9 (with my correction) in koren et al. (1999)
5583           xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/                            &
5584               snwe
5585           rhosn=min(max(58.8,xsn),500.)
5586
5587           rhocsn=2090.* rhosn
5588         if(isncond_opt == 1) then
5589         !-- old version thdifsn = 0.265/rhocsn
5590           thdifsn = 0.265/rhocsn
5591         else
5592         !-- 07jun19 - thermal conductivity (k_eff) from Sturm et al.(1997)
5593         !-- keff = 10. ** (2.650 * rhosn*1.e-3 - 1.652)
5594            fact = 1.
5595            if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then
5596              keff = 0.023 + 0.234 * rhosn * 1.e-3
5597            else
5598              keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6
5599            endif
5600            if(newsnow <= 0. .and. snhei > 1. .and. rhosn > 250.) then
5601            !-- some areas with large snow depth have unrealistically
5602            !-- low snow density (in the rockie's with snow depth > 1 m).
5603            !-- based on Sturm et al. keff=0.452 typical for hard snow slabs
5604            !-- with rhosn=488 kg/m^3. thdifsn = 0.452/(2090*488)=4.431718e-7
5605            !-- in future a better compaction scheme is needed for these areas.
5606              thdifsn = 4.431718e-7
5607            else
5608              thdifsn = keff/rhocsn * fact
5609            endif
5610         endif ! isncond_opt
5611
5612         endif
5613        endif
5614
5615 !--- compute flux in the top snow layer
5616        if(snhei.ge.snth)then
5617          s=thdifsn*rhocsn*(soilt-tsob)/snprim
5618          snflx=s
5619          s=d9*(tso(1)-tso(2))
5620        elseif(snhei.lt.snth.and.snhei.gt.0.) then
5621          s=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)*                   &
5622               (soilt-tsob)/snprim
5623          snflx=s
5624          s=d9*(tso(1)-tso(2))
5625        else
5626          s=d9sn*(soilt-tsob)
5627          snflx=s
5628          s=d9*(tso(1)-tso(2))
5629        endif
5630
5631         snhei=snwe *1.e3 / rhosn
5632 !--  if ground surface temperature
5633 !--  is above freezing snow can melt from the bottom. the following
5634 !--  piece of code will check if bottom melting is possible.
5635
5636         if(tso(1).gt.273.15 .and. snhei > 0.) then
5637           if (snhei.gt.deltsn+snth) then
5638               hsn = snhei - deltsn
5639     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5640        print*,'2 layer snow - snhei,hsn',snhei,hsn
5641     endif
5642           else
5643     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5644        print*,'1 layer snow or blended - snhei',snhei
5645     endif
5646               hsn = snhei
5647           endif
5648
5649          soiltfrac=snowfrac*273.15+(1.-snowfrac)*tso(1)
5650
5651         snohg=(tso(1)-soiltfrac)*(cap(1)*zshalf(2)+                       &
5652                rhocsn*0.5*hsn) / delt
5653         snohg=amax1(0.,snohg)
5654         snodif=0.
5655         smeltg=snohg/xlmelt*1.e-3
5656 ! egglston - empirical limit on snow melt from the bottom of snow pack
5657       !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting
5658       if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then
5659         smeltg=amin1(smeltg, 5.8e-9)
5660       endif
5661
5662 ! rr - potential melting
5663         rr=snwe/delt
5664         smeltg=amin1(smeltg, rr)
5665
5666         snohgnew=smeltg*xlmelt*1.e3
5667         snodif=amax1(0.,(snohg-snohgnew))
5668     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5669        print *,'tso(1),soiltfrac,smeltg,snodif',tso(1),soiltfrac,smeltg,snodif
5670     endif
5671
5672         snwe=max(0.,snwe-smeltg*delt)
5673         snhei=snwe *1.e3 / rhosn
5674         !-- add up all snow melt
5675         smelt = smelt + smeltg
5676
5677         if(snhei > 0.) tso(1) = soiltfrac
5678     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5679        print *,'melt from the bottom snwe,snhei',snwe,snhei
5680        if (snhei==0.) &
5681        print *,'snow is all melted on the warm ground'
5682     endif
5683
5684        endif
5685     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5686       print *,'snhei,snoh',i,j,snhei,snoh
5687     endif
5688 !                                              &
5689         snweprint=snwe
5690         snheiprint=snweprint*1.e3 / rhosn
5691
5692     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5693 print *, 'snweprint : ',snweprint
5694 print *, 'd9sn,soilt,tsob : ', d9sn,soilt,tsob
5695     endif
5696
5697          x= (r21+d9sn*r22sn)*(soilt-tn) +                     &
5698             xlvm*r210*(qsg-qgold)
5699     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5700       print *,'snowtemp storage ',i,j,x
5701       print *,'r21,d9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', &
5702               r21,d9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim
5703     endif
5704
5705          x=x &
5706 ! "heat" from snow and rain
5707         -rhonewcsn*newsnow/delt*(min(273.15,tabs)-soilt)         &
5708         -rainf*cvw*prcpms*(max(273.15,tabs)-soilt)
5709     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5710      print *,'x=',x
5711      print *,'snhei=',snhei
5712      print *,'snflx=',snflx
5713     endif
5714
5715       if(snhei.gt.0.) then
5716         if(ilnb.gt.1) then
5717           tsnav=0.5/snhei*((soilt+soilt1)*deltsn                     &
5718                     +(soilt1+tso(1))*(snhei-deltsn))                 &
5719                        -273.15
5720         else
5721           tsnav=0.5*(soilt+tso(1)) - 273.15
5722         endif
5723       else
5724           tsnav= soilt - 273.15
5725       endif
5726
5727 !------------------------------------------------------------------------
5728    end subroutine snowtemp
5729 !------------------------------------------------------------------------
5730
5731
5732         subroutine soilmoist (                                  &
5733 !--input parameters
5734               delt,nzs,nddzs,dtdzs,dtdzs2,riw,                  &
5735               zsmain,zshalf,diffu,hydro,                        &
5736               qsg,qvg,qcg,qcatm,qvatm,prcp,                     &
5737               qkms,transp,drip,                                 &
5738               dew,smelt,soilice,vegfrac,snowfrac,soilres,       &
5739 !--soil properties
5740               dqm,qmin,ref,ksat,ras,infmax,                     &
5741 !--output
5742               soilmois,soiliqw,mavail,runoff,runoff2,infiltrp)
5743 !*************************************************************************
5744 !   moisture balance equation and richards eqn.
5745 !   are solved here
5746 !
5747 !     delt - time step (s)
5748 !     ime,jme,nzs - dimensions of soil domain
5749 !     zsmain - main levels in soil (m)
5750 !     zshalf - middle of the soil layers (m)
5751 !     dtdzs -  dt/(2.*dzshalf*dzmain)
5752 !     dtdzs2 - dt/(2.*dzshalf)
5753 !     diffu - diffusional conductivity (m^2/s)
5754 !     hydro - hydraulic conductivity (m/s)
5755 !     qsg,qvg,qcg - saturated mixing ratio, mixing ratio of
5756 !                   water vapor and cloud at the ground
5757 !                   surface, respectively (kg/kg)
5758 !     qcatm,qvatm - cloud and water vapor mixing ratio
5759 !                   at the first atm. level (kg/kg)
5760 !     prcp - precipitation rate in m/s
5761 !     qkms - exchange coefficient for water vapor in the
5762 !              surface layer (m/s)
5763 !     transp - transpiration from the soil layers (m/s)
5764 !     drip - liquid water dripping from the canopy to soil (m)
5765 !     dew -  dew in kg/m^2s
5766 !     smelt - melting rate in m/s
5767 !     soilice - volumetric content of ice in soil (m^3/m^3)
5768 !     soiliqw - volumetric content of liquid water in soil (m^3/m^3)
5769 !     vegfrac - greeness fraction (0-1)
5770 !     ras - ration of air density to soil density
5771 !     infmax - maximum infiltration rate (kg/m^2/s)
5772 !
5773 !     soilmois - volumetric soil moisture, 6 levels (m^3/m^3)
5774 !     mavail - fraction of maximum soil moisture in the top
5775 !               layer (0-1)
5776 !     runoff - surface runoff (m/s)
5777 !     runoff2 - underground runoff (m)
5778 !     infiltrp - point infiltration flux into soil (m/s)
5779 !            /(snow bottom runoff) (mm/s)
5780 !
5781 !     cosmc, rhsmc - coefficients for implicit solution of
5782 !                     richards equation
5783 !******************************************************************
5784         implicit none
5785 !------------------------------------------------------------------
5786 !--- input variables
5787    real,     intent(in   )   ::  delt
5788    integer,  intent(in   )   ::  nzs,nddzs
5789
5790 ! input variables
5791
5792    real,     dimension(1:nzs), intent(in   )  ::         zsmain, &
5793                                                          zshalf, &
5794                                                           diffu, &
5795                                                           hydro, &
5796                                                          transp, &
5797                                                         soilice, &
5798                                                          dtdzs2
5799
5800    real,     dimension(1:nddzs), intent(in)  ::           dtdzs
5801
5802    real,     intent(in   )   ::    qsg,qvg,qcg,qcatm,qvatm     , &
5803                                    qkms,vegfrac,drip,prcp      , &
5804                                    dew,smelt,snowfrac          , &
5805                                    dqm,qmin,ref,ksat,ras,riw,soilres
5806
5807 ! output
5808
5809    real,     dimension(  1:nzs )                               , &
5810
5811              intent(inout)   ::                soilmois,soiliqw
5812
5813    real,     intent(inout)   ::  mavail,runoff,runoff2,infiltrp, &
5814                                                         infmax
5815
5816 ! local variables
5817
5818    real,     dimension( 1:nzs )  ::  cosmc,rhsmc
5819
5820    real    ::  dzs,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10
5821    real    ::  refkdt,refdk,delt1,f1max,f2max
5822    real    ::  f1,f2,fd,kdt,val,ddt,px,fk,fkmax
5823    real    ::  qq,umveg,infmax1,trans
5824    real    ::  totliq,flx,flxsat,qtot
5825    real    ::  did,x1,x2,x4,denom,q2,q4
5826    real    ::  dice,fcr,acrt,frzx,sum,cvfrz
5827
5828    integer ::  nzs1,nzs2,k,kk,k1,kn,ialp1,jj,jk
5829
5830 !******************************************************************************
5831 !       coefficients for thomas algorithm for soilmois
5832 !******************************************************************************
5833           nzs1=nzs-1
5834           nzs2=nzs-2
5835
5836  118      format(6(10pf23.19))
5837
5838            do k=1,nzs
5839             cosmc(k)=0.
5840             rhsmc(k)=0.
5841            enddo
5842
5843         did=(zsmain(nzs)-zshalf(nzs))
5844         x1=zsmain(nzs)-zsmain(nzs1)
5845
5846 !7may09        did=(zsmain(nzs)-zshalf(nzs))*2.
5847 !        denom=did/delt+diffu(nzs1)/x1
5848 !        cosmc(1)=diffu(nzs1)/x1/denom
5849 !        rhsmc(1)=(soilmois(nzs)*did/delt
5850 !     1   +transp(nzs)-(hydro(nzs)*soilmois(nzs)
5851 !     1   -hydro(nzs1)*soilmois(nzs1))*did
5852 !     1   /x1) /denom
5853
5854         denom=(1.+diffu(nzs1)/x1/did*delt+hydro(nzs)/(2.*did)*delt)
5855         cosmc(1)=delt*(diffu(nzs1)/did/x1                                &
5856                     +hydro(nzs1)/2./did)/denom
5857         rhsmc(1)=(soilmois(nzs)+transp(nzs)*delt/                         &
5858                did)/denom
5859
5860 !        rhsmc(1)=(soilmois(nzs)*did/delt  &
5861 !        +transp(nzs)-(hydro(nzs)*soilmois(nzs) &
5862 !        -hydro(nzs1)*soilmois(nzs1))*did &
5863 !        /x1) /denom
5864
5865 !12 june 2014 - low boundary condition: 1 - zero diffusion below the lowest
5866 ! level; 2 - soil moisture at the low boundary can be lost due to the root uptake.
5867 ! so far - no interaction with the water table.
5868
5869         denom=1.+diffu(nzs1)/x1/did*delt
5870         cosmc(1)=delt*(diffu(nzs1)/did/x1                                &
5871                     +hydro(nzs1)/did)/denom
5872         rhsmc(1)=(soilmois(nzs)-hydro(nzs)*delt/did*soilmois(nzs) &
5873                  +transp(nzs)*delt/did)/denom
5874         cosmc(1)=0.
5875         rhsmc(1)=soilmois(nzs)
5876 !
5877         do 330 k=1,nzs2
5878           kn=nzs-k
5879           k1=2*kn-3
5880           x4=2.*dtdzs(k1)*diffu(kn-1)
5881           x2=2.*dtdzs(k1+1)*diffu(kn)
5882           q4=x4+hydro(kn-1)*dtdzs2(kn-1)
5883           q2=x2-hydro(kn+1)*dtdzs2(kn-1)
5884           denom=1.+x2+x4-q2*cosmc(k)
5885           cosmc(k+1)=q4/denom
5886     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5887           print *,'q2,soilmois(kn),diffu(kn),x2,hydro(kn+1),dtdzs2(kn-1),kn,k' &
5888                   ,q2,soilmois(kn),diffu(kn),x2,hydro(kn+1),dtdzs2(kn-1),kn,k
5889     endif
5890  330      rhsmc(k+1)=(soilmois(kn)+q2*rhsmc(k)                            &
5891                    +transp(kn)                                            &
5892                    /(zshalf(kn+1)-zshalf(kn))                             &
5893                    *delt)/denom
5894
5895 ! --- moisture balance begins here
5896
5897           trans=transp(1)
5898           umveg=(1.-vegfrac)*soilres
5899
5900           runoff=0.
5901           runoff2=0.
5902           dzs=zsmain(2)
5903           r1=cosmc(nzs1)
5904           r2= rhsmc(nzs1)
5905           r3=diffu(1)/dzs
5906           r4=r3+hydro(1)*.5
5907           r5=r3-hydro(2)*.5
5908           r6=qkms*ras
5909 !-- total liquid water available on the top of soil domain
5910 !-- without snow - 3 sources of water: precipitation,
5911 !--         water dripping from the canopy and dew
5912 !-- with snow - only one source of water - snow melt
5913
5914   191   format (f23.19)
5915
5916 !        totliq=umveg*prcp-drip/delt-umveg*dew*ras-smelt
5917
5918         totliq=prcp-drip/delt-umveg*dew*ras-smelt
5919     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5920 print *,'umveg*prcp,drip/delt,umveg*dew*ras,smelt', &
5921          umveg*prcp,drip/delt,umveg*dew*ras,smelt
5922     endif
5923
5924         flx=totliq
5925         infiltrp=totliq
5926
5927 ! -----------     frozen ground version    -------------------------
5928 !   reference frozen ground parameter, cvfrz, is a shape parameter of
5929 !   areal distribution function of soil ice content which equals 1/cv.
5930 !   cv is a coefficient of spatial variation of soil ice content.
5931 !   based on field data cv depends on areal mean of frozen depth, and it
5932 !   close to constant = 0.6 if areal mean frozen depth is above 20 cm.
5933 !   that is why parameter cvfrz = 3 (int{1/0.6*0.6})
5934 !
5935 !   current logic doesn't allow cvfrz be bigger than 3
5936          cvfrz = 3.
5937
5938 !-- schaake/koren expression for calculation of max infiltration
5939          refkdt=3.
5940          refdk=3.4341e-6
5941          delt1=delt/86400.
5942          f1max=dqm*zshalf(2)
5943          f2max=dqm*(zshalf(3)-zshalf(2))
5944          f1=f1max*(1.-soilmois(1)/dqm)
5945          dice=soilice(1)*zshalf(2)
5946          fd=f1
5947         do k=2,nzs1
5948          dice=dice+(zshalf(k+1)-zshalf(k))*soilice(k)
5949          fkmax=dqm*(zshalf(k+1)-zshalf(k))
5950          fk=fkmax*(1.-soilmois(k)/dqm)
5951          fd=fd+fk
5952         enddo
5953          kdt=refkdt*ksat/refdk
5954          val=(1.-exp(-kdt*delt1))
5955          ddt = fd*val
5956          px= - totliq * delt
5957          if(px.lt.0.0) px = 0.0
5958          if(px.gt.0.0) then
5959            infmax1 = (px*(ddt/(px+ddt)))/delt
5960          else
5961            infmax1 = 0.
5962          endif
5963     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5964   print *,'infmax1 before frozen part',infmax1
5965     endif
5966
5967 ! -----------     frozen ground version    --------------------------
5968 !    reduction of infiltration based on frozen ground parameters
5969 !
5970 ! ------------------------------------------------------------------
5971
5972          frzx= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468)
5973          fcr = 1.
5974          if ( dice .gt. 1.e-2) then
5975            acrt = cvfrz * frzx / dice
5976            sum = 1.
5977            ialp1 = cvfrz - 1
5978            do jk = 1,ialp1
5979               k = 1
5980               do jj = jk+1, ialp1
5981                 k = k * jj
5982               end do
5983               sum = sum + (acrt ** ( cvfrz-jk)) / float (k)
5984            end do
5985            fcr = 1. - exp(-acrt) * sum
5986          end if
5987     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5988           print *,'fcr--------',fcr
5989           print *,'dice=',dice
5990     endif
5991          infmax1 = infmax1* fcr
5992 ! -------------------------------------------------------------------
5993
5994          infmax = max(infmax1,hydro(1)*soilmois(1))
5995          infmax = min(infmax, -totliq)
5996     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
5997 print *,'infmax,infmax1,hydro(1)*soiliqw(1),-totliq', &
5998          infmax,infmax1,hydro(1)*soiliqw(1),-totliq
5999     endif
6000 !----
6001           if (-totliq.gt.infmax)then
6002             runoff=-totliq-infmax
6003             flx=-infmax
6004     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6005        print *,'flx,runoff1=',flx,runoff
6006     endif
6007           endif
6008 ! infiltrp is total infiltration flux in m/s
6009           infiltrp=flx
6010 ! solution of moisture budget
6011           r7=.5*dzs/delt
6012           r4=r4+r7
6013           flx=flx-soilmois(1)*r7
6014 ! r8 is for direct evaporation from soil, which occurs
6015 ! only from snow-free areas
6016 !          r8=umveg*r6
6017           r8=umveg*r6*(1.-snowfrac)
6018           qtot=qvatm+qcatm
6019           r9=trans
6020           r10=qtot-qsg
6021
6022 !-- evaporation regime
6023           if(r10.le.0.) then
6024             qq=(r5*r2-flx+r9)/(r4-r5*r1-r10*r8/(ref-qmin))
6025             flxsat=-dqm*(r4-r5*r1-r10*r8/(ref-qmin))                &
6026                    +r5*r2+r9
6027           else
6028 !-- dew formation regime
6029             qq=(r2*r5-flx+r8*(qtot-qcg-qvg)+r9)/(r4-r1*r5)
6030             flxsat=-dqm*(r4-r1*r5)+r2*r5+r8*(qtot-qvg-qcg)+r9
6031           end if
6032
6033           if(qq.lt.0.) then
6034 !  print *,'negative qq=',qq
6035             soilmois(1)=1.e-8
6036
6037           else if(qq.gt.dqm) then
6038 !-- saturation
6039             soilmois(1)=dqm
6040     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6041    print *,'flxsat,flx,delt',flxsat,flx,delt,runoff2
6042     endif
6043 !            runoff2=(flxsat-flx)
6044             runoff=runoff+(flxsat-flx)
6045           else
6046             soilmois(1)=min(dqm,max(1.e-8,qq))
6047           end if
6048
6049     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6050    print *,'soilmois,soiliqw, soilice',soilmois,soiliqw,soilice*riw
6051    print *,'cosmc,rhsmc',cosmc,rhsmc
6052     endif
6053 !--- final solution for soilmois
6054 !          do k=2,nzs1
6055           do k=2,nzs
6056             kk=nzs-k+1
6057             qq=cosmc(kk)*soilmois(k-1)+rhsmc(kk)
6058 !            qq=cosmc(kk)*soiliqw(k-1)+rhsmc(kk)
6059
6060            if (qq.lt.0.) then
6061 !  print *,'negative qq=',qq
6062             soilmois(k)=1.e-8
6063
6064            else if(qq.gt.dqm) then
6065 !-- saturation
6066             soilmois(k)=dqm
6067              if(k.eq.nzs)then
6068     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6069    print *,'hydro(k),qq,dqm,k',hydro(k),qq,dqm,k
6070     endif
6071                runoff2=runoff2+((qq-dqm)*(zsmain(k)-zshalf(k)))/delt
6072              else
6073                runoff2=runoff2+((qq-dqm)*(zshalf(k+1)-zshalf(k)))/delt
6074              endif
6075            else
6076             soilmois(k)=min(dqm,max(1.e-8,qq))
6077            end if
6078           end do
6079     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6080    print *,'end soilmois,soiliqw,soilice',soilmois,soiliqw,soilice*riw
6081     endif
6082
6083            mavail=max(.00001,min(1.,(soilmois(1)/(ref-qmin)*(1.-snowfrac)+1.*snowfrac)))
6084
6085 !        return
6086 !        end
6087 !-------------------------------------------------------------------
6088     end subroutine soilmoist
6089 !-------------------------------------------------------------------
6090
6091
6092           subroutine soilprop(spp_lsm,rstochcol,fieldcol_sf, &
6093 !--- input variables
6094          nzs,fwsat,lwsat,tav,keepfr,                              &
6095          soilmois,soiliqw,soilice,                                &
6096          soilmoism,soiliqwm,soilicem,                             &
6097 !--- soil fixed fields
6098          qwrtz,rhocs,dqm,qmin,psis,bclh,ksat,                     &
6099 !--- constants
6100          riw,xlmelt,cp,g0_p,cvw,ci,                               &
6101          kqwrtz,kice,kwt,                                         &
6102 !--- output variables
6103          thdif,diffu,hydro,cap)
6104
6105 !******************************************************************
6106 ! soilprop computes thermal diffusivity, and diffusional and
6107 !          hydraulic condeuctivities
6108 !******************************************************************
6109 ! nx,ny,nzs - dimensions of soil domain
6110 ! fwsat, lwsat - volumetric content of frozen and liquid water
6111 !                for saturated condition at given temperatures (m^3/m^3)
6112 ! tav - temperature averaged for soil layers (k)
6113 ! soilmois - volumetric soil moisture at the main soil levels (m^3/m^3)
6114 ! soilmoism - volumetric soil moisture averaged for layers (m^3/m^3)
6115 ! soiliqwm - volumetric liquid soil moisture averaged for layers (m^3/m^3)
6116 ! soilicem - volumetric content of soil ice averaged for layers (m^3/m^3)
6117 ! thdif - thermal diffusivity for soil layers (w/m/k)
6118 ! diffu - diffusional conductivity (m^2/s)
6119 ! hydro - hydraulic conductivity (m/s)
6120 ! cap - volumetric heat capacity (j/m^3/k)
6121 !
6122 !******************************************************************
6123
6124         implicit none
6125 !-----------------------------------------------------------------
6126
6127 !--- soil properties
6128    integer, intent(in   )    ::                            nzs
6129    real                                                        , &
6130             intent(in   )    ::                           rhocs, &
6131                                                            bclh, &
6132                                                             dqm, &
6133                                                            ksat, &
6134                                                            psis, &
6135                                                           qwrtz, &
6136                                                            qmin
6137
6138    real,    dimension(  1:nzs )                                , &
6139             intent(in   )    ::                        soilmois, &
6140                                                          keepfr
6141
6142
6143    real,     intent(in   )   ::                              cp, &
6144                                                             cvw, &
6145                                                             riw, &
6146                                                          kqwrtz, &
6147                                                            kice, &
6148                                                             kwt, &
6149                                                          xlmelt, &
6150                                                             g0_p
6151
6152    real,     dimension(1:nzs), intent(in)  ::          rstochcol
6153    real,     dimension(1:nzs), intent(inout) ::      fieldcol_sf
6154    integer,  intent(in   )   ::                     spp_lsm
6155
6156
6157 !--- output variables
6158    real,     dimension(1:nzs)                                  , &
6159             intent(inout)  ::      cap,diffu,hydro             , &
6160                                    thdif,tav                   , &
6161                                    soilmoism                   , &
6162                                    soiliqw,soilice             , &
6163                                    soilicem,soiliqwm           , &
6164                                    fwsat,lwsat
6165
6166 !--- local variables
6167    real,     dimension(1:nzs)  ::  hk,detal,kasat,kjpl
6168
6169    real    ::  x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci
6170    real    ::  tln,tavln,tn,pf,a,am,ame,h
6171    integer ::  nzs1,k
6172
6173 !-- for johansen thermal conductivity
6174    real    ::  kzero,gamd,kdry,kas,x5,sr,ke
6175
6176
6177          nzs1=nzs-1
6178
6179 !-- constants for johansen (1975) thermal conductivity
6180          kzero =2.       ! if qwrtz > 0.2
6181
6182
6183          do k=1,nzs
6184             detal (k)=0.
6185             kasat (k)=0.
6186             kjpl  (k)=0.
6187             hk    (k)=0.
6188          enddo
6189
6190            ws=dqm+qmin
6191            x1=xlmelt/(g0_p*psis)
6192            x2=x1/bclh*ws
6193            x4=(bclh+1.)/bclh
6194 !--- next 3 lines are for johansen thermal conduct.
6195            gamd=(1.-ws)*2700.
6196            kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd)
6197            !-- one more option from christa's paper
6198            if(qwrtz > 0.2) then
6199            kas=kqwrtz**qwrtz*kzero**(1.-qwrtz)
6200            else
6201              kas=kqwrtz**qwrtz*3.**(1.-qwrtz)
6202            endif
6203
6204          do k=1,nzs1
6205            tn=tav(k) - 273.15
6206            wd=ws - riw*soilicem(k)
6207            psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh            &
6208                 * (ws/wd)**3.
6209 !--- psif should be in [cm] to compute pf
6210            pf=log10(abs(psif))
6211            fact=1.+riw*soilicem(k)
6212 !--- hk is for mccumber thermal conductivity
6213          if(pf.le.5.2) then
6214            hk(k)=420.*exp(-(pf+2.7))*fact
6215          else
6216            hk(k)=.1744*fact
6217          end if
6218
6219            if(soilicem(k).ne.0.and.tn.lt.0.) then
6220 !--- detal is taking care of energy spent on freezing or released from
6221 !          melting of soil water
6222
6223               detal(k)=273.15*x2/(tav(k)*tav(k))*                  &
6224                      (tav(k)/(x1*tn))**x4
6225
6226               if(keepfr(k).eq.1.) then
6227                  detal(k)=0.
6228               endif
6229
6230            endif
6231
6232 !--- next 10 lines calculate johansen thermal conductivity kjpl
6233            kasat(k)=kas**(1.-ws)*kice**fwsat(k)                    &
6234                     *kwt**lwsat(k)
6235
6236            x5=(soilmoism(k)+qmin)/ws
6237          if(soilicem(k).eq.0.) then
6238            sr=max(0.101,x5)
6239            ke=log10(sr)+1.
6240 !--- next 2 lines - for coarse soils
6241 !           sr=max(0.0501,x5)
6242 !           ke=0.7*log10(sr)+1.
6243          else
6244            ke=x5
6245          endif
6246
6247            kjpl(k)=ke*(kasat(k)-kdry)+kdry
6248
6249 !--- cap -volumetric heat capacity
6250             cap(k)=(1.-ws)*rhocs                                    &
6251                   + (soiliqwm(k)+qmin)*cvw                          &
6252                   + soilicem(k)*ci                                  &
6253                   + (dqm-soilmoism(k))*cp*1.2                       &
6254             - detal(k)*1.e3*xlmelt
6255
6256            a=riw*soilicem(k)
6257
6258         if((ws-a).lt.0.12)then
6259            diffu(k)=0.
6260         else
6261            h=max(0.,(soilmoism(k)+qmin-a)/(max(1.e-8,(ws-a))))
6262            facd=1.
6263         if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(k))
6264           ame=max(1.e-8,ws-riw*soilicem(k))
6265 !--- diffu is diffusional conductivity of soil water
6266           diffu(k)=-bclh*ksat*psis/ame*                             &
6267                   (ws/ame)**3.                                     &
6268                   *h**(bclh+2.)*facd
6269          endif
6270
6271 !--- thdif - thermal diffusivity
6272 !           thdif(k)=hk(k)/cap(k)
6273 !--- use thermal conductivity from johansen (1975)
6274             thdif(k)=kjpl(k)/cap(k)
6275
6276          end do
6277
6278     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6279    print *,'soilice*riw,soiliqw,soilmois,ws',soilice*riw,soiliqw,soilmois,ws
6280     endif
6281          do k=1,nzs
6282
6283          if((ws-riw*soilice(k)).lt.0.12)then
6284             hydro(k)=0.
6285          else
6286             fach=1.
6287           if(soilice(k).ne.0.)                                     &
6288              fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k))
6289          am=max(1.e-8,ws-riw*soilice(k))
6290 !--- hydro is hydraulic conductivity of soil water
6291           hydro(k)=min(ksat,ksat/am*                                        &
6292                   (soiliqw(k)/am)                                  &
6293                   **(2.*bclh+2.)                                   &
6294                   * fach)
6295           if(hydro(k)<1.e-10)hydro(k)=0.
6296          endif
6297
6298        enddo
6299
6300 !-----------------------------------------------------------------------
6301    end subroutine soilprop
6302 !-----------------------------------------------------------------------
6303
6304
6305            subroutine transf(i,j,                                &
6306 !--- input variables
6307               nzs,nroot,soiliqw,tabs,lai,gswin,                  &
6308 !--- soil fixed fields
6309               dqm,qmin,ref,wilt,zshalf,pc,iland,                 &
6310 !--- output variables
6311               tranf,transum)
6312
6313 !-------------------------------------------------------------------
6314 !--- tranf(k) - the transpiration function (Smirnova et al. 1996, eq. 18,19)
6315 !*******************************************************************
6316 ! nx,ny,nzs - dimensions of soil domain
6317 ! soiliqw - volumetric liquid soil moisture at the main levels (m^3/m^3)
6318 ! tranf - the transpiration function at levels (m)
6319 ! transum - transpiration function integrated over the rooting zone (m)
6320 !
6321 !*******************************************************************
6322         implicit none
6323 !-------------------------------------------------------------------
6324
6325 !--- input variables
6326
6327    integer,  intent(in   )   ::  i,j,nroot,nzs, iland
6328
6329    real                                                        , &
6330             intent(in   )    ::                gswin, tabs, lai
6331 !--- soil properties
6332    real                                                        , &
6333             intent(in   )    ::                             dqm, &
6334                                                            qmin, &
6335                                                             ref, &
6336                                                              pc, &
6337                                                            wilt
6338
6339    real,     dimension(1:nzs), intent(in)  ::          soiliqw,  &
6340                                                          zshalf
6341
6342 !-- output
6343    real,     dimension(1:nzs), intent(out)  ::            tranf
6344    real,     intent(out)  ::                            transum
6345
6346 !-- local variables
6347    real    ::  totliq, did
6348    integer ::  k
6349
6350 !-- for non-linear root distribution
6351    real    ::  gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4
6352    real    ::  ftem, pctot, fsol, f1, cmin, cmax, totcnd
6353    real,     dimension(1:nzs)   ::           part
6354 !--------------------------------------------------------------------
6355
6356         do k=1,nzs
6357            part(k)=0.
6358            tranf(k)=0.
6359         enddo
6360
6361         transum=0.
6362         totliq=soiliqw(1)+qmin
6363            sm1=totliq
6364            sm2=sm1*sm1
6365            sm3=sm2*sm1
6366            sm4=sm3*sm1
6367            ap0=0.299
6368            ap1=-8.152
6369            ap2=61.653
6370            ap3=-115.876
6371            ap4=59.656
6372            gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4
6373           if(totliq.ge.ref) gx=1.
6374           if(totliq.le.0.) gx=0.
6375           if(gx.gt.1.) gx=1.
6376           if(gx.lt.0.) gx=0.
6377         did=zshalf(2)
6378           part(1)=did*gx
6379         if(totliq.gt.ref) then
6380           tranf(1)=did
6381         else if(totliq.le.wilt) then
6382           tranf(1)=0.
6383         else
6384           tranf(1)=(totliq-wilt)/(ref-wilt)*did
6385         endif
6386 !-- uncomment next line for non-linear root distribution
6387 !          tranf(1)=part(1)
6388
6389         do k=2,nroot
6390         totliq=soiliqw(k)+qmin
6391            sm1=totliq
6392            sm2=sm1*sm1
6393            sm3=sm2*sm1
6394            sm4=sm3*sm1
6395            gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4
6396           if(totliq.ge.ref) gx=1.
6397           if(totliq.le.0.) gx=0.
6398           if(gx.gt.1.) gx=1.
6399           if(gx.lt.0.) gx=0.
6400           did=zshalf(k+1)-zshalf(k)
6401           part(k)=did*gx
6402         if(totliq.ge.ref) then
6403           tranf(k)=did
6404         else if(totliq.le.wilt) then
6405           tranf(k)=0.
6406         else
6407           tranf(k)=(totliq-wilt)                                &
6408                 /(ref-wilt)*did
6409         endif
6410 !-- uncomment next line for non-linear root distribution
6411 !          tranf(k)=part(k)
6412         end do
6413
6414 ! for lai> 3 =>  transpiration at potential rate (f.tardieu, 2013)
6415       if(lai > 4.) then
6416         pctot=0.8
6417       else
6418         pctot=pc
6419 !- 26aug16-  next 2 lines could lead to lh increase and higher 2-m q during the day
6420 !        pctot=min(0.8,pc*lai)
6421 !        pctot=min(0.8,max(pc,pc*lai))
6422       endif
6423     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6424      print *,'i,j,pctot,lai,pc',i,j,pctot,lai,pc
6425     endif
6426 !---
6427 !--- air temperature function
6428 !     Avissar (1985) and Ax 7/95
6429         if (tabs .le. 302.15) then
6430           ftem = 1.0 / (1.0 + exp(-0.41 * (tabs - 282.05)))
6431         else
6432           ftem = 1.0 / (1.0 + exp(0.5 * (tabs - 314.0)))
6433         endif
6434     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6435      print *,'i,j,tabs,ftem',i,j,tabs,ftem
6436     endif
6437 !--- incoming solar function
6438      cmin = 1./rsmax_data
6439      cmax = 1./rstbl(iland)
6440     if(lai > 1.) then
6441      cmax = lai/rstbl(iland) ! max conductance
6442     endif
6443 ! noihlan & planton (1988)
6444        f1=0.
6445 !    if(lai > 0.01) then
6446 !       f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when gswin=0.
6447 !       fsol = (f1+cmin/cmax)/(1.+f1)
6448 !       fsol=min(1.,fsol)
6449 !    else
6450 !       fsol=cmin/cmax
6451 !    endif
6452 !     totcnd = max(lai/rstbl(iland), pctot * ftem * f1)
6453 ! Mahrer & Avissar (1982), Avissar et al. (1985)
6454      if (gswin < rgltbl(iland)) then
6455       fsol = 1. / (1. + exp(-0.034 * (gswin - 3.5)))
6456      else
6457       fsol = 1.
6458      endif
6459     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6460      print *,'i,j,gswin,lai,f1,fsol',i,j,gswin,lai,f1,fsol
6461     endif
6462 !--- total conductance
6463      totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax
6464
6465     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6466      print *,'i,j,iland,rgltbl(iland),rstbl(iland),rsmax_data,totcnd'  &
6467              ,i,j,iland,rgltbl(iland),rstbl(iland),rsmax_data,totcnd
6468     endif
6469
6470 !-- transum - total for the rooting zone
6471           transum=0.
6472         do k=1,nroot
6473 ! linear root distribution
6474          tranf(k)=max(cmin,tranf(k)*totcnd)
6475          transum=transum+tranf(k)
6476         end do
6477     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6478       print *,'i,j,transum,tranf',i,j,transum,tranf
6479     endif
6480
6481 !-----------------------------------------------------------------
6482    end subroutine transf
6483 !-----------------------------------------------------------------
6484
6485
6486        subroutine vilka(tn,d1,d2,pp,qs,ts,tt,nstep,ii,j,iland,isoil)
6487 !--------------------------------------------------------------
6488 !--- vilka finds the solution of energy budget at the surface
6489 !--- using table t,qs computed from clausius-klapeiron
6490 !--------------------------------------------------------------
6491    real,     dimension(1:5001),  intent(in   )   ::  tt
6492    real,     intent(in  )   ::  tn,d1,d2,pp
6493    integer,  intent(in  )   ::  nstep,ii,j,iland,isoil
6494
6495    real,     intent(out  )  ::  qs, ts
6496
6497    real    ::  f1,t1,t2,rn
6498    integer ::  i,i1
6499
6500        i=(tn-1.7315e2)/.05+1
6501        t1=173.1+float(i)*.05
6502        f1=t1+d1*tt(i)-d2
6503        i1=i-f1/(.05+d1*(tt(i+1)-tt(i)))
6504        i=i1
6505        if(i.gt.5000.or.i.lt.1) goto 1
6506   10   i1=i
6507        t1=173.1+float(i)*.05
6508        f1=t1+d1*tt(i)-d2
6509        rn=f1/(.05+d1*(tt(i+1)-tt(i)))
6510        i=i-int(rn)
6511        if(i.gt.5000.or.i.lt.1) goto 1
6512        if(i1.ne.i) goto 10
6513        ts=t1-.05*rn
6514        qs=(tt(i)+(tt(i)-tt(i+1))*rn)/pp
6515        goto 20
6516 !   1   print *,'crash in surface energy budget - stop'
6517    1   print *,'     avost in vilka     table index= ',i
6518 !       print *,tn,d1,d2,pp,nstep,i,tt(i),ii,j,iland,isoil
6519        print *,'i,j=',ii,j,'lu_index = ',iland, 'psfc[hpa] = ',pp, 'tsfc = ',tn
6520        call wrf_error_fatal ('  crash in surface energy budget  ' )
6521    20  continue
6522 !-----------------------------------------------------------------------
6523    end subroutine vilka
6524 !-----------------------------------------------------------------------
6525
6526      subroutine soilvegin  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
6527                      shdmin, shdmax,                                 &
6528                      nlcat,ivgtyp,isltyp,iswater,myj,                &
6529                      iforest,lufrac,vegfrac,emiss,pc,znt,lai,rdlai2d,&
6530                      qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j)
6531
6532 !************************************************************************
6533 !  set-up soil and vegetation parameters in the case when
6534 !  snow disappears during the forecast and snow parameters
6535 !  shold be replaced by surface parameters according to
6536 !  soil and vegetation types in this point.
6537 !
6538 !        output:
6539 !
6540 !
6541 !             soil parameters:
6542 !               dqm: max soil moisture content - min (m^3/m^3)
6543 !               ref:        reference soil moisture (m^3/m^3)
6544 !               wilt: wilting pt soil moisture contents (m^3/m^3)
6545 !               qmin: air dry soil moist content limits (m^3/m^3)
6546 !               psis: sat soil potential coefs. (m)
6547 !               ksat:  sat soil diffusivity/conductivity coefs. (m/s)
6548 !               bclh: soil diffusivity/conductivity exponent.
6549 !
6550 ! ************************************************************************
6551    implicit none
6552 !---------------------------------------------------------------------------
6553       integer,   parameter      ::      nsoilclas=19
6554       integer,   parameter      ::      nvegclas=24+3
6555       integer,   parameter      ::      ilsnow=99
6556
6557    integer,    intent(in   )    ::      nlcat, nscat, iswater, i, j
6558
6559 !---    soiltyp classification according to statsgo(nclasses=16)
6560 !
6561 !             1          sand                  sand
6562 !             2          loamy sand            loamy sand
6563 !             3          sandy loam            sandy loam
6564 !             4          silt loam             silty loam
6565 !             5          silt                  silty loam
6566 !             6          loam                  loam
6567 !             7          sandy clay loam       sandy clay loam
6568 !             8          silty clay loam       silty clay loam
6569 !             9          clay loam             clay loam
6570 !            10          sandy clay            sandy clay
6571 !            11          silty clay            silty clay
6572 !            12          clay                  light clay
6573 !            13          organic materials     loam
6574 !            14          water
6575 !            15          bedrock
6576 !                        bedrock is reclassified as class 14
6577 !            16          other (land-ice)
6578 !            17          playa
6579 !            18          lava
6580 !            19          white sand
6581 !
6582 !----------------------------------------------------------------------
6583          real  lqma(nsoilclas),lrhc(nsoilclas),                       &
6584                lpsi(nsoilclas),lqmi(nsoilclas),                       &
6585                lbcl(nsoilclas),lkas(nsoilclas),                       &
6586                lwil(nsoilclas),lref(nsoilclas),                       &
6587                datqtz(nsoilclas)
6588 !-- lqma rawls et al.[1982]
6589 !        data lqma /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398,
6590 !     &  0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/
6591 !---
6592 !-- clapp, r. and g. hornberger, 1978: empirical equations for some soil
6593 !   hydraulic properties, water resour. res., 14, 601-604.
6594
6595 !-- clapp et al. [1978]
6596      data lqma /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420,      &
6597                 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0,        &
6598                 0.20,  0.435, 0.468, 0.200, 0.339/
6599
6600 !-- lref rawls et al.[1982]
6601 !        data lref /0.091, 0.125, 0.207, 0.330, 0.360, 0.270, 0.255,
6602 !     &  0.366, 0.318, 0.339, 0.387, 0.396, 0.329, 1.0, 0.108, 0.283/
6603
6604 !-- clapp et al. [1978]
6605         data lref /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299,   &
6606                    0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1.,      &
6607                    0.1,   0.249, 0.454, 0.17,  0.236/
6608
6609 !-- lwil rawls et al.[1982]
6610 !        data lwil/0.033, 0.055, 0.095, 0.133, 0.133, 0.117, 0.148,
6611 !     &  0.208, 0.197, 0.239, 0.250, 0.272, 0.066, 0.0, 0.006, 0.029/
6612
6613 !-- clapp et al. [1978]
6614         data lwil/0.068, 0.075, 0.114, 0.179, 0.179, 0.155, 0.175,    &
6615                   0.218, 0.250, 0.219, 0.283, 0.286, 0.155, 0.0,      &
6616                   0.006, 0.114, 0.030, 0.006, 0.01/
6617
6618 !        data lqmi/0.010, 0.028, 0.047, 0.084, 0.084, 0.066, 0.067,
6619 !     &  0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.0, 0.006, 0.028/
6620
6621 !-- carsel and parrish [1988]
6622         data lqmi/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10,     &
6623                   0.089, 0.095, 0.10,  0.070, 0.068, 0.078, 0.0,      &
6624                   0.004, 0.065, 0.020, 0.004, 0.008/
6625
6626 !-- lpsi cosby et al[1984]
6627 !        data lpsi/0.060, 0.036, 0.141, 0.759, 0.759, 0.355, 0.135,
6628 !     &  0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/
6629 !     &  0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/
6630
6631 !-- clapp et al. [1978]
6632        data lpsi/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299,     &
6633                  0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0,       &
6634                  0.121, 0.218, 0.468, 0.069, 0.069/
6635
6636 !-- lkas rawls et al.[1982]
6637 !        data lkas/5.83e-5, 1.70e-5, 7.19e-6, 1.89e-6, 1.89e-6,
6638 !     &  3.67e-6, 1.19e-6, 4.17e-7, 6.39e-7, 3.33e-7, 2.50e-7,
6639 !     &  1.67e-7, 3.38e-6, 0.0, 1.41e-4, 1.41e-5/
6640
6641 !-- clapp et al. [1978]
6642         data lkas/1.76e-4, 1.56e-4, 3.47e-5, 7.20e-6, 7.20e-6,         &
6643                   6.95e-6, 6.30e-6, 1.70e-6, 2.45e-6, 2.17e-6,         &
6644                   1.03e-6, 1.28e-6, 6.95e-6, 0.0,     1.41e-4,         &
6645                   3.47e-5, 1.28e-6, 1.41e-4, 1.76e-4/
6646
6647 !-- lbcl cosby et al [1984]
6648 !        data lbcl/2.79,  4.26,  4.74,  5.33,  5.33,  5.25,  6.66,
6649 !     &  8.72,  8.17,  10.73, 10.39, 11.55, 5.25,  0.0, 2.79,  4.26/
6650
6651 !-- clapp et al. [1978]
6652         data lbcl/4.05,  4.38,  4.90,  5.30,  5.30,  5.39,  7.12,      &
6653                   7.75,  8.52, 10.40, 10.40, 11.40,  5.39,  0.0,       &
6654                   4.05,  4.90, 11.55,  2.79,  2.79/
6655
6656         data lrhc /1.47,1.41,1.34,1.27,1.27,1.21,1.18,1.32,1.23,       &
6657                    1.18,1.15,1.09,1.21,4.18,2.03,2.10,1.09,2.03,1.47/
6658
6659         data datqtz/0.92,0.82,0.60,0.25,0.10,0.40,0.60,0.10,0.35,      &
6660                     0.52,0.10,0.25,0.00,0.,0.60,0.0,0.25,0.60,0.92/
6661
6662 !--------------------------------------------------------------------------
6663 !
6664 !     usgs vegetation types
6665 !
6666 !    1:   urban and built-up land
6667 !    2:   dryland cropland and pasture
6668 !    3:   irrigated cropland and pasture
6669 !    4:   mixed dryland/irrigated cropland and pasture
6670 !    5:   cropland/grassland mosaic
6671 !    6:   cropland/woodland mosaic
6672 !    7:   grassland
6673 !    8:   shrubland
6674 !    9:   mixed shrubland/grassland
6675 !   10:   savanna
6676 !   11:   deciduous broadleaf forest
6677 !   12:   deciduous needleleaf forest
6678 !   13:   evergreen broadleaf forest
6679 !   14:   evergreen needleleaf fores
6680 !   15:   mixed forest
6681 !   16:   water bodies
6682 !   17:   herbaceous wetland
6683 !   18:   wooded wetland
6684 !   19:   barren or sparsely vegetated
6685 !   20:   herbaceous tundra
6686 !   21:   wooded tundra
6687 !   22:   mixed tundra
6688 !   23:   bare ground tundra
6689 !   24:   snow or ice
6690 !
6691 !   25:   playa
6692 !   26:   lava
6693 !   27:   white sand
6694
6695 ! modis vegetation categories from VEGPARM.TBL
6696 !    1:   evergreen needleleaf forest
6697 !    2:   evergreen broadleaf forest
6698 !    3:   deciduous needleleaf forest
6699 !    4:   deciduous broadleaf forest
6700 !    5:   mixed forests
6701 !    6:   closed shrublands
6702 !    7:   open shrublands
6703 !    8:   woody savannas
6704 !    9:   savannas
6705 !   10:   grasslands
6706 !   11:   permanent wetlands
6707 !   12:   croplands
6708 !   13:   urban and built-up
6709 !   14:   cropland/natural vegetation mosaic
6710 !   15:   snow and ice
6711 !   16:   barren or sparsely vegetated
6712 !   17:   water
6713 !   18:   wooded tundra
6714 !   19:   mixed tundra
6715 !   20:   barren tundra
6716 !   21:   lakes
6717
6718
6719 !----  below are the arrays for the vegetation parameters
6720          real lalb(nvegclas),lmoi(nvegclas),lemi(nvegclas),            &
6721               lrou(nvegclas),lthi(nvegclas),lsig(nvegclas),            &
6722               lpc(nvegclas)
6723
6724 !************************************************************************
6725 !----     vegetation parameters
6726 !
6727 !-- usgs model
6728 !
6729         data  lalb/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14,     &
6730                    .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55,     &
6731                    .30,.16,.60 /
6732         data lemi/.88,4*.92,.93,.92,.88,.9,.92,.93,.94,                 &
6733                   .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95,      &
6734                   .85,.85,.90 /
6735 !-- roughness length is changed for forests and some others
6736 !        data lrou/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85,       &
6737 !                  2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/
6738          data lrou/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5,       &
6739                    .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05,         &
6740                    .01,.15,.01 /
6741
6742         data lmoi/.1,.3,.5,.25,.25,.35,.15,.1,.15,.15,.3,.3,            &
6743                   .5,.3,.3,1.,.6,.35,.02,.5,.5,.5,.02,.95,.40,.50,.40/
6744 !
6745 !---- still needs to be corrected
6746 !
6747 !       data lpc/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/
6748        data lpc /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55,                   &
6749                  0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./
6750
6751 ! used in ruc       data lpc /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8,                   &
6752 !                 0.5,0.7,0.6,0.7,0.5,0./
6753
6754
6755 !***************************************************************************
6756
6757
6758    integer      ::                &
6759                                                          ivgtyp, &
6760                                                          isltyp
6761    integer,    intent(in   )    ::     mosaic_lu, mosaic_soil
6762
6763    logical,    intent(in   )    ::     myj
6764    real,       intent(in )      ::   shdmax
6765    real,       intent(in )      ::   shdmin
6766    real,       intent(in )      ::   vegfrac
6767    real,     dimension( 1:nlcat ),  intent(in)::         lufrac
6768    real,     dimension( 1:nscat ),  intent(in)::         soilfrac
6769
6770    real                                                        , &
6771             intent (  out)            ::                     pc
6772
6773    real                                                        , &
6774             intent (inout   )         ::                  emiss, &
6775                                                             lai, &
6776                                                             znt
6777   logical, intent(in) :: rdlai2d
6778 !--- soil properties
6779    real                                                        , &
6780             intent(  out)    ::                           rhocs, &
6781                                                            bclh, &
6782                                                             dqm, &
6783                                                            ksat, &
6784                                                            psis, &
6785                                                            qmin, &
6786                                                           qwrtz, &
6787                                                             ref, &
6788                                                            wilt
6789    integer, intent (  out)   ::                         iforest
6790
6791 !   integer, dimension( 1:(lucats) )                          , &
6792 !            intent (  out)            ::                iforest
6793
6794
6795 !   integer, dimension( 1:50 )   ::   if1
6796    integer   ::   kstart, kfin, lstart, lfin
6797    integer   ::   k
6798    real      ::   area,  factor, znt1, lb
6799    real,     dimension( 1:nlcat ) :: znttoday, laitoday, deltalai
6800
6801 !***********************************************************************
6802 !        data zs1/0.0,0.05,0.20,0.40,1.6,3.0/   ! o -  levels in soil
6803 !        data zs2/0.0,0.025,0.125,0.30,1.,2.3/   ! x - levels in soil
6804
6805 !        data if1/12*0,1,1,1,12*0/
6806
6807 !          do k=1,lucats
6808 !             iforest(k)=if1(k)
6809 !          enddo
6810
6811         iforest = ifortbl(ivgtyp)
6812
6813     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6814       if(i.eq.375.and.j.eq.254)then
6815         print *,'ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)', &
6816             ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)
6817       endif
6818     endif
6819
6820         deltalai(:) = 0.
6821
6822 ! 11oct2012 - seasonal correction on znt for crops and lai for all veg. types
6823 ! factor = 1 with minimum greenness -->  vegfrac = shdmin (cold season)
6824 ! factor = 0 with maximum greenness -->  vegfrac = shdmax
6825 ! shdmax, shdmin and vegfrac are in % here.
6826       if((shdmax - shdmin) .lt. 1) then
6827         factor = 1. ! min greenness
6828       else
6829         factor = 1. - max(0.,min(1.,(vegfrac - shdmin)/max(1.,(shdmax-shdmin))))
6830       endif
6831
6832 ! 18sept18 - laitbl and z0tbl are the max values
6833       do k = 1,nlcat
6834        if(ifortbl(k) == 1) deltalai(k)=min(0.2,0.8*laitbl(k))
6835        if(ifortbl(k) == 2 .or. ifortbl(k) == 7) deltalai(k)=min(0.5,0.8*laitbl(k))
6836        if(ifortbl(k) == 3) deltalai(k)=min(0.45,0.8*laitbl(k))
6837        if(ifortbl(k) == 4) deltalai(k)=min(0.75,0.8*laitbl(k))
6838        if(ifortbl(k) == 5) deltalai(k)=min(0.86,0.8*laitbl(k))
6839
6840        if(k.ne.iswater) then
6841 !-- 20aug18 - change in laitoday based on the greenness fraction for the current day
6842         laitoday(k) = laitbl(k) - deltalai(k) * factor
6843
6844          if(ifortbl(k) == 7) then
6845 !-- seasonal change of roughness length for crops
6846            znttoday(k) = z0tbl(k) - 0.125 * factor
6847          else
6848            znttoday(k) = z0tbl(k)
6849          endif
6850        else
6851         laitoday(k) = laitbl(k)
6852         znttoday(k) = znt ! do not overwrite z0 over water with the table value
6853        endif
6854       enddo
6855
6856     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6857       if(i.eq.358.and.j.eq.260)then
6858         print *,'ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp)', &
6859          i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp)
6860       endif
6861     endif
6862
6863         emiss = 0.
6864         znt   = 0.
6865         znt1  = 0.
6866         pc    = 0.
6867         if(.not.rdlai2d) lai = 0.
6868         area  = 0.
6869 !-- mosaic approach to landuse in the grid box
6870 ! use  mason (1988) eq.(15) to compute effective znt;
6871 !  lb - blending height =  l/200., where l is the length scale of regions with varying z0 (lb = 5 if l=1000 m)
6872         lb = 5.
6873       if(mosaic_lu == 1) then
6874       do k = 1,nlcat
6875         area  = area + lufrac(k)
6876         emiss = emiss+ lemitbl(k)*lufrac(k)
6877         znt   = znt  + lufrac(k)/alog(lb/znttoday(k))**2.
6878 ! znt1 - weighted average in the grid box, not used, computed for comparison
6879         znt1  = znt1 + lufrac(k)*znttoday(k)
6880         if(.not.rdlai2d) lai = lai  + laitoday(k)*lufrac(k)
6881         pc    = pc   + pctbl(k)*lufrac(k)
6882       enddo
6883
6884        if (area.gt.1.) area=1.
6885        if (area <= 0.) then
6886           print *,'bad area of grid box', area
6887           stop
6888        endif
6889
6890     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6891       if(i.eq.358.and.j.eq.260) then
6892         print *,'area=',area,i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),emiss,znt,znt1,lai,pc
6893       endif
6894     endif
6895
6896         emiss = emiss/area
6897         znt1   = znt1/area
6898         znt = lb/exp(sqrt(1./znt))
6899         if(.not.rdlai2d) lai = lai/area
6900         pc    = pc /area
6901
6902     if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then
6903       if(i.eq.358.and.j.eq.260) then
6904         print *,'mosaic=',i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),emiss,znt,znt1,lai,pc
6905       endif
6906     endif
6907
6908
6909       else
6910         emiss = lemitbl(ivgtyp)
6911         znt   = znttoday(ivgtyp)
6912         pc    = pctbl(ivgtyp)
6913         if(.not.rdlai2d) lai = laitoday(ivgtyp)
6914      endif
6915
6916 ! parameters from soilparm.tbl
6917           rhocs  = 0.
6918           bclh   = 0.
6919           dqm    = 0.
6920           ksat   = 0.
6921           psis   = 0.
6922           qmin   = 0.
6923           ref    = 0.
6924           wilt   = 0.
6925           qwrtz  = 0.
6926           area   = 0.
6927 ! mosaic approach
6928        if(mosaic_soil == 1 ) then
6929             do k = 1, nscat
6930         if(k.ne.14) then  ! statsgo value for water
6931 !exclude watrer points from this loop
6932           area   = area + soilfrac(k)
6933           rhocs  = rhocs + hc(k)*1.e6*soilfrac(k)
6934           bclh   = bclh + bb(k)*soilfrac(k)
6935           dqm    = dqm + (maxsmc(k)-                               &
6936                    drysmc(k))*soilfrac(k)
6937           ksat   = ksat + satdk(k)*soilfrac(k)
6938           psis   = psis - satpsi(k)*soilfrac(k)
6939           qmin   = qmin + drysmc(k)*soilfrac(k)
6940           ref    = ref + refsmc(k)*soilfrac(k)
6941           wilt   = wilt + wltsmc(k)*soilfrac(k)
6942           qwrtz  = qwrtz + qtz(k)*soilfrac(k)
6943         endif
6944             enddo
6945        if (area.gt.1.) area=1.
6946        if (area <= 0.) then
6947 ! area = 0. for water points
6948 !          print *,'area of a grid box', area, 'iswater = ',iswater
6949           rhocs  = hc(isltyp)*1.e6
6950           bclh   = bb(isltyp)
6951           dqm    = maxsmc(isltyp)-                               &
6952                    drysmc(isltyp)
6953           ksat   = satdk(isltyp)
6954           psis   = - satpsi(isltyp)
6955           qmin   = drysmc(isltyp)
6956           ref    = refsmc(isltyp)
6957           wilt   = wltsmc(isltyp)
6958           qwrtz  = qtz(isltyp)
6959        else
6960           rhocs  = rhocs/area
6961           bclh   = bclh/area
6962           dqm    = dqm/area
6963           ksat   = ksat/area
6964           psis   = psis/area
6965           qmin   = qmin/area
6966           ref    = ref/area
6967           wilt   = wilt/area
6968           qwrtz  = qwrtz/area
6969        endif
6970
6971 ! dominant category approach
6972         else
6973       if(isltyp.ne.14) then
6974           rhocs  = hc(isltyp)*1.e6
6975           bclh   = bb(isltyp)
6976           dqm    = maxsmc(isltyp)-                               &
6977                    drysmc(isltyp)
6978           ksat   = satdk(isltyp)
6979           psis   = - satpsi(isltyp)
6980           qmin   = drysmc(isltyp)
6981           ref    = refsmc(isltyp)
6982           wilt   = wltsmc(isltyp)
6983           qwrtz  = qtz(isltyp)
6984         endif
6985         endif
6986
6987 !--------------------------------------------------------------------------
6988    end subroutine soilvegin
6989 !--------------------------------------------------------------------------
6990
6991   subroutine ruclsminit( sh2o,smfr3d,tslb,smois,isltyp,ivgtyp,     &
6992                      mminlu, xice,mavail,nzs, iswater, isice,      &
6993                      znt, restart, allowed_to_read ,               &
6994                      ids,ide, jds,jde, kds,kde,                    &
6995                      ims,ime, jms,jme, kms,kme,                    &
6996                      its,ite, jts,jte, kts,kte                     )
6997 #if ( wrf_chem == 1 )
6998   use module_data_gocart_dust
6999 #endif
7000    implicit none
7001
7002
7003    integer,  intent(in   )   ::     ids,ide, jds,jde, kds,kde,  &
7004                                     ims,ime, jms,jme, kms,kme,  &
7005                                     its,ite, jts,jte, kts,kte,  &
7006                                     nzs, iswater, isice
7007    character(len=*), intent(in   )    ::                 mminlu
7008
7009    real, dimension( ims:ime, 1:nzs, jms:jme )                    , &
7010             intent(in)    ::                                 tslb, &
7011                                                             smois
7012
7013    integer, dimension( ims:ime, jms:jme )                        , &
7014             intent(inout)    ::                     isltyp,ivgtyp
7015
7016    real, dimension( ims:ime, 1:nzs, jms:jme )                    , &
7017             intent(inout)    ::                            smfr3d, &
7018                                                              sh2o
7019
7020    real, dimension( ims:ime, jms:jme )                           , &
7021             intent(inout)    ::                       xice,mavail
7022
7023    real, dimension( ims:ime, jms:jme )                           , &
7024             intent(  out)    ::                               znt
7025
7026    real, dimension ( 1:nzs )  ::                           soiliqw
7027
7028    logical , intent(in) :: restart, allowed_to_read
7029
7030 !
7031   integer ::  i,j,l,itf,jtf
7032   real    ::  riw,xlmelt,tln,dqm,ref,psis,qmin,bclh
7033
7034   character*8 :: mminluruc, mminsl
7035
7036    integer                   :: errflag
7037
7038         riw=900.*1.e-3
7039         xlmelt=3.35e+5
7040
7041 ! initialize three  lsm related tables
7042    if ( allowed_to_read ) then
7043      call wrf_message( 'initialize three lsm related tables' )
7044       if(mminlu == 'USGS') then
7045         mminluruc='USGS-RUC'
7046       elseif(mminlu == 'MODIS' .or. &
7047         &    mminlu == 'MODIFIED_IGBP_MODIS_NOAH') then
7048         mminluruc='MODI-RUC'
7049       endif
7050         mminsl='STAS-RUC'
7051     print *,'ruclsminit uses ',mminluruc
7052      call ruclsm_soilvegparm( mminluruc, mminsl)
7053    endif
7054
7055 !#if ( wrf_chem == 1 )
7056 !
7057 ! need this parameter for dust parameterization in wrf/chem
7058 !
7059 !   do i=1,nsltype
7060 !      porosity(i)=maxsmc(i)
7061 !      drypoint(i)=drysmc(i)
7062 !   enddo
7063 !#endif
7064 !
7065  if(.not.restart)then
7066
7067    itf=min0(ite,ide-1)
7068    jtf=min0(jte,jde-1)
7069
7070    errflag = 0
7071    do j = jts,jtf
7072      do i = its,itf
7073        if ( isltyp( i,j ) .lt. 1 ) then
7074          errflag = 1
7075          write(err_message,*)"module_sf_ruclsm.f: lsminit: out of range isltyp ",i,j,isltyp( i,j )
7076          call wrf_message(err_message)
7077        endif
7078      enddo
7079    enddo
7080    if ( errflag .eq. 1 ) then
7081       call wrf_error_fatal( "module_sf_ruclsm.f: lsminit: out of range value "// &
7082                             "of isltyp. is this field in the input?" )
7083    endif
7084
7085    do j=jts,jtf
7086        do i=its,itf
7087
7088         znt(i,j)   = z0tbl(ivgtyp(i,j))
7089
7090 !--- computation of volumetric content of ice in soil
7091 !--- and initialize mavail
7092           dqm    = maxsmc   (isltyp(i,j)) -                               &
7093                    drysmc   (isltyp(i,j))
7094           ref    = refsmc   (isltyp(i,j))
7095           psis   = - satpsi (isltyp(i,j))
7096           qmin   = drysmc   (isltyp(i,j))
7097           bclh   = bb       (isltyp(i,j))
7098
7099
7100     if(xice(i,j).gt.0.) then
7101 !-- for ice
7102          do l=1,nzs
7103            smfr3d(i,l,j)=1.
7104            sh2o(i,l,j)=0.
7105            mavail(i,j) = 1.
7106          enddo
7107     else
7108        if(isltyp(i,j).ne.14 ) then
7109 !-- land
7110            mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin)))
7111          do l=1,nzs
7112 !-- for land points initialize soil ice
7113          tln=log(tslb(i,l,j)/273.15)
7114
7115           if(tln.lt.0.) then
7116            soiliqw(l)=(dqm+qmin)*(xlmelt*                        &
7117          (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis)             &
7118           **(-1./bclh)
7119            soiliqw(l)=max(0.,soiliqw(l))
7120            soiliqw(l)=min(soiliqw(l),smois(i,l,j))
7121            sh2o(i,l,j)=soiliqw(l)
7122            smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/riw
7123
7124           else
7125            smfr3d(i,l,j)=0.
7126            sh2o(i,l,j)=smois(i,l,j)
7127           endif
7128          enddo
7129
7130        else
7131 !-- for water  isltyp=14
7132          do l=1,nzs
7133            smfr3d(i,l,j)=0.
7134            sh2o(i,l,j)=1.
7135            mavail(i,j) = 1.
7136          enddo
7137        endif
7138     endif
7139
7140     enddo
7141    enddo
7142
7143  endif
7144
7145 !-----------------------------------------------------------------
7146   end subroutine ruclsminit
7147 !-----------------------------------------------------------------
7148 !
7149         subroutine ruclsm_soilvegparm( mminluruc, mminsl)
7150 !-----------------------------------------------------------------
7151
7152         implicit none
7153
7154         integer :: LUMATCH, IINDEX, LC, NUM_SLOPE
7155         integer :: ierr
7156         INTEGER , PARAMETER :: OPEN_OK = 0
7157
7158         character*8 :: MMINLURUC, MMINSL
7159         character*128 :: mess , message, vege_parm_string
7160         logical, external :: wrf_dm_on_monitor
7161
7162
7163 !-----specify vegetation related characteristics :
7164 !             albbck: sfc albedo (in percentage)
7165 !                 z0: roughness length (m)
7166 !               lemi: emissivity
7167 !                 pc: plant coefficient for transpiration function
7168 ! -- the rest of the parameters are read in but not used currently
7169 !             shdfac: green vegetation fraction (in percentage)
7170 !  note: the albedo, z0, and shdfac values read from the following table
7171 !          albedo, amd z0 are specified in land-use table; and shdfac is
7172 !          the monthly green vegetation data
7173 !             cmxtbl: max cnpy capacity (m)
7174 !              rsmin: mimimum stomatal resistance (s m-1)
7175 !              rsmax: max. stomatal resistance (s m-1)
7176 !                rgl: parameters used in radiation stress function
7177 !                 hs: parameter used in vapor pressure deficit functio
7178 !               topt: optimum transpiration air temperature. (k)
7179 !             cmcmax: maximum canopy water capacity
7180 !             cfactr: parameter used in the canopy inteception calculati
7181 !               snup: threshold snow depth (in water equivalent m) that
7182 !                     implies 100% snow cover
7183 !                lai: leaf area index (dimensionless)
7184 !             maxalb: upper bound on maximum albedo over deep snow
7185 !
7186 !-----read in vegetaion properties from VEGPARM.TBL
7187 !
7188
7189        IF ( wrf_dm_on_monitor() ) THEN
7190
7191         OPEN(19, FILE='VEGPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
7192         IF(ierr .NE. OPEN_OK ) THEN
7193           WRITE(message,FMT='(A)') &
7194           'module_sf_ruclsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL'
7195           CALL wrf_error_fatal ( message )
7196         END IF
7197
7198         WRITE ( mess, * ) 'INPUT VEGPARM FOR ',MMINLURUC
7199         CALL wrf_message( mess )
7200
7201         LUMATCH=0
7202
7203  2000   FORMAT (A8)
7204         READ (19,'(A)') vege_parm_string
7205         outer : DO
7206            READ (19,2000,END=2002)LUTYPE
7207            READ (19,*)LUCATS,IINDEX
7208
7209            WRITE( mess , * ) 'VEGPARM FOR ',LUTYPE,' FOUND', LUCATS,' CATEGORIES'
7210            CALL wrf_message( mess )
7211
7212            IF(LUTYPE.NE.MMINLURUC)THEN    ! Skip over the undesired table
7213               write ( mess , * ) 'Skipping ', LUTYPE, ' table'
7214               CALL wrf_message( mess )
7215               DO LC=1,LUCATS
7216                  READ (19,*)
7217               ENDDO
7218               inner : DO               ! Find the next "Vegetation Parameters"
7219                  READ (19,'(A)',END=2002) vege_parm_string
7220                  IF (TRIM(vege_parm_string) .EQ. "Vegetation Parameters") THEN
7221                     EXIT inner
7222                  END IF
7223                ENDDO inner
7224            ELSE
7225               LUMATCH=1
7226               write ( mess , * ) 'Found ', LUTYPE, ' table'
7227               CALL wrf_message( mess )
7228               EXIT outer                ! Found the table, read the data
7229            END IF
7230
7231         ENDDO outer
7232
7233         IF (LUMATCH == 1) then
7234            write ( mess , * ) 'Reading ',LUTYPE,' table'
7235            CALL wrf_message( mess )
7236            DO LC=1,LUCATS
7237               READ (19,*)IINDEX,ALBTBL(LC),Z0TBL(LC),LEMITBL(LC),PCTBL(LC), &
7238                          SHDTBL(LC),IFORTBL(LC),RSTBL(LC),RGLTBL(LC),         &
7239                          HSTBL(LC),SNUPTBL(LC),LAITBL(LC),MAXALB(LC)
7240            ENDDO
7241 !
7242            READ (19,*)
7243            READ (19,*)TOPT_DATA
7244            READ (19,*)
7245            READ (19,*)CMCMAX_DATA
7246            READ (19,*)
7247            READ (19,*)CFACTR_DATA
7248            READ (19,*)
7249            READ (19,*)RSMAX_DATA
7250            READ (19,*)
7251            READ (19,*)BARE
7252            READ (19,*)
7253            READ (19,*)NATURAL
7254            READ (19,*)
7255            READ (19,*)CROP
7256            READ (19,*)
7257            READ (19,*,iostat=ierr)URBAN
7258            if ( ierr /= 0 ) call wrf_message     (  "-------- VEGPARM.TBL READ ERROR --------")
7259            if ( ierr /= 0 ) call wrf_message     (  "Problem read URBAN from VEGPARM.TBL")
7260            if ( ierr /= 0 ) call wrf_message     (  " -- Use updated version of VEGPARM.TBL  ")
7261            if ( ierr /= 0 ) call wrf_error_fatal (  "Problem read URBAN from VEGPARM.TBL")
7262
7263         ENDIF
7264
7265  2002   CONTINUE
7266         CLOSE (19)
7267 !-----
7268     IF ( wrf_at_debug_level(lsmruc_dbg_lvl) ) THEN
7269          print *,' LEMITBL, PCTBL, Z0TBL, LAITBL --->', LEMITBL, PCTBL, Z0TBL, LAITBL
7270     ENDIF
7271
7272         IF (LUMATCH == 0) then
7273            CALL wrf_error_fatal ("Land Use Dataset '"//MMINLURUC//"' not found in VEGPARM.TBL.")
7274         ENDIF
7275
7276       END IF
7277
7278       CALL wrf_dm_bcast_string  ( LUTYPE  , 8 )
7279       CALL wrf_dm_bcast_integer ( LUCATS  , 1 )
7280       CALL wrf_dm_bcast_integer ( IINDEX  , 1 )
7281       CALL wrf_dm_bcast_integer ( LUMATCH , 1 )
7282       CALL wrf_dm_bcast_real    ( ALBTBL  , NLUS )
7283       CALL wrf_dm_bcast_real    ( Z0TBL   , NLUS )
7284       CALL wrf_dm_bcast_real    ( LEMITBL , NLUS )
7285       CALL wrf_dm_bcast_real    ( PCTBL   , NLUS )
7286       CALL wrf_dm_bcast_real    ( SHDTBL  , NLUS )
7287       CALL wrf_dm_bcast_real    ( IFORTBL , NLUS )
7288       CALL wrf_dm_bcast_real    ( RSTBL   , NLUS )
7289       CALL wrf_dm_bcast_real    ( RGLTBL  , NLUS )
7290       CALL wrf_dm_bcast_real    ( HSTBL   , NLUS )
7291       CALL wrf_dm_bcast_real    ( SNUPTBL , NLUS )
7292       CALL wrf_dm_bcast_real    ( LAITBL  , NLUS )
7293       CALL wrf_dm_bcast_real    ( MAXALB  , NLUS )
7294       CALL wrf_dm_bcast_real    ( TOPT_DATA    , 1 )
7295       CALL wrf_dm_bcast_real    ( CMCMAX_DATA  , 1 )
7296       CALL wrf_dm_bcast_real    ( CFACTR_DATA  , 1 )
7297       CALL wrf_dm_bcast_real    ( RSMAX_DATA  , 1 )
7298       CALL wrf_dm_bcast_integer ( BARE        , 1 )
7299       CALL wrf_dm_bcast_integer ( NATURAL     , 1 )
7300       CALL wrf_dm_bcast_integer ( CROP        , 1 )
7301       CALL wrf_dm_bcast_integer ( URBAN       , 1 )
7302
7303 !
7304 !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL
7305 !
7306       IF ( wrf_dm_on_monitor() ) THEN
7307         OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
7308         IF(ierr .NE. OPEN_OK ) THEN
7309           WRITE(message,FMT='(A)') &
7310           'module_sf_ruclsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL'
7311           CALL wrf_error_fatal ( message )
7312         END IF
7313
7314         WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICATION = ',MMINSL
7315         CALL wrf_message( mess )
7316
7317         LUMATCH=0
7318
7319         READ (19,*)
7320         READ (19,2000,END=2003)SLTYPE
7321         READ (19,*)SLCATS,IINDEX
7322         IF(SLTYPE.NE.MMINSL)THEN
7323           DO LC=1,SLCATS
7324               READ (19,*) IINDEX,BB(LC),DRYSMC(LC),HC(LC),MAXSMC(LC),&
7325                         REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC),   &
7326                         WLTSMC(LC), QTZ(LC)
7327           ENDDO
7328         ENDIF
7329         READ (19,*)
7330         READ (19,2000,END=2003)SLTYPE
7331         READ (19,*)SLCATS,IINDEX
7332
7333         IF(SLTYPE.EQ.MMINSL)THEN
7334             WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ',SLTYPE,' FOUND', &
7335                   SLCATS,' CATEGORIES'
7336             CALL wrf_message ( mess )
7337           LUMATCH=1
7338         ENDIF
7339             IF(SLTYPE.EQ.MMINSL)THEN
7340           DO LC=1,SLCATS
7341               READ (19,*) IINDEX,BB(LC),DRYSMC(LC),HC(LC),MAXSMC(LC),&
7342                         REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC),   &
7343                         WLTSMC(LC), QTZ(LC)
7344           ENDDO
7345            ENDIF
7346
7347  2003   CONTINUE
7348
7349         CLOSE (19)
7350       ENDIF
7351
7352       CALL wrf_dm_bcast_integer ( LUMATCH , 1 )
7353       CALL wrf_dm_bcast_string  ( SLTYPE  , 8 )
7354       CALL wrf_dm_bcast_string  ( MMINSL  , 8 )  ! since this is reset above, see oct2 ^
7355       CALL wrf_dm_bcast_integer ( SLCATS  , 1 )
7356       CALL wrf_dm_bcast_integer ( IINDEX  , 1 )
7357       CALL wrf_dm_bcast_real    ( BB      , NSLTYPE )
7358       CALL wrf_dm_bcast_real    ( DRYSMC  , NSLTYPE )
7359       CALL wrf_dm_bcast_real    ( HC      , NSLTYPE )
7360       CALL wrf_dm_bcast_real    ( MAXSMC  , NSLTYPE )
7361       CALL wrf_dm_bcast_real    ( REFSMC  , NSLTYPE )
7362       CALL wrf_dm_bcast_real    ( SATPSI  , NSLTYPE )
7363       CALL wrf_dm_bcast_real    ( SATDK   , NSLTYPE )
7364       CALL wrf_dm_bcast_real    ( SATDW   , NSLTYPE )
7365       CALL wrf_dm_bcast_real    ( WLTSMC  , NSLTYPE )
7366       CALL wrf_dm_bcast_real    ( QTZ     , NSLTYPE )
7367
7368       IF(LUMATCH.EQ.0)THEN
7369           CALL wrf_message( 'SOIl TEXTURE IN INPUT FILE DOES NOT ' )
7370           CALL wrf_message( 'MATCH SOILPARM TABLE'                 )
7371           CALL wrf_error_fatal ( 'INCONSISTENT OR MISSING SOILPARM FILE' )
7372       ENDIF
7373 !
7374 !-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL
7375 !
7376       IF ( wrf_dm_on_monitor() ) THEN
7377         OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
7378         IF(ierr .NE. OPEN_OK ) THEN
7379           WRITE(message,FMT='(A)') &
7380           'module_sf_ruclsm.F: soil_veg_gen_parm: failure opening GENPARM.TBL'
7381           CALL wrf_error_fatal ( message )
7382         END IF
7383
7384         READ (19,*)
7385         READ (19,*)
7386         READ (19,*) NUM_SLOPE
7387
7388           SLPCATS=NUM_SLOPE
7389
7390           DO LC=1,SLPCATS
7391               READ (19,*)SLOPE_DATA(LC)
7392           ENDDO
7393
7394           READ (19,*)
7395           READ (19,*)SBETA_DATA
7396           READ (19,*)
7397           READ (19,*)FXEXP_DATA
7398           READ (19,*)
7399           READ (19,*)CSOIL_DATA
7400           READ (19,*)
7401           READ (19,*)SALP_DATA
7402           READ (19,*)
7403           READ (19,*)REFDK_DATA
7404           READ (19,*)
7405           READ (19,*)REFKDT_DATA
7406           READ (19,*)
7407           READ (19,*)FRZK_DATA
7408           READ (19,*)
7409           READ (19,*)ZBOT_DATA
7410           READ (19,*)
7411           READ (19,*)CZIL_DATA
7412           READ (19,*)
7413           READ (19,*)SMLOW_DATA
7414           READ (19,*)
7415           READ (19,*)SMHIGH_DATA
7416         CLOSE (19)
7417       ENDIF
7418
7419       CALL wrf_dm_bcast_integer ( NUM_SLOPE    ,  1 )
7420       CALL wrf_dm_bcast_integer ( SLPCATS      ,  1 )
7421       CALL wrf_dm_bcast_real    ( SLOPE_DATA   ,  NSLOPE )
7422       CALL wrf_dm_bcast_real    ( SBETA_DATA   ,  1 )
7423       CALL wrf_dm_bcast_real    ( FXEXP_DATA   ,  1 )
7424       CALL wrf_dm_bcast_real    ( CSOIL_DATA   ,  1 )
7425       CALL wrf_dm_bcast_real    ( SALP_DATA    ,  1 )
7426       CALL wrf_dm_bcast_real    ( REFDK_DATA   ,  1 )
7427       CALL wrf_dm_bcast_real    ( REFKDT_DATA  ,  1 )
7428       CALL wrf_dm_bcast_real    ( FRZK_DATA    ,  1 )
7429       CALL wrf_dm_bcast_real    ( ZBOT_DATA    ,  1 )
7430       CALL wrf_dm_bcast_real    ( CZIL_DATA    ,  1 )
7431       CALL wrf_dm_bcast_real    ( SMLOW_DATA   ,  1 )
7432       CALL wrf_dm_bcast_real    ( SMHIGH_DATA  ,  1 )
7433
7434
7435 !-----------------------------------------------------------------
7436       end subroutine ruclsm_soilvegparm
7437 !-----------------------------------------------------------------
7438
7439
7440   subroutine soilin (isltyp, dqm, ref, psis, qmin, bclh )
7441
7442 !---    soiltyp classification according to statsgo(nclasses=16)
7443 !
7444 !             1          sand                  sand
7445 !             2          loamy sand            loamy sand
7446 !             3          sandy loam            sandy loam
7447 !             4          silt loam             silty loam
7448 !             5          silt                  silty loam
7449 !             6          loam                  loam
7450 !             7          sandy clay loam       sandy clay loam
7451 !             8          silty clay loam       silty clay loam
7452 !             9          clay loam             clay loam
7453 !            10          sandy clay            sandy clay
7454 !            11          silty clay            silty clay
7455 !            12          clay                  light clay
7456 !            13          organic materials     loam
7457 !            14          water
7458 !            15          bedrock
7459 !                        bedrock is reclassified as class 14
7460 !            16          other (land-ice)
7461 ! extra classes from fei chen
7462 !            17          playa
7463 !            18          lava
7464 !            19          white sand
7465 !
7466 !----------------------------------------------------------------------
7467          integer,   parameter      ::      nsoilclas=19
7468
7469          integer, intent ( in)  ::                          isltyp
7470          real,    intent ( out) ::               dqm,ref,qmin,psis
7471
7472          real  lqma(nsoilclas),lref(nsoilclas),lbcl(nsoilclas),       &
7473                lpsi(nsoilclas),lqmi(nsoilclas)
7474
7475 !-- lqma rawls et al.[1982]
7476 !        data lqma /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398,
7477 !     &  0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/
7478 !---
7479 !-- clapp, r. and g. hornberger, empirical equations for some soil
7480 !   hydraulic properties, water resour. res., 14,601-604,1978.
7481 !-- clapp et al. [1978]
7482      data lqma /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420,      &
7483                 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0,        &
7484                 0.20,  0.435, 0.468, 0.200, 0.339/
7485
7486 !-- clapp et al. [1978]
7487         data lref /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299,   &
7488                    0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1.,      &
7489                    0.1,   0.249, 0.454, 0.17,  0.236/
7490
7491 !-- carsel and parrish [1988]
7492         data lqmi/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10,     &
7493                   0.089, 0.095, 0.10,  0.070, 0.068, 0.078, 0.0,      &
7494                   0.004, 0.065, 0.020, 0.004, 0.008/
7495
7496 !-- clapp et al. [1978]
7497        data lpsi/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299,     &
7498                  0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0,       &
7499                  0.121, 0.218, 0.468, 0.069, 0.069/
7500
7501 !-- clapp et al. [1978]
7502         data lbcl/4.05,  4.38,  4.90,  5.30,  5.30,  5.39,  7.12,      &
7503                   7.75,  8.52, 10.40, 10.40, 11.40,  5.39,  0.0,       &
7504                   4.05,  4.90, 11.55,  2.79,  2.79/
7505
7506
7507           dqm    = lqma(isltyp)-                               &
7508                    lqmi(isltyp)
7509           ref    = lref(isltyp)
7510           psis   = - lpsi(isltyp)
7511           qmin   = lqmi(isltyp)
7512           bclh   = lbcl(isltyp)
7513
7514   end subroutine soilin
7515
7516 end module module_sf_ruclsm