PageRenderTime 138ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 2ms

/wrfv2_fire/phys/module_sf_noahmplsm.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 8875 lines | 5630 code | 1321 blank | 1924 comment | 120 complexity | 9bdab95b1e3a0cc9ff0a5e1b9fd0b8d3 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. module noahmp_globals
    2. 

  2. 

  3.   ! Maybe most of these can be moved to a REDPRM use statement?
    4. 

  4.   use module_sf_noahlsm, only: &
    5. 

  5.        &                       SLCATS,     &
    6. 

  6.        &                       LUCATS,     &
    7. 

  7.        &                       CSOIL_DATA, & 
    8. 

  8.        &                       BB,         &
    9. 

  9.        &                       SATDK,      &
    10. 

  10.        &                       SATDW,      &
    11. 

  11.        &                       F11,        &
    12. 

  12.        &                       SATPSI,     &
    13. 

  13.        &                       QTZ,        &
    14. 

  14.        &                       DRYSMC,     &
    15. 

  15.        &                       MAXSMC,     &
    16. 

  16.        &                       REFSMC,     &
    17. 

  17.        &                       WLTSMC,     &
    18. 

  18.        &                       RSTBL,      &
    19. 

  19.        &                       RGLTBL,     &
    20. 

  20.        &                       HSTBL,      &
    21. 

  21.        &                       NROTBL,     &
    22. 

  22.        &                       TOPT_DATA,  &
    23. 

  23.        &                       RSMAX_DATA, &
    24. 

  24.        &                       ZBOT_DATA,  &
    25. 

  25.        &                       CZIL_DATA,  &
    26. 

  26.        &                       FRZK_DATA,  &
    27. 

  27.        &                       SLOPE_DATA, &
    28. 

  28.        &                       REFDK_DATA, &
    29. 

  29.        &                       REFKDT_DATA
    30. 

  30.        
    31. 

  31.   implicit none
    32. 

  32. 

  33. ! ==================================================================================================
    34. 

  34. !------------------------------------------------------------------------------------------!
    35. 

  35. ! Physical Constants:                                                                      !
    36. 

  36. !------------------------------------------------------------------------------------------!
    37. 

  37. 

  38.   REAL, PARAMETER :: GRAV   = 9.80616   !acceleration due to gravity (m/s2)
    39. 

  39.   REAL, PARAMETER :: SB     = 5.67E-08  !Stefan-Boltzmann constant (w/m2/k4)
    40. 

  40.   REAL, PARAMETER :: VKC    = 0.40      !von Karman constant
    41. 

  41.   REAL, PARAMETER :: TFRZ   = 273.16    !freezing/melting point (k)
    42. 

  42.   REAL, PARAMETER :: HSUB   = 2.8440E06 !latent heat of sublimation (j/kg)
    43. 

  43.   REAL, PARAMETER :: HVAP   = 2.5104E06 !latent heat of vaporization (j/kg)
    44. 

  44.   REAL, PARAMETER :: HFUS   = 0.3336E06 !latent heat of fusion (j/kg)
    45. 

  45.   REAL, PARAMETER :: CWAT   = 4.188E06  !specific heat capacity of water (j/m3/k)
    46. 

  46.   REAL, PARAMETER :: CICE   = 2.094E06  !specific heat capacity of ice (j/m3/k)
    47. 

  47.   REAL, PARAMETER :: CPAIR  = 1004.64   !heat capacity dry air at const pres (j/kg/k)
    48. 

  48.   REAL, PARAMETER :: TKWAT  = 0.6       !thermal conductivity of water (w/m/k)
    49. 

  49.   REAL, PARAMETER :: TKICE  = 2.2       !thermal conductivity of ice (w/m/k)
    50. 

  50.   REAL, PARAMETER :: TKAIR  = 0.023     !thermal conductivity of air (w/m/k)
    51. 

  51.   REAL, PARAMETER :: RAIR   = 287.04    !gas constant for dry air (j/kg/k)
    52. 

  52.   REAL, PARAMETER :: RW     = 461.269   !gas constant for  water vapor (j/kg/k)
    53. 

  53.   REAL, PARAMETER :: DENH2O = 1000.     !density of water (kg/m3)
    54. 

  54.   REAL, PARAMETER :: DENICE = 917.      !density of ice (kg/m3)
    55. 

  55. 

  56. !------------------------------------------------------------------------------------------!
    57. 

  57. ! From the VEGPARM.TBL tables, as functions of vegetation category.
    58. 

  58. !------------------------------------------------------------------------------------------!
    59. 

  59.   INTEGER :: NROOT        !rooting depth [as the number of layers] ( Assigned in REDPRM )
    60. 

  60.   REAL    :: RGL          !parameter used in radiation stress function ( Assigned in REDPRM )
    61. 

  61.   REAL    :: RSMIN        !minimum Canopy Resistance [s/m] ( Assigned in REDPRM )
    62. 

  62.   REAL    :: HS           !parameter used in vapor pressure deficit function ( Assigned in REDPRM )
    63. 

  63.   REAL    :: RSMAX        !maximum stomatal resistance ( Assigned in REDPRM )
    64. 

  64.   REAL    :: TOPT         !optimum transpiration air temperature.
    65. 

  65. 

  66. !KWM  CHARACTER(LEN=256) ::  LUTYPE
    67. 

  67. !KWM  INTEGER                    :: LUCATS, BARE
    68. 

  68. !KWM  INTEGER, PARAMETER         :: NLUS=50
    69. 

  69. !KWM  INTEGER, DIMENSION(1:NLUS) :: NROTBL
    70. 

  70. !KWM  REAL,    DIMENSION(1:NLUS) :: RSTBL, RGLTBL, HSTBL
    71. 

  71. !KWM  REAL                       :: TOPT_DATA,RSMAX_DATA
    72. 

  72. 

  73. ! not further used in this version (niu):
    74. 

  74. 

  75. !KWM  REAL,    DIMENSION(1:NLUS) ::  SNUPTBL, LAITBL,        &
    76. 

  76. !KWM                                 ALBTBL, SHDTBL, MAXALB
    77. 

  77. !KWM  REAL                       ::  CMCMAX_DATA,CFACTR_DATA,SBETA_DATA,&
    78. 

  78. !KWM                                 SALP_DATA  ,SMLOW_DATA ,SMHIGH_DATA
    79. 

  79. 

  80. !KWM  REAL,    DIMENSION(NLUS)   ::  LAIMINTBL    !KWM
    81. 

  81. !KWM  REAL,    DIMENSION(NLUS)   ::  LAIMAXTBL    !KWM
    82. 

  82. !KWM  REAL,    DIMENSION(NLUS)   ::  EMISSMINTBL  !KWM
    83. 

  83. !KWM  REAL,    DIMENSION(NLUS)   ::  EMISSMAXTBL  !KWM
    84. 

  84. !KWM  REAL,    DIMENSION(NLUS)   ::  ALBEDOMINTBL !KWM
    85. 

  85. !KWM  REAL,    DIMENSION(NLUS)   ::  ALBEDOMAXTBL !KWM
    86. 

  86. !KWM  REAL,    DIMENSION(NLUS)   ::  Z0MINTBL     !KWM
    87. 

  87. !KWM  REAL,    DIMENSION(NLUS)   ::  Z0MAXTBL     !KWM
    88. 

  88. 

  89. 

  90. !------------------------------------------------------------------------------------------!
    91. 

  91. ! From the SOILPARM.TBL tables, as functions of soil category.
    92. 

  92. !------------------------------------------------------------------------------------------!
    93. 

  93.   REAL    :: BEXP         !B parameter ( Assigned in REDPRM )
    94. 

  94.   REAL    :: SMCDRY       !dry soil moisture threshold where direct evap from top
    95. 

  95.                           !layer ends (volumetric) ( Assigned in REDPRM )
    96. 

  96.   REAL    :: F1           !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM )
    97. 

  97.   REAL    :: SMCMAX       !porosity, saturated value of soil moisture (volumetric)
    98. 

  98.   REAL    :: SMCREF       !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM )
    99. 

  99.   REAL    :: PSISAT       !saturated soil matric potential ( Assigned in REDPRM )
    100. 

  100.   REAL    :: DKSAT        !saturated soil hydraulic conductivity ( Assigned in REDPRM )
    101. 

  101.   REAL    :: DWSAT        !saturated soil hydraulic diffusivity ( Assigned in REDPRM )
    102. 

  102.   REAL    :: SMCWLT       !wilting point soil moisture (volumetric) ( Assigned in REDPRM )
    103. 

  103.   REAL    :: QUARTZ       !soil quartz content ( Assigned in REDPRM )
    104. 

  104. 

  105. !KWM  CHARACTER*4 SLTYPE
    106. 

  106. !KWM  INTEGER                     :: SLCATS
    107. 

  107. !KWM  INTEGER, PARAMETER          :: NSLTYPE=30
    108. 

  108. !KWM  REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11,                           &
    109. 

  109. !KWM        MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ
    110. 

  110. !------------------------------------------------------------------------------------------!
    111. 

  111. ! From the GENPARM.TBL file
    112. 

  112. !------------------------------------------------------------------------------------------!
    113. 

  113.   REAL    :: SLOPE       !slope index (0 - 1) ( Assigned in REDPRM )
    114. 

  114.   REAL    :: CSOIL       !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM )
    115. 

  115.   REAL    :: ZBOT        !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM )
    116. 

  116.   REAL    :: CZIL        !Calculate roughness length of heat ( Assigned in REDPRM )
    117. 

  117. 

  118.   REAL    :: KDT         !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM )
    119. 

  119.   REAL    :: FRZX        !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM )
    120. 

  120. 

  121. ! LSM GENERAL PARAMETERS
    122. 

  122. 

  123. !KWM  INTEGER :: SLPCATS
    124. 

  124. !KWM  INTEGER, PARAMETER :: NSLOPE=30
    125. 

  125. !KWM  REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA
    126. 

  126. !KWM  REAL ::  FXEXP_DATA,CSOIL_DATA,REFDK_DATA ,         &
    127. 

  127. !KWM           REFKDT_DATA,FRZK_DATA ,ZBOT_DATA ,CZIL_DATA
    128. 

  128. 

  129. ! =====================================options for different schemes================================
    130. 

  130. ! options for dynamic vegetation: 
    131. 

  131. ! 1 -> off (use table LAI; use FVEG = SHDFAC from input)
    132. 

  132. ! 2 -> on (together with OPT_CRS = 1)
    133. 

  133. ! 3 -> off (use table LAI; calculate FVEG)
    134. 

  134. ! 4 -> off (use table LAI; use maximum vegetation fraction)
    135. 

  135. 

  136.   INTEGER :: DVEG    != 2   !
    137. 

  137. 

  138. ! options for canopy stomatal resistance
    139. 

  139. ! 1-> Ball-Berry; 2->Jarvis
    140. 

  140. 

  141.   INTEGER :: OPT_CRS != 1    !(must 1 when DVEG = 2)
    142. 

  142. 

  143. ! options for soil moisture factor for stomatal resistance
    144. 

  144. ! 1-> Noah (soil moisture) 
    145. 

  145. ! 2-> CLM  (matric potential)
    146. 

  146. ! 3-> SSiB (matric potential)
    147. 

  147. 

  148.   INTEGER :: OPT_BTR != 1    !(suggested 1)
    149. 

  149. 

  150. ! options for runoff and groundwater
    151. 

  151. ! 1 -> TOPMODEL with groundwater (Niu et al. 2007 JGR) ;
    152. 

  152. ! 2 -> TOPMODEL with an equilibrium water table (Niu et al. 2005 JGR) ;
    153. 

  153. ! 3 -> original surface and subsurface runoff (free drainage)
    154. 

  154. ! 4 -> BATS surface and subsurface runoff (free drainage)
    155. 

  155. 

  156.   INTEGER :: OPT_RUN != 1    !(suggested 1)
    157. 

  157. 

  158. ! options for surface layer drag coeff (CH & CM)
    159. 

  159. ! 1->M-O ; 2->original Noah (Chen97); 3->MYJ consistent; 4->YSU consistent. 
    160. 

  160. 

  161.   INTEGER :: OPT_SFC != 1    !(1 or 2 or 3 or 4)
    162. 

  162. 

  163. ! options for supercooled liquid water (or ice fraction)
    164. 

  164. ! 1-> no iteration (Niu and Yang, 2006 JHM); 2: Koren's iteration 
    165. 

    166. 

  166.   INTEGER :: OPT_FRZ != 1    !(1 or 2)
    167. 

  167. 

  168. ! options for frozen soil permeability
    169. 

  169. ! 1 -> linear effects, more permeable (Niu and Yang, 2006, JHM)
    170. 

  170. ! 2 -> nonlinear effects, less permeable (old)
    171. 

  171. 

  172.   INTEGER :: OPT_INF != 1    !(suggested 1)
    173. 

  173. 

  174. ! options for radiation transfer
    175. 

  175. ! 1 -> modified two-stream (gap = F(solar angle, 3D structure ...)<1-FVEG)
    176. 

  176. ! 2 -> two-stream applied to grid-cell (gap = 0)
    177. 

  177. ! 3 -> two-stream applied to vegetated fraction (gap=1-FVEG)
    178. 

  178. 

  179.   INTEGER :: OPT_RAD != 1    !(suggested 1)
    180. 

  180. 

  181. ! options for ground snow surface albedo
    182. 

  182. ! 1-> BATS; 2 -> CLASS
    183. 

  183. 

  184.   INTEGER :: OPT_ALB != 2    !(suggested 2)
    185. 

  185. 

  186. ! options for partitioning  precipitation into rainfall & snowfall
    187. 

  187. ! 1 -> Jordan (1991); 2 -> BATS: when SFCTMP<TFRZ+2.2 ; 3-> SFCTMP<TFRZ
    188. 

  188. 

  189.   INTEGER :: OPT_SNF != 1    !(suggested 1)
    190. 

  190. 

  191. ! options for lower boundary condition of soil temperature
    192. 

  192. ! 1 -> zero heat flux from bottom (ZBOT and TBOT not used)
    193. 

  193. ! 2 -> TBOT at ZBOT (8m) read from a file (original Noah)
    194. 

  194. 

  195.   INTEGER :: OPT_TBOT != 2   !(suggested 2)
    196. 

  196. 

  197. ! options for snow/soil temperature time scheme (only layer 1)
    198. 

  198. ! 1 -> semi-implicit; 2 -> full implicit (original Noah)
    199. 

  199. 

  200.   INTEGER :: OPT_STC != 1    !(suggested 1)
    201. 

  201. ! ==================================================================================================
    202. 

  202. ! runoff parameters used for SIMTOP and SIMGM:
    203. 

  203.   REAL, PARAMETER :: TIMEAN = 10.5   !gridcell mean topgraphic index (global mean)
    204. 

  204.   REAL, PARAMETER :: FSATMX = 0.38   !maximum surface saturated fraction (global mean)
    205. 

  205. 

  206. ! adjustable parameters for snow processes
    207. 

  207. 

  208.   REAL, PARAMETER :: M      = 1.0 ! 2.50   !melting factor (-) 
    209. 

  209.   REAL, PARAMETER :: Z0SNO  = 0.002  !snow surface roughness length (m) (0.002)
    210. 

  210.   REAL, PARAMETER :: SSI    = 0.03   !liquid water holding capacity for snowpack (m3/m3) (0.03)
    211. 

  211.   REAL, PARAMETER :: SWEMX  = 1.00   !new snow mass to fully cover old snow (mm)
    212. 

  212.                                      !equivalent to 10mm depth (density = 100 kg/m3)
    213. 

  213. 

  214. ! NOTES: things to add or improve
    215. 

  215. ! 1. lake model: explicit representation of lake water storage, sunlight through lake
    216. 

  216. !    with different purity, turbulent mixing of surface laker water, snow on frozen lake, etc.
    217. 

  217. ! 2. shallow snow wihtout a layer: melting energy
    218. 

  218. ! 3. urban model to be added.
    219. 

  219. ! 4. irrigation
    220. 

  220. !------------------------------------------------------------------------------------------!
    221. 

  221. END MODULE NOAHMP_GLOBALS
    222. 

  222. !------------------------------------------------------------------------------------------!
    223. 

  223. !------------------------------------------------------------------------------------------!
    224. 

  224. MODULE NOAHMP_VEG_PARAMETERS
    225. 

  225. 

  226.     IMPLICIT NONE
    227. 

  227. 

  228.     INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33
    229. 

  229.     INTEGER, PARAMETER :: MVT   = 27
    230. 

  230.     INTEGER, PARAMETER :: MBAND = 2
    231. 

  231. 

  232.     INTEGER, PRIVATE :: ISURBAN
    233. 

  233.     INTEGER :: ISWATER
    234. 

  234.     INTEGER :: ISBARREN
    235. 

  235.     INTEGER :: ISSNOW
    236. 

  236.     INTEGER :: EBLFOREST
    237. 

  237. 

  238.     REAL :: CH2OP(MVT)       !maximum intercepted h2o per unit lai+sai (mm)
    239. 

  239.     REAL :: DLEAF(MVT)       !characteristic leaf dimension (m)
    240. 

  240.     REAL :: Z0MVT(MVT)       !momentum roughness length (m)
    241. 

  241.     REAL :: HVT(MVT)         !top of canopy (m)
    242. 

  242.     REAL :: HVB(MVT)         !bottom of canopy (m)
    243. 

  243.     REAL :: DEN(MVT)         !tree density (no. of trunks per m2)
    244. 

  244.     REAL :: RC(MVT)          !tree crown radius (m)
    245. 

  245.     REAL :: SAIM(MVT,12)     !monthly stem area index, one-sided
    246. 

  246.     REAL :: LAIM(MVT,12)     !monthly leaf area index, one-sided
    247. 

  247.     REAL :: SLA(MVT)         !single-side leaf area per Kg [m2/kg]
    248. 

  248.     REAL :: DILEFC(MVT)      !coeficient for leaf stress death [1/s]
    249. 

  249.     REAL :: DILEFW(MVT)      !coeficient for leaf stress death [1/s]
    250. 

  250.     REAL :: FRAGR(MVT)       !fraction of growth respiration  !original was 0.3 
    251. 

  251.     REAL :: LTOVRC(MVT)      !leaf turnover [1/s]
    252. 

  252. 

  253.     REAL :: C3PSN(MVT)       !photosynthetic pathway: 0. = c4, 1. = c3
    254. 

  254.     REAL :: KC25(MVT)        !co2 michaelis-menten constant at 25c (pa)
    255. 

  255.     REAL :: AKC(MVT)         !q10 for kc25
    256. 

  256.     REAL :: KO25(MVT)        !o2 michaelis-menten constant at 25c (pa)
    257. 

  257.     REAL :: AKO(MVT)         !q10 for ko25
    258. 

  258.     REAL :: VCMX25(MVT)      !maximum rate of carboxylation at 25c (umol co2/m**2/s)
    259. 

  259.     REAL :: AVCMX(MVT)       !q10 for vcmx25
    260. 

  260.     REAL :: BP(MVT)          !minimum leaf conductance (umol/m**2/s)
    261. 

  261.     REAL :: MP(MVT)          !slope of conductance-to-photosynthesis relationship
    262. 

  262.     REAL :: QE25(MVT)        !quantum efficiency at 25c (umol co2 / umol photon)
    263. 

  263.     REAL :: AQE(MVT)         !q10 for qe25
    264. 

  264.     REAL :: RMF25(MVT)       !leaf maintenance respiration at 25c (umol co2/m**2/s)
    265. 

  265.     REAL :: RMS25(MVT)       !stem maintenance respiration at 25c (umol co2/kg bio/s)
    266. 

  266.     REAL :: RMR25(MVT)       !root maintenance respiration at 25c (umol co2/kg bio/s)
    267. 

  267.     REAL :: ARM(MVT)         !q10 for maintenance respiration
    268. 

  268.     REAL :: FOLNMX(MVT)      !foliage nitrogen concentration when f(n)=1 (%)
    269. 

  269.     REAL :: TMIN(MVT)        !minimum temperature for photosynthesis (k)
    270. 

  270. 

  271.     REAL :: XL(MVT)          !leaf/stem orientation index
    272. 

  272.     REAL :: RHOL(MVT,MBAND)  !leaf reflectance: 1=vis, 2=nir
    273. 

  273.     REAL :: RHOS(MVT,MBAND)  !stem reflectance: 1=vis, 2=nir
    274. 

  274.     REAL :: TAUL(MVT,MBAND)  !leaf transmittance: 1=vis, 2=nir
    275. 

  275.     REAL :: TAUS(MVT,MBAND)  !stem transmittance: 1=vis, 2=nir
    276. 

  276. 

  277.     REAL :: MRP(MVT)         !microbial respiration parameter (umol co2 /kg c/ s)
    278. 

  278.     REAL :: CWPVT(MVT)       !empirical canopy wind parameter
    279. 

  279. 

  280.     REAL :: WRRAT(MVT)       !wood to non-wood ratio
    281. 

  281.     REAL :: WDPOOL(MVT)      !wood pool (switch 1 or 0) depending on woody or not [-]
    282. 

  282.     REAL :: TDLEF(MVT)       !characteristic T for leaf freezing [K]
    283. 

  283. 

  284.     INTEGER :: IK,IM
    285. 

  285.     REAL :: TMP10(MVT*MBAND)
    286. 

  286.     REAL :: TMP11(MVT*MBAND)
    287. 

  287.     REAL :: TMP12(MVT*MBAND)
    288. 

  288.     REAL :: TMP13(MVT*MBAND)
    289. 

  289.     REAL :: TMP14(MVT*12)
    290. 

  290.     REAL :: TMP15(MVT*12)
    291. 

  291.     REAL :: TMP16(MVT*5)
    292. 

  292. 

  293.     real slarea(MVT)
    294. 

  294.     real eps(MVT,5)
    295. 

  295. 

  296. CONTAINS
    297. 

  297.   subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
    298. 

  298.     implicit none
    299. 

  299.     character(len=*), intent(in) :: DATASET_IDENTIFIER
    300. 

  300.     integer :: ierr
    301. 

  301. 

  302.     ! Temporary arrays used in reshaping namelist arrays
    303. 

  303.     REAL :: TMP10(MVT*MBAND)
    304. 

  304.     REAL :: TMP11(MVT*MBAND)
    305. 

  305.     REAL :: TMP12(MVT*MBAND)
    306. 

  306.     REAL :: TMP13(MVT*MBAND)
    307. 

  307.     REAL :: TMP14(MVT*12)
    308. 

  308.     REAL :: TMP15(MVT*12)
    309. 

  309.     REAL :: TMP16(MVT*5)
    310. 

  310. 

  311.     integer :: NVEG
    312. 

  312.     character(len=256) :: VEG_DATASET_DESCRIPTION
    313. 

  313. 

  314.     NAMELIST / noah_mp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
    315. 

  315.     NAMELIST / noah_mp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, &
    316. 

  316.          CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL,  RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
    317. 

  317.          LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP,   &
    318. 

  318.          SAIM,  LAIM,  SLAREA, EPS
    319. 

  319. 

  320.     NAMELIST / noah_mp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
    321. 

  321.     NAMELIST / noah_mp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, &
    322. 

  322.          CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL,  RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
    323. 

  323.          LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP,   &
    324. 

  324.          SAIM,  LAIM,  SLAREA, EPS
    325. 

  325. 

  326.     ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything.
    327. 

  327.     CH2OP  = -1.E36
    328. 

  328.     DLEAF  = -1.E36
    329. 

  329.     Z0MVT  = -1.E36
    330. 

  330.     HVT    = -1.E36
    331. 

  331.     HVB    = -1.E36
    332. 

  332.     DEN    = -1.E36
    333. 

  333.     RC     = -1.E36
    334. 

  334.     RHOL   = -1.E36
    335. 

  335.     RHOS   = -1.E36
    336. 

  336.     TAUL   = -1.E36
    337. 

  337.     TAUS   = -1.E36
    338. 

  338.     XL     = -1.E36
    339. 

  339.     CWPVT  = -1.E36
    340. 

  340.     C3PSN  = -1.E36
    341. 

  341.     KC25   = -1.E36
    342. 

  342.     AKC    = -1.E36
    343. 

  343.     KO25   = -1.E36
    344. 

  344.     AKO    = -1.E36
    345. 

  345.     AVCMX  = -1.E36
    346. 

  346.     AQE    = -1.E36
    347. 

  347.     LTOVRC = -1.E36
    348. 

  348.     DILEFC = -1.E36
    349. 

  349.     DILEFW = -1.E36
    350. 

  350.     RMF25  = -1.E36
    351. 

  351.     SLA    = -1.E36
    352. 

  352.     FRAGR  = -1.E36
    353. 

  353.     TMIN   = -1.E36
    354. 

  354.     VCMX25 = -1.E36
    355. 

  355.     TDLEF  = -1.E36
    356. 

  356.     BP     = -1.E36
    357. 

  357.     MP     = -1.E36
    358. 

  358.     QE25   = -1.E36
    359. 

  359.     RMS25  = -1.E36
    360. 

  360.     RMR25  = -1.E36
    361. 

  361.     ARM    = -1.E36
    362. 

  362.     FOLNMX = -1.E36
    363. 

  363.     WDPOOL = -1.E36
    364. 

  364.     WRRAT  = -1.E36
    365. 

  365.     MRP    = -1.E36
    366. 

  366.     SAIM   = -1.E36
    367. 

  367.     LAIM   = -1.E36
    368. 

  368.     SLAREA = -1.E36
    369. 

  369.     EPS    = -1.E36
    370. 

  370. 

  371.     open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr)
    372. 

  372.     if (ierr /= 0) then
    373. 

  373.        write(*,'("****** Error ******************************************************")')
    374. 

  374.        write(*,'("Cannot find file MPTABLE.TBL")')
    375. 

  375.        write(*,'("STOP")')
    376. 

  376.        write(*,'("*******************************************************************")')
    377. 

  377.        call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters")
    378. 

  378.     endif
    379. 

  379. 

  380.     if ( trim(DATASET_IDENTIFIER) == "USGS" ) then
    381. 

  381.        read(15,noah_mp_usgs_veg_categories)
    382. 

  382.        read(15,noah_mp_usgs_parameters)
    383. 

  383.     else if ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then
    384. 

  384.        read(15,noah_mp_modis_veg_categories)
    385. 

  385.        read(15,noah_mp_modis_parameters)
    386. 

  386.     else
    387. 

  387.        write(*,'("Unrecognized DATASET_IDENTIFIER in subroutine READ_MP_VEG_PARAMETERS")')
    388. 

  388.        write(*,'("DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER)
    389. 

  389.        call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters")
    390. 

  390.     endif
    391. 

  391.     close(15)
    392. 

  392. 

  393.     ! Problem.  Namelist reading of 2-d arrays doesn't work well when the arrays are declared with larger dimension than the
    394. 

  394.     ! variables in the provided namelist.  So we need to reshape the 2-d arrays after we've read them.
    395. 

    396. 

  396.     if ( MVT > NVEG ) then
    397. 

  397. 

  398.        ! 
    399. 

  399.        ! Reshape the 2-d arrays:
    400. 

  400.        ! 
    401. 

  401. 

  402.        TMP10 = reshape( RHOL, (/ MVT*size(RHOL,2) /))
    403. 

  403.        TMP11 = reshape( RHOS, (/ MVT*size(RHOS,2) /))
    404. 

  404.        TMP12 = reshape( TAUL, (/ MVT*size(TAUL,2) /))
    405. 

  405.        TMP13 = reshape( TAUS, (/ MVT*size(TAUS,2) /))
    406. 

  406.        TMP14 = reshape( SAIM, (/ MVT*size(SAIM,2) /))
    407. 

  407.        TMP15 = reshape( LAIM, (/ MVT*size(LAIM,2) /))
    408. 

  408.        TMP16 = reshape( EPS,  (/ MVT*size(EPS ,2) /))
    409. 

  409. 

  410.        RHOL(1:NVEG,:) = reshape( TMP10, (/ NVEG, size(RHOL,2) /))
    411. 

  411.        RHOS(1:NVEG,:) = reshape( TMP11, (/ NVEG, size(RHOS,2) /))
    412. 

  412.        TAUL(1:NVEG,:) = reshape( TMP12, (/ NVEG, size(TAUL,2) /))
    413. 

  413.        TAUS(1:NVEG,:) = reshape( TMP13, (/ NVEG, size(TAUS,2) /))
    414. 

  414.        SAIM(1:NVEG,:) = reshape( TMP14, (/ NVEG, size(SAIM,2) /))
    415. 

  415.        LAIM(1:NVEG,:) = reshape( TMP15, (/ NVEG, size(LAIM,2) /))
    416. 

  416.        EPS(1:NVEG,:)  = reshape( TMP16, (/ NVEG, size(EPS,2)  /))
    417. 

  417. 

  418.        RHOL(NVEG+1:MVT,:) = -1.E36
    419. 

  419.        RHOS(NVEG+1:MVT,:) = -1.E36
    420. 

  420.        TAUL(NVEG+1:MVT,:) = -1.E36
    421. 

  421.        TAUS(NVEG+1:MVT,:) = -1.E36
    422. 

  422.        SAIM(NVEG+1:MVT,:) = -1.E36
    423. 

  423.        LAIM(NVEG+1:MVT,:) = -1.E36
    424. 

  424.        EPS( NVEG+1:MVT,:) = -1.E36
    425. 

  425.     endif
    426. 

  426. 

  427.   end subroutine read_mp_veg_parameters
    428. 

  428. 

  429. END MODULE NOAHMP_VEG_PARAMETERS
    430. 

  430. ! ==================================================================================================
    431. 

  431. ! ==================================================================================================
    432. 

  432. MODULE NOAHMP_RAD_PARAMETERS
    433. 

  433. 

  434.     IMPLICIT NONE
    435. 

  435.  
    436. 

  436.     INTEGER I                ! loop index
    437. 

  437.     INTEGER, PARAMETER :: MSC   = 9
    438. 

  438.     INTEGER, PARAMETER :: MBAND = 2
    439. 

  439. 

  440.     REAL :: ALBSAT(MSC,MBAND)   !saturated soil albedos: 1=vis, 2=nir
    441. 

  441.     REAL :: ALBDRY(MSC,MBAND)   !dry soil albedos: 1=vis, 2=nir
    442. 

  442.     REAL :: ALBICE(MBAND)       !albedo land ice: 1=vis, 2=nir
    443. 

  443.     REAL :: ALBLAK(MBAND)       !albedo frozen lakes: 1=vis, 2=nir
    444. 

  444.     REAL :: OMEGAS(MBAND)       !two-stream parameter omega for snow
    445. 

  445.     REAL :: BETADS              !two-stream parameter betad for snow
    446. 

  446.     REAL :: BETAIS              !two-stream parameter betad for snow
    447. 

  447.     REAL :: EG(2)               !emissivity
    448. 

  448. 

  449. ! saturated soil albedos: 1=vis, 2=nir
    450. 

  450.     DATA(ALBSAT(I,1),I=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/
    451. 

  451.     DATA(ALBSAT(I,2),I=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/
    452. 

  452. 

  453. ! dry soil albedos: 1=vis, 2=nir
    454. 

  454.     DATA(ALBDRY(I,1),I=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/
    455. 

  455.     DATA(ALBDRY(I,2),I=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/
    456. 

  456. 

  457. ! albedo land ice: 1=vis, 2=nir
    458. 

  458.     DATA (ALBICE(I),I=1,MBAND) /0.80, 0.55/
    459. 

  459. 

  460. ! albedo frozen lakes: 1=vis, 2=nir
    461. 

  461.     DATA (ALBLAK(I),I=1,MBAND) /0.60, 0.40/
    462. 

  462. 

  463. ! omega,betad,betai for snow
    464. 

  464.     DATA (OMEGAS(I),I=1,MBAND) /0.8, 0.4/
    465. 

  465.     DATA BETADS, BETAIS /0.5, 0.5/
    466. 

  466. 

  467. ! emissivity ground surface    
    468. 

  468.       DATA EG /0.97, 0.98/ ! 1-soil;2-lake
    469. 

  469. 

  470. END MODULE NOAHMP_RAD_PARAMETERS
    471. 

  471. ! ==================================================================================================
    472. 

  472. 

  473. MODULE NOAHMP_ROUTINES
    474. 

  474.   USE NOAHMP_GLOBALS
    475. 

  475.   IMPLICIT NONE
    476. 

  476. 

  477.   public  :: noahmp_options
    478. 

  478.   public  :: NOAHMP_SFLX
    479. 

  479.   public  :: REDPRM
    480. 

  480.   public  :: FRH2O           
    481. 

  481. 

  482.   private :: ATM
    483. 

  483.   private :: PHENOLOGY
    484. 

  484.   private :: ENERGY
    485. 

  485.   private ::       THERMOPROP
    486. 

  486.   private ::               CSNOW
    487. 

  487.   private ::               TDFCND
    488. 

  488.   private ::       RADIATION
    489. 

  489.   private ::               ALBEDO
    490. 

  490.   private ::                         SNOW_AGE
    491. 

  491.   private ::                         SNOWALB_BATS  
    492. 

  492.   private ::                         SNOWALB_CLASS
    493. 

  493.   private ::                         GROUNDALB
    494. 

  494.   private ::                         TWOSTREAM
    495. 

  495.   private ::               SURRAD
    496. 

  496.   private ::       VEGE_FLUX
    497. 

  497.   private ::               SFCDIF1                  
    498. 

  498.   private ::               SFCDIF2                
    499. 

  499.   private ::               STOMATA                  
    500. 

  500.   private ::               CANRES                  
    501. 

  501.   private ::               ESAT
    502. 

  502.   private ::               RAGRB
    503. 

  503.   private ::       BARE_FLUX
    504. 

  504.   private ::       TSNOSOI
    505. 

  505.   private ::               HRT
    506. 

  506.   private ::               HSTEP   
    507. 

  507.   private ::                         ROSR12
    508. 

  508.   private ::       PHASECHANGE
    509. 

  509. 

  510.   private :: WATER
    511. 

  511.   private ::       CANWATER
    512. 

  512.   private ::       SNOWWATER
    513. 

  513.   private ::               SNOWFALL
    514. 

  514.   private ::               COMBINE
    515. 

  515.   private ::               DIVIDE
    516. 

  516.   private ::                         COMBO
    517. 

  517.   private ::               COMPACT
    518. 

  518.   private ::               SNOWH2O
    519. 

  519.   private ::       SOILWATER
    520. 

  520.   private ::               ZWTEQ
    521. 

  521.   private ::               INFIL
    522. 

  522.   private ::               SRT
    523. 

  523.   private ::                         WDFCND1        
    524. 

  524.   private ::                         WDFCND2       
    525. 

  525. !  private ::                         INFIL       
    526. 

  526.   private ::               SSTEP
    527. 

  527.   private ::       GROUNDWATER
    528. 

  528. 

  529.   private :: CARBON
    530. 

  530.   private ::       CO2FLUX
    531. 

  531. !  private ::       BVOCFLUX
    532. 

  532. !  private ::       CH4FLUX
    533. 

  533. 

  534.   private :: ERROR
    535. 

  535. 

  536. contains
    537. 

  537. !
    538. 

  538. ! ==================================================================================================
    539. 

  539. 

  540.   SUBROUTINE NOAHMP_SFLX (&
    541. 

  541.        &           ILOC    , JLOC    , LAT     , YEARLEN , JULIAN  , COSZ    , & ! IN : Time/Space-related
    542. 

  542.        &           DT      , DX      , DZ8W    , NSOIL   , ZSOIL   , NSNOW   , & ! IN : Model configuration 
    543. 

  543.        &           SHDFAC  , SHDMAX  , VEGTYP  , ISURBAN , ICE     , IST     , & ! IN : Vegetation/Soil characteristics
    544. 

  544.        &           ISC     ,                                                   & ! IN : Vegetation/Soil characteristics
    545. 

  545.        &           IZ0TLND ,                                                   & ! IN : User options
    546. 

  546.        &           SFCTMP  , SFCPRS  , PSFC    , UU      , VV      , Q2      , & ! IN : Forcing
    547. 

  547.        &           QC      , SOLDN   , LWDN    , PRCP    , TBOT    , CO2AIR  , & ! IN : Forcing
    548. 

  548.        &           O2AIR   , FOLN    , FICEOLD , PBLH    ,                     & ! IN : Forcing
    549. 

  549.        &           ZLVL    , ALBOLD  , SNEQVO  ,                               & ! IN/OUT : 
    550. 

  550.        &           STC     , SH2O    , SMC     , TAH     , EAH     , FWET    , & ! IN/OUT : 
    551. 

  551.        &           CANLIQ  , CANICE  , TV      , TG      , QSFC    , QSNOW   , & ! IN/OUT : 
    552. 

  552.        &           ISNOW   , ZSNSO   , SNOWH   , SNEQV   , SNICE   , SNLIQ   , & ! IN/OUT : 
    553. 

  553.        &           ZWT     , WA      , WT      , WSLAKE  , LFMASS  , RTMASS  , & ! IN/OUT : 
    554. 

  554.        &           STMASS  , WOOD    , STBLCP  , FASTCP  , LAI     , SAI     , & ! IN/OUT : 
    555. 

  555.        &           CM      , CH      , CHSTAR  ,                               & ! IN/OUT : 
    556. 

  556.        &           FSA     , FSR     , FIRA    , FSH     , SSOIL   , FCEV    , & ! OUT : 
    557. 

  557.        &           FGEV    , FCTR    , ECAN    , ETRAN   , EDIR    , TRAD    , & ! OUT :
    558. 

  558.        &           TS      , TGB     , TGV     , T2MV    , T2MB    , TSTAR   , & ! OUT :
    559. 

  559.        &           Q1      , Q2V     , Q2B     , RUNSRF  , RUNSUB  , APAR    , & ! OUT :
    560. 

  560.        &           PSN     , SAV     , SAG     , FSNO    , NEE     , GPP     , & ! OUT :
    561. 

  561.        &           NPP     , FVEG    , ALBEDO  , QMELT   , PONDING , PONDING1, & ! OUT :
    562. 

  562.        &           PONDING2, RSSUN   , RSSHA   , BGAP    , WGAP    , GAP     , & ! OUT :
    563. 

  563.        &           ERRWAT  , CHV     , CHB     , EMISSI)                         ! OUT :
    564. 

  564. 

  565. ! --------------------------------------------------------------------------------------------------
    566. 

  566. ! Initial code: Guo-Yue Niu, Oct. 2007
    567. 

  567. ! --------------------------------------------------------------------------------------------------
    568. 

  568.   USE NOAHMP_VEG_PARAMETERS
    569. 

  569.   USE NOAHMP_RAD_PARAMETERS
    570. 

  570. ! --------------------------------------------------------------------------------------------------
    571. 

  571.   implicit none
    572. 

  572. ! --------------------------------------------------------------------------------------------------
    573. 

  573. ! input
    574. 

  574.   INTEGER                        , INTENT(IN)    :: ICE    !ice (ice = 1)
    575. 

  575.   INTEGER                        , INTENT(IN)    :: IST    !surface type 1->soil; 2->lake
    576. 

  576.   INTEGER                        , INTENT(IN)    :: VEGTYP !vegetation type 
    577. 

  577.   INTEGER                        , INTENT(IN)    :: ISC    !soil color type (1-lighest; 8-darkest)
    578. 

  578.   INTEGER                        , INTENT(IN)    :: NSNOW  !maximum no. of snow layers        
    579. 

  579.   INTEGER                        , INTENT(IN)    :: NSOIL  !no. of soil layers        
    580. 

  580.   INTEGER                        , INTENT(IN)    :: ILOC   !grid index
    581. 

  581.   INTEGER                        , INTENT(IN)    :: JLOC   !grid index
    582. 

  582.   REAL                           , INTENT(IN)    :: DT     !time step [sec]
    583. 

  583.   REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: ZSOIL  !layer-bottom depth from soil surf (m)
    584. 

  584.   REAL                           , INTENT(IN)    :: Q2     !mixing ratio (kg/kg) lowest model layer
    585. 

  585.   REAL                           , INTENT(IN)    :: SFCTMP !surface air temperature [K]
    586. 

  586.   REAL                           , INTENT(IN)    :: UU     !wind speed in eastward dir (m/s)
    587. 

  587.   REAL                           , INTENT(IN)    :: VV     !wind speed in northward dir (m/s)
    588. 

  588.   REAL                           , INTENT(IN)    :: SOLDN  !downward shortwave radiation (w/m2)
    589. 

  589.   REAL                           , INTENT(IN)    :: PRCP   !precipitation rate (kg m-2 s-1)
    590. 

  590.   REAL                           , INTENT(IN)    :: LWDN   !downward longwave radiation (w/m2)
    591. 

  591.   REAL                           , INTENT(IN)    :: SFCPRS !pressure (pa)
    592. 

  592.   REAL                           , INTENT(INOUT) :: ZLVL   !reference height (m)
    593. 

  593.   REAL                           , INTENT(IN)    :: COSZ   !cosine solar zenith angle [0-1]
    594. 

  594.   REAL                           , INTENT(IN)    :: TBOT   !bottom condition for soil temp. [K]
    595. 

  595.   REAL                           , INTENT(IN)    :: FOLN   !foliage nitrogen (%) [1-saturated]
    596. 

  596.   REAL                           , INTENT(IN)    :: SHDFAC !green vegetation fraction [0.0-1.0]
    597. 

  597.   INTEGER                        , INTENT(IN)    :: YEARLEN!Number of days in the particular year.
    598. 

  598.   REAL                           , INTENT(IN)    :: JULIAN !Julian day of year (floating point)
    599. 

  599.   REAL                           , INTENT(IN)    :: LAT    !latitude (radians)
    600. 

  600.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)    :: FICEOLD!ice fraction at last timestep
    601. 

  601. 

  602. !jref:start; in 
    603. 

  603.   INTEGER                        , INTENT(IN)    :: ISURBAN
    604. 

  604.   INTEGER                        , INTENT(IN)    :: IZ0TLND
    605. 

  605.   REAL                           , INTENT(IN)    :: QC     !cloud water mixing ratio
    606. 

  606.   REAL                           , INTENT(IN)    :: PBLH   !planetary boundary layer height
    607. 

  607.   REAL                           , INTENT(INOUT)    :: QSFC   !mixing ratio at lowest model layer
    608. 

  608.   REAL                           , INTENT(IN)    :: PSFC   !pressure at lowest model layer
    609. 

  609.   REAL                           , INTENT(IN)    :: DZ8W   !thickness of lowest layer
    610. 

  610.   REAL                           , INTENT(IN)    :: DX
    611. 

  611.   REAL                           , INTENT(IN)    :: SHDMAX  !yearly max vegetation fraction
    612. 

  612. !jref:end
    613. 

  613. 

  614. ! input/output : need arbitary intial values
    615. 

  615.   REAL                           , INTENT(INOUT) :: QSNOW  !snowfall [mm/s]
    616. 

  616.   REAL                           , INTENT(INOUT) :: FWET   !wetted or snowed fraction of canopy (-)
    617. 

  617.   REAL                           , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm)
    618. 

  618.   REAL                           , INTENT(INOUT) :: EAH    !canopy air vapor pressure (pa)
    619. 

  619.   REAL                           , INTENT(INOUT) :: TAH    !canopy air tmeperature (k)
    620. 

  620.   REAL                           , INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type)
    621. 

  621.   REAL                           , INTENT(INOUT) :: CM     !momentum drag coefficient
    622. 

  622.   REAL                           , INTENT(INOUT) :: CH     !sensible heat exchange coefficient
    623. 

  623. 

  624. ! prognostic variables
    625. 

  625.   INTEGER                        , INTENT(INOUT) :: ISNOW  !actual no. of snow layers [-]
    626. 

  626.   REAL                           , INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm)
    627. 

  627.   REAL                           , INTENT(INOUT) :: CANICE !intercepted ice mass (mm)
    628. 

  628.   REAL                           , INTENT(INOUT) :: SNEQV  !snow water eqv. [mm]
    629. 

  629.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SMC    !soil moisture (ice + liq.) [m3/m3]
    630. 

  630.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO  !layer-bottom depth from snow surf [m]
    631. 

  631.   REAL                           , INTENT(INOUT) :: SNOWH  !snow height [m]
    632. 

  632.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE  !snow layer ice [mm]
    633. 

  633.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ  !snow layer liquid water [mm]
    634. 

  634.   REAL                           , INTENT(INOUT) :: TV     !vegetation temperature (k)
    635. 

  635.   REAL                           , INTENT(INOUT) :: TG     !ground temperature (k)
    636. 

  636.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC    !snow/soil temperature [k]
    637. 

  637.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O   !liquid soil moisture [m3/m3]
    638. 

  638.   REAL                           , INTENT(INOUT) :: ZWT    !depth to water table [m]
    639. 

  639.   REAL                           , INTENT(INOUT) :: WA     !water storage in aquifer [mm]
    640. 

  640.   REAL                           , INTENT(INOUT) :: WT     !water in aquifer&saturated soil [mm]
    641. 

  641.   REAL                           , INTENT(INOUT) :: WSLAKE !lake water storage (can be neg.) (mm)
    642. 

  642. 

  643. ! output
    644. 

  644.   REAL                           , INTENT(OUT)   :: FSA    !total absorbed solar radiation (w/m2)
    645. 

  645.   REAL                           , INTENT(OUT)   :: FSR    !total reflected solar radiation (w/m2)
    646. 

  646.   REAL                           , INTENT(OUT)   :: FIRA   !total net LW rad (w/m2)  [+ to atm]
    647. 

  647.   REAL                           , INTENT(OUT)   :: FSH    !total sensible heat (w/m2) [+ to atm]
    648. 

  648.   REAL                           , INTENT(OUT)   :: FCEV   !canopy evap heat (w/m2) [+ to atm]
    649. 

  649.   REAL                           , INTENT(OUT)   :: FGEV   !ground evap heat (w/m2) [+ to atm]
    650. 

  650.   REAL                           , INTENT(OUT)   :: FCTR   !transpiration heat (w/m2) [+ to atm]
    651. 

  651.   REAL                           , INTENT(OUT)   :: SSOIL  !ground heat flux (w/m2)   [+ to soil]
    652. 

  652.   REAL                           , INTENT(OUT)   :: TRAD   !surface radiative temperature (k)
    653. 

  653.   REAL                           , INTENT(OUT)   :: TS     !surface temperature (k)
    654. 

  654.   REAL                           , INTENT(OUT)   :: ECAN   !evaporation of intercepted water (mm/s)
    655. 

  655.   REAL                           , INTENT(OUT)   :: ETRAN  !transpiration rate (mm/s)
    656. 

  656.   REAL                           , INTENT(OUT)   :: EDIR   !soil surface evaporation rate (mm/s]
    657. 

  657.   REAL                           , INTENT(OUT)   :: RUNSRF !surface runoff [mm/s] 
    658. 

  658.   REAL                           , INTENT(OUT)   :: RUNSUB !baseflow (saturation excess) [mm/s]
    659. 

  659.   REAL                           , INTENT(OUT)   :: PSN    !total photosynthesis (umol co2/m2/s) [+]
    660. 

  660.   REAL                           , INTENT(OUT)   :: APAR   !photosyn active energy by canopy (w/m2)
    661. 

  661.   REAL                           , INTENT(OUT)   :: SAV    !solar rad absorbed by veg. (w/m2)
    662. 

  662.   REAL                           , INTENT(OUT)   :: SAG    !solar rad absorbed by ground (w/m2)
    663. 

  663.   REAL                           , INTENT(OUT)   :: FSNO   !snow cover fraction on the ground (-)
    664. 

  664.   REAL                           , INTENT(OUT)   :: FVEG   !green vegetation fraction [0.0-1.0]
    665. 

  665.   REAL                           , INTENT(OUT)   :: ALBEDO !surface albedo [-]
    666. 

  666.   REAL                           , INTENT(OUT)   :: ERRWAT !water error [kg m{-2}]
    667. 

  667.   REAL                           , INTENT(OUT)   :: QMELT  !snowmelt [mm/s]
    668. 

  668.   REAL                           , INTENT(OUT)   :: PONDING!surface ponding [mm]
    669. 

  669.   REAL                           , INTENT(OUT)   :: PONDING1!surface ponding [mm]
    670. 

  670.   REAL                           , INTENT(OUT)   :: PONDING2!surface ponding [mm]
    671. 

  671. 

  672. !jref:start; output
    673. 

  673.   REAL                           , INTENT(OUT)     :: CHSTAR !effective exchange coefficient
    674. 

  674.   REAL                           , INTENT(OUT)     :: TSTAR  !effective skin temperature
    675. 

  675.   REAL                           , INTENT(OUT)     :: T2MV   !2-m air temperature over vegetated part [k]
    676. 

  676.   REAL                           , INTENT(OUT)     :: T2MB   !2-m air temperature over bare ground part [k]
    677. 

  677.   REAL, INTENT(OUT) :: RSSUN        !sunlit leaf stomatal resistance (s/m)
    678. 

  678.   REAL, INTENT(OUT) :: RSSHA        !shaded leaf stomatal resistance (s/m)
    679. 

  679.   REAL, INTENT(OUT) :: BGAP
    680. 

  680.   REAL, INTENT(OUT) :: WGAP
    681. 

  681.   REAL, INTENT(OUT) :: GAP
    682. 

  682.   REAL, INTENT(OUT) :: TGV
    683. 

  683.   REAL, INTENT(OUT) :: TGB
    684. 

  684.   REAL, INTENT(OUT) :: Q1
    685. 

  685.   REAL, INTENT(OUT) :: EMISSI
    686. 

  686. !jref:end
    687. 

  687. 

  688. ! local
    689. 

  689.   INTEGER                                        :: IZ     !do-loop index
    690. 

  690.   INTEGER, DIMENSION(-NSNOW+1:NSOIL)             :: IMELT  !phase change index [1-melt; 2-freeze]
    691. 

  691.   REAL                                           :: CMC    !intercepted water (CANICE+CANLIQ) (mm)
    692. 

  692.   REAL                                           :: TAUX   !wind stress: e-w (n/m2)
    693. 

  693.   REAL                                           :: TAUY   !wind stress: n-s (n/m2)
    694. 

  694.   REAL                                           :: RHOAIR !density air (kg/m3)
    695. 

  695. !  REAL, DIMENSION(       1:    5)                :: VOCFLX !voc fluxes [ug C m-2 h-1]
    696. 

  696.   REAL, DIMENSION(-NSNOW+1:NSOIL)                :: DZSNSO !snow/soil layer thickness [m]
    697. 

  697.   REAL                                           :: THAIR  !potential temperature (k)
    698. 

  698.   REAL                                           :: QAIR   !specific humidity (kg/kg) (q2/(1+q2))
    699. 

  699.   REAL                                           :: EAIR   !vapor pressure air (pa)
    700. 

  700.   REAL, DIMENSION(       1:    2)                :: SOLAD  !incoming direct solar rad (w/m2)
    701. 

  701.   REAL, DIMENSION(       1:    2)                :: SOLAI  !incoming diffuse solar rad (w/m2)
    702. 

  702.   REAL                                           :: QPRECC !convective precipitation (mm/s)
    703. 

  703.   REAL                                           :: QPRECL !large-scale precipitation (mm/s)
    704. 

  704.   REAL                                           :: IGS    !growing season index (0=off, 1=on)
    705. 

  705.   REAL                                           :: ELAI   !leaf area index, after burying by snow
    706. 

  706.   REAL                                           :: ESAI   !stem area index, after burying by snow
    707. 

  707.   REAL                                           :: BEVAP  !soil water evaporation factor (0 - 1)
    708. 

  708.   REAL, DIMENSION(       1:NSOIL)                :: BTRANI !Soil water transpiration factor (0 - 1)
    709. 

  709.   REAL                                           :: BTRAN  !soil water transpiration factor (0 - 1)
    710. 

  710.   REAL                                           :: HTOP   !top of canopy layer (m)
    711. 

  711.   REAL                                           :: QIN    !groundwater recharge [mm/s]
    712. 

  712.   REAL                                           :: QDIS   !groundwater discharge [mm/s]
    713. 

  713.   REAL, DIMENSION(       1:NSOIL)                :: SICE   !soil ice content (m3/m3)
    714. 

  714.   REAL, DIMENSION(-NSNOW+1:    0)                :: SNICEV !partial volume ice of snow [m3/m3]
    715. 

  715.   REAL, DIMENSION(-NSNOW+1:    0)                :: SNLIQV !partial volume liq of snow [m3/m3]
    716. 

  716.   REAL, DIMENSION(-NSNOW+1:    0)                :: EPORE  !effective porosity [m3/m3]
    717. 

  717.   REAL                                           :: TOTSC  !total soil carbon (g/m2)
    718. 

  718.   REAL                                           :: TOTLB  !total living carbon (g/m2)
    719. 

  719.   REAL                                           :: T2M    !2-meter air temperature (k)
    720. 

  720.   REAL                                           :: QDEW   !ground surface dew rate [mm/s]
    721. 

  721.   REAL                                           :: QVAP   !ground surface evap. rate [mm/s]
    722. 

  722.   REAL                                           :: LATHEA !latent heat [j/kg]
    723. 

  723.   REAL                                           :: SWDOWN !downward solar [w/m2]
    724. 

  724.   REAL                                           :: BEG_WB !water storage at begin of a step [mm]
    725. 

  725. 

  726. !jref:start 
    727. 

  727.   REAL                                           :: FSRV
    728. 

  728.   REAL                                           :: FSRG
    729. 

  729.   REAL,INTENT(OUT)                               :: Q2V
    730. 

  730.   REAL,INTENT(OUT)                               :: Q2B
    731. 

  731.   REAL :: Q2E
    732. 

  732.   REAL :: QFX
    733. 

  733.   REAL,INTENT(OUT)                               :: CHV    !sensible heat exchange coefficient over vegetated fraction
    734. 

  734.   REAL,INTENT(OUT)                               :: CHB    !sensible heat exchange coefficient over bare-ground
    735. 

  735. !jref:end  
    736. 

  736. 

  737. ! carbon
    738. 

  738. ! inputs
    739. 

  739.   REAL                           , INTENT(IN)    :: CO2AIR !atmospheric co2 concentration (pa)
    740. 

  740.   REAL                           , INTENT(IN)    :: O2AIR  !atmospheric o2 concentration (pa)
    741. 

  741. 

  742. ! inputs and outputs : prognostic variables
    743. 

  743.   REAL                        , INTENT(INOUT)    :: LFMASS !leaf mass [g/m2]
    744. 

  744.   REAL                        , INTENT(INOUT)    :: RTMASS !mass of fine roots [g/m2]
    745. 

  745.   REAL                        , INTENT(INOUT)    :: STMASS !stem mass [g/m2]
    746. 

  746.   REAL                        , INTENT(INOUT)    :: WOOD   !mass of wood (incl. woody roots) [g/m2]
    747. 

  747.   REAL                        , INTENT(INOUT)    :: STBLCP !stable carbon in deep soil [g/m2]
    748. 

  748.   REAL                        , INTENT(INOUT)    :: FASTCP !short-lived carbon, shallow soil [g/m2]
    749. 

  749.   REAL                        , INTENT(INOUT)    :: LAI    !leaf area index [-]
    750. 

  750.   REAL                        , INTENT(INOUT)    :: SAI    !stem area index [-]
    751. 

  751. 

  752. ! outputs
    753. 

  753.   REAL                          , INTENT(OUT)    :: NEE    !net ecosys exchange (g/m2/s CO2)
    754. 

  754.   REAL                          , INTENT(OUT)    :: GPP    !net instantaneous assimilation [g/m2/s C]
    755. 

  755.   REAL                          , INTENT(OUT)    :: NPP    !net primary productivity [g/m2/s C]
    756. 

  756.   REAL                                           :: AUTORS !net ecosystem respiration (g/m2/s C)
    757. 

  757.   REAL                                           :: HETERS !organic respiration (g/m2/s C)
    758. 

  758.   REAL                                           :: TROOT  !root-zone averaged temperature (k)
    759. 

  759. 

  760.   ! INTENT (OUT) variables need to be assigned a value.  These normally get assigned values
    761. 

  761.   ! only if DVEG == 2.
    762. 

  762.   nee = 0.0
    763. 

  763.   npp = 0.0
    764. 

  764.   gpp = 0.0
    765. 

  765. 

  766. ! --------------------------------------------------------------------------------------------------
    767. 

  767. ! re-process atmospheric forcing
    768. 

  768. 

  769.    CALL ATM (SFCPRS ,SFCTMP ,Q2     ,PRCP   ,SOLDN  ,COSZ   ,THAIR  , & 
    770. 

  770.              QAIR   ,EAIR   ,RHOAIR ,QPRECC ,QPRECL ,SOLAD  ,SOLAI  , &
    771. 

  771.              SWDOWN )
    772. 

  772. 

  773. ! snow/soil layer thickness (m)
    774. 

  774. 

  775.      DO IZ = ISNOW+1, NSOIL
    776. 

  776.          IF(IZ == ISNOW+1) THEN
    777. 

  777.            DZSNSO(IZ) = - ZSNSO(IZ)
    778. 

  778.          ELSE
    779. 

  779.            DZSNSO(IZ) = ZSNSO(IZ-1) - ZSNSO(IZ)
    780. 

  780.          END IF
    781. 

  781.      END DO
    782. 

  782. 

  783. ! root-zone temperature
    784. 

  784. 

  785.      TROOT  = 0.
    786. 

  786.      DO IZ=1,NROOT
    787. 

  787.         TROOT = TROOT + STC(IZ)*DZSNSO(IZ)/(-ZSOIL(NROOT))
    788. 

  788.      ENDDO
    789. 

  789. 

  790. ! total water storage for water balance check
    791. 

  791.     
    792. 

  792.      IF(IST == 1) THEN
    793. 

  793.      BEG_WB = CANLIQ + CANICE + SNEQV + WA
    794. 

  794.      DO IZ = 1,NSOIL
    795. 

  795.         BEG_WB = BEG_WB + SMC(IZ) * DZSNSO(IZ) * 1000.
    796. 

  796.      END DO
    797. 

  797.      END IF
    798. 

  798. 

  799. ! vegetation phenology
    800. 

  800. 

  801.      CALL PHENOLOGY (VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JULIAN , & !in
    802. 

  802.                      LAI    , SAI    , TROOT  , HTOP  , ELAI    , ESAI   ,IGS)
    803. 

  803. 

  804. !input GVF should be consistent with LAI
    805. 

  805.      IF(DVEG == 1) THEN
    806. 

  806.         FVEG = SHDFAC
    807. 

  807.         IF(FVEG <= 0.05) FVEG = 0.05
    808. 

  808.      ELSE IF (DVEG == 2 .or. DVEG == 3) THEN
    809. 

  809.         FVEG = 1.-EXP(-0.52*(LAI+SAI))
    810. 

  810.         IF(FVEG <= 0.05) FVEG = 0.05
    811. 

  811.      ELSE IF (DVEG == 4) THEN
    812. 

  812.         FVEG = SHDMAX
    813. 

  813.         IF(FVEG <= 0.05) FVEG = 0.05
    814. 

  814.      ELSE
    815. 

  815.         WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------"
    816. 

  816.         CALL wrf_error_fatal("Namelist parameter DVEG unknown") 
    817. 

  817.      ENDIF
    818. 

  818. 

  819. !     CALL PHENOLOGY (VEGTYP,IMONTH ,IDAY   ,SNOWH  ,TV     ,LAT   , & !in
    820. 

  820. !                     LAI   ,SAI    ,TROOT  ,                & !in
    821. 

  821. !                     HTOP  ,ELAI   ,ESAI   ,IGS    )   !out
    822. 

  822. 

  823. ! compute energy budget (momentum & energy fluxes and phase changes) 
    824. 

  824. 

  825.     CALL ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
    826. 

  826.                  ISNOW  ,NROOT  ,DT     ,RHOAIR ,SFCPRS ,QAIR   , & !in
    827. 

  827.                  SFCTMP ,THAIR  ,LWDN   ,UU     ,VV     ,ZLVL   , & !in
    828. 

  828.                  CO2AIR ,O2AIR  ,SOLAD  ,SOLAI  ,COSZ   ,IGS    , & !in
    829. 

  829.                  EAIR   ,HTOP   ,TBOT   ,ZBOT   ,ZSNSO  ,ZSOIL  , & !in
    830. 

  830.                  ELAI   ,ESAI   ,CSOIL  ,FWET   ,FOLN   ,         & !in
    831. 

  831.                  FVEG   ,                                         & !in
    832. 

  832.                  QSNOW  ,DZSNSO ,LAT    ,CANLIQ ,CANICE ,iloc, jloc , & !in
    833. 

  833.                  IMELT  ,SNICEV ,SNLIQV ,EPORE  ,T2M    ,FSNO   , & !out
    834. 

  834.                  SAV    ,SAG    ,QMELT  ,FSA    ,FSR    ,TAUX   , & !out
    835. 

  835.                  TAUY   ,FIRA   ,FSH    ,FCEV   ,FGEV   ,FCTR   , & !out
    836. 

  836.                  TRAD   ,PSN    ,APAR   ,SSOIL  ,BTRANI ,BTRAN  , & !out
    837. 

  837.                  PONDING,TS     ,LATHEA ,                         & !out
    838. 

  838.                  TV     ,TG     ,STC    ,SNOWH  ,EAH    ,TAH    , & !inout
    839. 

  839.                  SNEQVO ,SNEQV  ,SH2O   ,SMC    ,SNICE  ,SNLIQ  , & !inout
    840. 

  840.                  ALBOLD ,CM     ,CH     ,DX     ,DZ8W   ,Q2     , & !inout
    841. 

  841. !jref:start
    842. 

  842.                  QC     ,PBLH   ,QSFC   ,PSFC   ,ISURBAN,IZ0TLND, & !in 
    843. 

  843.                  CHSTAR ,TSTAR  ,T2MV   ,T2MB  ,FSRV   , &
    844. 

  844.                  FSRG   ,RSSUN   ,RSSHA ,BGAP   ,WGAP, GAP,TGV,TGB,&
    845. 

  845.                  Q1     ,Q2V    ,Q2B    ,Q2E    ,CHV   ,CHB     , & !out
    846. 

  846.                  EMISSI)                                            !out
    847. 

  847. !jref:end                            
    848. 

  848. 

  849.     SICE(:) = MAX(0.0, SMC(:) - SH2O(:))   
    850. 

  850.     SNEQVO  = SNEQV
    851. 

  851. 

  852.     QVAP = MAX( FGEV/LATHEA, 0.)       ! positive part of fgev
    853. 

  853.     QDEW = ABS( MIN(FGEV/LATHEA, 0.))  ! negative part of fgev
    854. 

  854.     EDIR = QVAP - QDEW
    855. 

  855. 

  856. ! compute water budgets (water storages, ET components, and runoff)
    857. 

  857. 

  858.      CALL WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
    859. 

  859.                  VV     ,FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
    860. 

  860.                  ESAI   ,SFCTMP ,QVAP   ,QDEW   ,ZSOIL  ,BTRANI , & !in
    861. 

  861.                  FICEOLD,PONDING,TG     ,IST    ,FVEG   ,iloc,jloc , & !in
    862. 

  862.                  ISNOW  ,CANLIQ ,CANICE ,TV     ,SNOWH  ,SNEQV  , & !inout
    863. 

  863.                  SNICE  ,SNLIQ  ,STC    ,ZSNSO  ,SH2O   ,SMC    , & !inout
    864. 

  864.                  SICE   ,ZWT    ,WA     ,WT     ,DZSNSO ,WSLAKE , & !inout
    865. 

  865.                  CMC    ,ECAN   ,ETRAN  ,FWET   ,RUNSRF ,RUNSUB , & !out
    866. 

  866.                  QIN    ,QDIS   ,QSNOW  ,PONDING1       ,PONDING2,&
    867. 

  867.                  ISURBAN)  !out
    868. 

  868. 

  869. !     write(*,'(a20,10F15.5)') 'SFLX:RUNOFF=',RUNSRF*DT,RUNSUB*DT,EDIR*DT
    870. 

  870. 

  871. ! compute carbon budgets (carbon storages and co2 & bvoc fluxes)
    872. 

  872. 

  873.    IF (DVEG == 2) THEN
    874. 

  874.     CALL CARBON (NSNOW  ,NSOIL  ,VEGTYP ,NROOT  ,DT     ,ZSOIL  , & !in
    875. 

  875.                  DZSNSO ,STC    ,SMC    ,TV     ,TG     ,PSN    , & !in
    876. 

  876.                  FOLN   ,SMCMAX ,BTRAN  ,APAR   ,FVEG   ,IGS    , & !in
    877. 

  877.                  TROOT  ,IST    ,LAT    ,iloc   ,jloc   ,         & !in
    878. 

  878.                  LFMASS ,RTMASS ,STMASS ,WOOD   ,STBLCP ,FASTCP , & !inout
    879. 

  879.                  GPP    ,NPP    ,NEE    ,AUTORS ,HETERS ,TOTSC  , & !out
    880. 

  880.                  TOTLB  ,LAI    ,SAI    )                   !out
    881. 

  881.    END IF
    882. 

  882. 

  883. ! water and energy balance check
    884. 

  884. 

  885.      CALL ERROR (SWDOWN ,FSA    ,FSR    ,FIRA   ,FSH    ,FCEV   , & !in
    886. 

  886.                  FGEV   ,FCTR   ,SSOIL  ,BEG_WB ,CANLIQ ,CANICE , & !in
    887. 

  887.                  SNEQV  ,WA     ,SMC    ,DZSNSO ,PRCP   ,ECAN   , & !in
    888. 

  888.                  ETRAN  ,EDIR   ,RUNSRF ,RUNSUB ,DT     ,NSOIL  , & !in
    889. 

  889.                  NSNOW  ,IST    ,ERRWAT ,ILOC   , JLOC  ,FVEG   , &
    890. 

  890.                  SAV    ,SAG    ,FSRV   ,FSRG)   !in ( Except ERRWAT, which is out )
    891. 

  891. 

  892. ! urban - jref
    893. 

  893.     QFX = ETRAN + ECAN + EDIR
    894. 

  894.     IF ( VEGTYP == ISURBAN ) THEN
    895. 

  895.        QSFC = (QFX/RHOAIR*CHSTAR) + QAIR
    896. 

  896.        Q2B = QSFC
    897. 

  897.     END IF
    898. 

  898. 

  899.     IF(SWDOWN.NE.0.) THEN
    900. 

  900.       ALBEDO = FSR / SWDOWN
    901. 

  901.     ELSE
    902. 

  902.       ALBEDO = -999.9
    903. 

  903.     END IF
    904. 

  904.     
    905. 

  905. 

  906.   END SUBROUTINE NOAHMP_SFLX
    907. 

  907. ! ==================================================================================================
    908. 

  908.   SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2     ,PRCP   ,SOLDN  ,COSZ   ,THAIR  , &
    909. 

  909.                   QAIR   ,EAIR   ,RHOAIR ,QPRECC ,QPRECL ,SOLAD  ,SOLAI  , &
    910. 

  910.                   SWDOWN )     
    911. 

  911. ! --------------------------------------------------------------------------------------------------
    912. 

  912. ! re-process atmospheric forcing
    913. 

  913. ! --------------------------------------------------------------------------------------------------
    914. 

  914.   IMPLICIT NONE
    915. 

  915. ! --------------------------------------------------------------------------------------------------
    916. 

  916. ! inputs
    917. 

  917. 

  918.   REAL                          , INTENT(IN)  :: SFCPRS !pressure (pa)
    919. 

  919.   REAL                          , INTENT(IN)  :: SFCTMP !surface air temperature [k]
    920. 

  920.   REAL                          , INTENT(IN)  :: Q2     !mixing ratio (kg/kg)
    921. 

  921.   REAL                          , INTENT(IN)  :: SOLDN  !downward shortwave radiation (w/m2)
    922. 

  922.   REAL                          , INTENT(IN)  :: PRCP   !precipitation rate (kg m-2 s-1)
    923. 

  923.   REAL                          , INTENT(IN)  :: COSZ   !cosine solar zenith angle [0-1]
    924. 

  924. 

  925. ! outputs
    926. 

  926. 

  927.   REAL                          , INTENT(OUT) :: THAIR  !potential temperature (k)
    928. 

  928.   REAL                          , INTENT(OUT) :: QAIR   !specific humidity (kg/kg) (q2/(1+q2))
    929. 

  929.   REAL                          , INTENT(OUT) :: EAIR   !vapor pressure air (pa)
    930. 

  930.   REAL, DIMENSION(       1:   2), INTENT(OUT) :: SOLAD  !incoming direct solar radiation (w/m2)
    931. 

  931.   REAL, DIMENSION(       1:   2), INTENT(OUT) :: SOLAI  !incoming diffuse solar radiation (w/m2)
    932. 

  932.   REAL                          , INTENT(OUT) :: QPRECC !convective precipitation (mm/s)
    933. 

  933.   REAL                          , INTENT(OUT) :: QPRECL !large-scale precipitation (mm/s)
    934. 

  934.   REAL                          , INTENT(OUT) :: RHOAIR !density air (kg/m3)
    935. 

  935.   REAL                          , INTENT(OUT) :: SWDOWN !downward solar filtered by sun angle [w/m2]
    936. 

  936. 

  937. !locals
    938. 

  938. 

  939.   REAL                                        :: PAIR   !atm bottom level pressure (pa)
    940. 

  940. ! --------------------------------------------------------------------------------------------------
    941. 

  941. 

  942. !jref: seems like PAIR should be P1000mb??
    943. 

  943.        PAIR   = SFCPRS                   ! atm bottom level pressure (pa)
    944. 

  944.        THAIR  = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) 
    945. 

  945. !jref: mixing ratio to specific       
    946. 

  946.        QAIR   = Q2 / (1.0+Q2)           ! mixing ratio to specific humidity [kg/kg]
    947. 

  947. !       QAIR   = Q2                       ! GLDAS forcing: Q2 = specific humidity [kg/kg]
    948. 

  948. 

  949.        EAIR   = QAIR*SFCPRS / (0.622+0.378*QAIR)
    950. 

  950.        RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP)
    951. 

  951. 

  952.        QPRECC = 0.10 * PRCP          ! should be from the atmospheric model
    953. 

  953.        QPRECL = 0.90 * PRCP          ! should be from the atmospheric model
    954. 

  954. 

  955.        IF(COSZ <= 0.) THEN 
    956. 

  956.           SWDOWN = 0.
    957. 

  957.        ELSE
    958. 

  958.           SWDOWN = SOLDN
    959. 

  959.        END IF 
    960. 

  960. 

  961.        SOLAD(1) = SWDOWN*0.7*0.5     ! direct  vis
    962. 

  962.        SOLAD(2) = SWDOWN*0.7*0.5     ! direct  nir
    963. 

  963.        SOLAI(1) = SWDOWN*0.3*0.5     ! diffuse vis
    964. 

  964.        SOLAI(2) = SWDOWN*0.3*0.5     ! diffuse nir
    965. 

  965. 

  966.   END SUBROUTINE ATM
    967. 

  967. ! ==================================================================================================
    968. 

  968. ! --------------------------------------------------------------------------------------------------
    969. 

  969.   SUBROUTINE PHENOLOGY (VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JULIAN , & !in
    970. 

  970.                         LAI    , SAI    , TROOT  , HTOP  , ELAI    , ESAI   , IGS)
    971. 

  971. 

  972. ! --------------------------------------------------------------------------------------------------
    973. 

  973. ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time
    974. 

  974. ! --------------------------------------------------------------------------------------------------
    975. 

  975.   USE NOAHMP_VEG_PARAMETERS
    976. 

  976. ! --------------------------------------------------------------------------------------------------
    977. 

  977.   IMPLICIT NONE
    978. 

  978. ! --------------------------------------------------------------------------------------------------
    979. 

  979. ! inputs
    980. 

  980.   INTEGER                , INTENT(IN   ) :: VEGTYP !vegetation type 
    981. 

  981.   REAL                   , INTENT(IN   ) :: SNOWH  !snow height [m]
    982. 

  982.   REAL                   , INTENT(IN   ) :: TV     !vegetation temperature (k)
    983. 

  983.   REAL                   , INTENT(IN   ) :: LAT    !latitude (radians)
    984. 

  984.   INTEGER                , INTENT(IN   ) :: YEARLEN!Number of days in the particular year
    985. 

  985.   REAL                   , INTENT(IN   ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN )
    986. 

  986.   real                   , INTENT(IN   ) :: TROOT  !root-zone averaged temperature (k)
    987. 

  987.   REAL                   , INTENT(INOUT) :: LAI    !LAI, unadjusted for burying by snow
    988. 

  988.   REAL                   , INTENT(INOUT) :: SAI    !SAI, unadjusted for burying by snow
    989. 

  989. 

  990. ! outputs
    991. 

  991.   REAL                   , INTENT(OUT  ) :: HTOP   !top of canopy layer (m)
    992. 

  992.   REAL                   , INTENT(OUT  ) :: ELAI   !leaf area index, after burying by snow
    993. 

  993.   REAL                   , INTENT(OUT  ) :: ESAI   !stem area index, after burying by snow
    994. 

  994.   REAL                   , INTENT(OUT  ) :: IGS    !growing season index (0=off, 1=on)
    995. 

  995. 

  996. ! locals
    997. 

  997. 

  998.   REAL                                   :: DB     !thickness of canopy buried by snow (m)
    999. 

  999.   REAL                                   :: FB     !fraction of canopy buried by snow
    1000. 

  1000.   REAL                                   :: SNOWHC !critical snow depth at which short vege
    1001. 

  1001.                                                    !is fully covered by snow
    1002. 

  1002. 

  1003.   INTEGER                                :: K       !index
    1004. 

  1004.   INTEGER                                :: IT1,IT2 !interpolation months
    1005. 

  1005.   REAL                                   :: DAY     !current day of year ( 0 <= DAY < YEARLEN )
    1006. 

  1006.   REAL                                   :: WT1,WT2 !interpolation weights
    1007. 

  1007.   REAL                                   :: T       !current month (1.00, ..., 12.00)
    1008. 

  1008. ! --------------------------------------------------------------------------------------------------
    1009. 

  1009. 

  1010.   IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN
    1011. 

  1011. 

  1012.      IF (LAT >= 0.) THEN
    1013. 

  1013.         ! Northern Hemisphere
    1014. 

  1014.         DAY = JULIAN
    1015. 

  1015.      ELSE
    1016. 

  1016.         ! Southern Hemisphere.  DAY is shifted by 1/2 year.
    1017. 

  1017.         DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) )
    1018. 

  1018.      ENDIF
    1019. 

  1019. 

  1020.      T = 12. * DAY / REAL(YEARLEN)
    1021. 

  1021.      IT1 = T + 0.5
    1022. 

  1022.      IT2 = IT1 + 1
    1023. 

  1023.      WT1 = (IT1+0.5) - T
    1024. 

  1024.      WT2 = 1.-WT1
    1025. 

  1025.      IF (IT1 .LT.  1) IT1 = 12
    1026. 

  1026.      IF (IT2 .GT. 12) IT2 = 1
    1027. 

  1027. 

  1028.      LAI = WT1*LAIM(VEGTYP,IT1) + WT2*LAIM(VEGTYP,IT2)
    1029. 

  1029.      SAI = WT1*SAIM(VEGTYP,IT1) + WT2*SAIM(VEGTYP,IT2)
    1030. 

  1030.   ENDIF
    1031. 

  1031. 

  1032.   IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISSNOW ) ) THEN
    1033. 

  1033.      LAI  = 0.
    1034. 

  1034.      SAI  = 0.
    1035. 

  1035.   ENDIF
    1036. 

  1036. 

  1037. !buried by snow
    1038. 

  1038. 

  1039.      DB = MIN( MAX(SNOWH - HVB(VEGTYP),0.), HVT(VEGTYP)-HVB(VEGTYP) )
    1040. 

  1040.      FB = DB / MAX(1.E-06,HVT(VEGTYP)-HVB(VEGTYP))
    1041. 

  1041. 

  1042.      IF(HVT(VEGTYP)> 0. .AND. HVT(VEGTYP) <= 0.5) THEN
    1043. 

  1043.        SNOWHC = HVT(VEGTYP)*EXP(-SNOWH/0.1)
    1044. 

  1044.        FB     = MIN(SNOWH,SNOWHC)/SNOWHC
    1045. 

  1045.      ENDIF
    1046. 

  1046. 

  1047.      ELAI =  LAI*(1.-FB)
    1048. 

  1048.      ESAI =  SAI*(1.-FB)
    1049. 

  1049. 

  1050.      IF (TV .GT. TMIN(VEGTYP)) THEN
    1051. 

  1051.          IGS = 1.
    1052. 

  1052.      ELSE
    1053. 

  1053.          IGS = 0.
    1054. 

  1054.      ENDIF
    1055. 

  1055. 

  1056.      HTOP = HVT(VEGTYP)
    1057. 

  1057. 

  1058.   END SUBROUTINE PHENOLOGY
    1059. 

  1059. ! ==================================================================================================
    1060. 

  1060.   SUBROUTINE ERROR (SWDOWN ,FSA    ,FSR    ,FIRA   ,FSH    ,FCEV   , &
    1061. 

  1061.                     FGEV   ,FCTR   ,SSOIL  ,BEG_WB ,CANLIQ ,CANICE , &
    1062. 

  1062.                     SNEQV  ,WA     ,SMC    ,DZSNSO ,PRCP   ,ECAN   , &
    1063. 

  1063.                     ETRAN  ,EDIR   ,RUNSRF ,RUNSUB ,DT     ,NSOIL  , &
    1064. 

  1064.                     NSNOW  ,IST    ,ERRWAT, ILOC   ,JLOC   ,FVEG   , &
    1065. 

  1065.                     SAV    ,SAG    ,FSRV   ,FSRG)
    1066. 

  1066. ! --------------------------------------------------------------------------------------------------
    1067. 

  1067. ! check surface energy balance and water balance
    1068. 

  1068. ! --------------------------------------------------------------------------------------------------
    1069. 

  1069.   IMPLICIT NONE
    1070. 

  1070. ! --------------------------------------------------------------------------------------------------
    1071. 

  1071. ! inputs
    1072. 

  1072.   INTEGER                        , INTENT(IN) :: NSNOW  !maximum no. of snow layers        
    1073. 

  1073.   INTEGER                        , INTENT(IN) :: NSOIL  !number of soil layers
    1074. 

  1074.   INTEGER                        , INTENT(IN) :: IST    !surface type 1->soil; 2->lake
    1075. 

  1075.   INTEGER                        , INTENT(IN) :: ILOC   !grid index
    1076. 

  1076.   INTEGER                        , INTENT(IN) :: JLOC   !grid index
    1077. 

  1077.   REAL                           , INTENT(IN) :: SWDOWN !downward solar filtered by sun angle [w/m2]
    1078. 

  1078.   REAL                           , INTENT(IN) :: FSA    !total absorbed solar radiation (w/m2)
    1079. 

  1079.   REAL                           , INTENT(IN) :: FSR    !total reflected solar radiation (w/m2)
    1080. 

  1080.   REAL                           , INTENT(IN) :: FIRA   !total net longwave rad (w/m2)  [+ to atm]
    1081. 

  1081.   REAL                           , INTENT(IN) :: FSH    !total sensible heat (w/m2)     [+ to atm]
    1082. 

  1082.   REAL                           , INTENT(IN) :: FCEV   !canopy evaporation heat (w/m2) [+ to atm]
    1083. 

  1083.   REAL                           , INTENT(IN) :: FGEV   !ground evaporation heat (w/m2) [+ to atm]
    1084. 

  1084.   REAL                           , INTENT(IN) :: FCTR   !transpiration heat flux (w/m2) [+ to atm]
    1085. 

  1085.   REAL                           , INTENT(IN) :: SSOIL  !ground heat flux (w/m2)        [+ to soil]
    1086. 

  1086.   REAL                           , INTENT(IN) :: FVEG
    1087. 

  1087.   REAL                           , INTENT(IN) :: SAV
    1088. 

  1088.   REAL                           , INTENT(IN) :: SAG
    1089. 

  1089.   REAL                           , INTENT(IN) :: FSRV
    1090. 

  1090.   REAL                           , INTENT(IN) :: FSRG
    1091. 

  1091. 

  1092.   REAL                           , INTENT(IN) :: PRCP   !precipitation rate (kg m-2 s-1)
    1093. 

  1093.   REAL                           , INTENT(IN) :: ECAN   !evaporation of intercepted water (mm/s)
    1094. 

  1094.   REAL                           , INTENT(IN) :: ETRAN  !transpiration rate (mm/s)
    1095. 

  1095.   REAL                           , INTENT(IN) :: EDIR   !soil surface evaporation rate[mm/s]
    1096. 

  1096.   REAL                           , INTENT(IN) :: RUNSRF !surface runoff [mm/s] 
    1097. 

  1097.   REAL                           , INTENT(IN) :: RUNSUB !baseflow (saturation excess) [mm/s]
    1098. 

  1098.   REAL                           , INTENT(IN) :: CANLIQ !intercepted liquid water (mm)
    1099. 

  1099.   REAL                           , INTENT(IN) :: CANICE !intercepted ice mass (mm)
    1100. 

  1100.   REAL                           , INTENT(IN) :: SNEQV  !snow water eqv. [mm]
    1101. 

  1101.   REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SMC    !soil moisture (ice + liq.) [m3/m3]
    1102. 

  1102.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m]
    1103. 

  1103.   REAL                           , INTENT(IN) :: WA     !water storage in aquifer [mm]
    1104. 

  1104.   REAL                           , INTENT(IN) :: DT     !time step [sec]
    1105. 

  1105.   REAL                           , INTENT(IN) :: BEG_WB !water storage at begin of a timesetp [mm]
    1106. 

  1106.   REAL                           , INTENT(OUT) :: ERRWAT !error in water balance [mm/timestep]
    1107. 

  1107. 

  1108.   INTEGER                                     :: IZ     !do-loop index
    1109. 

  1109.   REAL                                        :: END_WB !water storage at end of a timestep [mm]
    1110. 

  1110.   !KWM REAL                                        :: ERRWAT !error in water balance [mm/timestep]
    1111. 

  1111.   REAL                                        :: ERRENG !error in surface energy balance [w/m2]
    1112. 

  1112.   REAL                                        :: ERRSW  !error in shortwave radiation balance [w/m2]
    1113. 

  1113.   REAL                                        :: FSRVG
    1114. 

  1114.   CHARACTER(len=256)                          :: message
    1115. 

  1115. ! --------------------------------------------------------------------------------------------------
    1116. 

  1116. !jref:start
    1117. 

  1117. !   ERRSW   = SWDOWN - (FSA + FSR)
    1118. 

  1118.    ERRSW   = SWDOWN - (SAV+SAG + FSRV+FSRG)
    1119. 

  1119.  !  WRITE(*,*) "ERRSW =",ERRSW
    1120. 

  1120.    IF (ERRSW > 0.01) THEN            ! w/m2
    1121. 

  1121.    WRITE(*,*) "VEGETATION!"
    1122. 

  1122.    WRITE(*,*) "SWDOWN*FVEG =",SWDOWN*FVEG
    1123. 

  1123.    WRITE(*,*) "FVEG*(SAV+SAG) =",FVEG*SAV + SAG
    1124. 

  1124.    WRITE(*,*) "FVEG*(FSRV +FSRG)=",FVEG*FSRV + FSRG
    1125. 

  1125.    WRITE(*,*) "GROUND!"
    1126. 

  1126.    WRITE(*,*) "(1-.FVEG)*SWDOWN =",(1.-FVEG)*SWDOWN
    1127. 

  1127.    WRITE(*,*) "(1.-FVEG)*SAG =",(1.-FVEG)*SAG
    1128. 

  1128.    WRITE(*,*) "(1.-FVEG)*FSRG=",(1.-FVEG)*FSRG
    1129. 

  1129.    WRITE(*,*) "FSRV   =",FSRV
    1130. 

  1130.    WRITE(*,*) "FSRG   =",FSRG
    1131. 

  1131.    WRITE(*,*) "FSR    =",FSR
    1132. 

  1132.    WRITE(*,*) "SAV    =",SAV
    1133. 

  1133.    WRITE(*,*) "SAG    =",SAG
    1134. 

  1134.    WRITE(*,*) "FSA    =",FSA
    1135. 

  1135. !jref:end   
    1136. 

  1136.       WRITE(message,*) 'ERRSW =',ERRSW
    1137. 

  1137.       call wrf_message(trim(message))
    1138. 

  1138.       call wrf_error_fatal("Stop in Noah-MP")
    1139. 

  1139.    END IF
    1140. 

  1140. 

  1141. !jref:start - FSA changed to FVEG(SAV+SAG)+(1-FVEG)*SAG
    1142. 

  1142.    ERRENG = FVEG*SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL)
    1143. 

  1143. !   WRITE(*,*) "ERRENG =",ERRENG
    1144. 

  1144.    IF(ERRENG > 0.01) THEN
    1145. 

  1145.       write(message,*) 'ERRENG =',ERRENG
    1146. 

  1146.       call wrf_message(trim(message))
    1147. 

  1147.       WRITE(message,'(i6,1x,i6,1x,7F10.4)')ILOC,JLOC,FSA,FIRA,FSH,FCEV,FGEV,FCTR,SSOIL
    1148. 

  1148.       call wrf_message(trim(message))
    1149. 

  1149.       call wrf_error_fatal("Energy budget problem in NOAHMP LSM")
    1150. 

  1150.    END IF
    1151. 

  1151. 

  1152.    IF (IST == 1) THEN                                       !soil
    1153. 

  1153.         END_WB = CANLIQ + CANICE + SNEQV + WA
    1154. 

  1154.         DO IZ = 1,NSOIL
    1155. 

  1155.           END_WB = END_WB + SMC(IZ) * DZSNSO(IZ) * 1000.
    1156. 

  1156.         END DO
    1157. 

  1157.         ERRWAT = END_WB-BEG_WB-(PRCP-ECAN-ETRAN-EDIR-RUNSRF-RUNSUB)*DT
    1158. 

  1158. 

  1159.         IF(ABS(ERRWAT) > 0.1) THEN
    1160. 

  1160.            if (ERRWAT > 0) then
    1161. 

  1161.               call wrf_message ('The model is gaining water (ERRWAT is positive)')
    1162. 

  1162.            else
    1163. 

  1163.               call wrf_message('The model is losing water (ERRWAT is negative)')
    1164. 

  1164.            endif
    1165. 

  1165.            write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}"
    1166. 

  1166.            call wrf_message(trim(message))
    1167. 

  1167.            WRITE(message,'("    I      J     END_WB     BEG_WB       PRCP       ECAN       EDIR      ETRAN      RUNSRF     RUNSUB")')
    1168. 

  1168.            call wrf_message(trim(message))
    1169. 

  1169.            WRITE(message,'(i6,1x,i6,1x,2f15.3,8f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,&
    1170. 

  1170.                 EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT
    1171. 

  1171.            call wrf_message(trim(message))
    1172. 

  1172.            call wrf_error_fatal("Water budget problem in NOAHMP LSM")
    1173. 

  1173.         END IF
    1174. 

  1174.    ELSE                 !KWM
    1175. 

  1175.       ERRWAT = 0.0      !KWM
    1176. 

  1176.    ENDIF
    1177. 

  1177. 

  1178.  END SUBROUTINE ERROR
    1179. 

  1179. ! ==================================================================================================
    1180. 

  1180. ! --------------------------------------------------------------------------------------------------
    1181. 

  1181.   SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
    1182. 

  1182.                      ISNOW  ,NROOT  ,DT     ,RHOAIR ,SFCPRS ,QAIR   , & !in
    1183. 

  1183.                      SFCTMP ,THAIR  ,LWDN   ,UU     ,VV     ,ZREF   , & !in
    1184. 

  1184.                      CO2AIR ,O2AIR  ,SOLAD  ,SOLAI  ,COSZ   ,IGS    , & !in
    1185. 

  1185.                      EAIR   ,HTOP   ,TBOT   ,ZBOT   ,ZSNSO  ,ZSOIL  , & !in
    1186. 

  1186.                      ELAI   ,ESAI   ,CSOIL  ,FWET   ,FOLN   ,         & !in
    1187. 

  1187.                      FVEG   ,                                         & !in
    1188. 

  1188.                      QSNOW  ,DZSNSO ,LAT    ,CANLIQ ,CANICE ,ILOC   , JLOC, & !in
    1189. 

  1189.                      IMELT  ,SNICEV ,SNLIQV ,EPORE  ,T2M    ,FSNO   , & !out
    1190. 

  1190.                      SAV    ,SAG    ,QMELT  ,FSA    ,FSR    ,TAUX   , & !out
    1191. 

  1191.                      TAUY   ,FIRA   ,FSH    ,FCEV   ,FGEV   ,FCTR   , & !out
    1192. 

  1192.                      TRAD   ,PSN    ,APAR   ,SSOIL  ,BTRANI ,BTRAN  , & !out
    1193. 

  1193.                      PONDING,TS     ,LATHEA ,                         & !out
    1194. 

  1194.                      TV     ,TG     ,STC    ,SNOWH  ,EAH    ,TAH    , & !inout
    1195. 

  1195.                      SNEQVO ,SNEQV  ,SH2O   ,SMC    ,SNICE  ,SNLIQ  , & !inout
    1196. 

  1196.                      ALBOLD ,CM     ,CH     ,DX     ,DZ8W   ,Q2     , &   !inout
    1197. 

  1197. !jref:start
    1198. 

  1198.                      QC     ,PBLH   ,QSFC   ,PSFC   ,ISURBAN,IZ0TLND, & !in 
    1199. 

  1199.                      CHSTAR ,TSTAR  ,T2MV   ,T2MB   ,FSRV   , &
    1200. 

  1200.                      FSRG   ,RSSUN  ,RSSHA  ,BGAP   ,WGAP,GAP,TGV,TGB,&
    1201. 

  1201.                      Q1     ,Q2V    ,Q2B    ,Q2E    ,CHV  ,CHB, EMISSI )   !out 
    1202. 

  1202. !jref:end                            
    1203. 

  1203. 

  1204. ! --------------------------------------------------------------------------------------------------
    1205. 

  1205. ! --------------------------------------------------------------------------------------------------
    1206. 

  1206.   USE NOAHMP_VEG_PARAMETERS
    1207. 

  1207.   USE NOAHMP_RAD_PARAMETERS
    1208. 

  1208. ! --------------------------------------------------------------------------------------------------
    1209. 

  1209. ! we use different approaches to deal with subgrid features of radiation transfer and turbulent
    1210. 

  1210. ! transfer. We use 'tile' approach to compute turbulent fluxes, while we use modified two-
    1211. 

  1211. ! stream to compute radiation transfer. Tile approach, assemblying vegetation canopies together,
    1212. 

  1212. ! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. The
    1213. 

  1213. ! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree
    1214. 

  1214. ! crowns.
    1215. 

  1215. ! --------------------------------------------------------------------------------------------------
    1216. 

  1216. ! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and
    1217. 

  1217. !                         bare fraction separately and then sum them up weighted by fraction
    1218. 

  1218. !                     --------------------------------------
    1219. 

  1219. !                    / O  O  O  O  O  O  O  O  /          / 
    1220. 

  1220. !                   /  |  |  |  |  |  |  |  | /          /
    1221. 

  1221. !                  / O  O  O  O  O  O  O  O  /          /
    1222. 

  1222. !                 /  |  |  |tile1|  |  |  | /  tile2   /
    1223. 

  1223. !                / O  O  O  O  O  O  O  O  /  bare    /
    1224. 

  1224. !               /  |  |  | vegetated |  | /          /
    1225. 

  1225. !              / O  O  O  O  O  O  O  O  /          /
    1226. 

  1226. !             /  |  |  |  |  |  |  |  | /          /
    1227. 

  1227. !            --------------------------------------
    1228. 

  1228. ! --------------------------------------------------------------------------------------------------
    1229. 

  1229. ! radiation transfer : modified two-stream (Yang and Friedl, 2003, JGR; Niu ang Yang, 2004, JGR)
    1230. 

  1230. !                     --------------------------------------  two-stream treats leaves as
    1231. 

  1231. !                    /   O   O   O   O   O   O   O   O    /  cloud over the entire grid-cell,
    1232. 

  1232. !                   /    |   |   |   |   |   |   |   |   / while the modified two-stream 
    1233. 

  1233. !                  /   O   O   O   O   O   O   O   O    / aggregates cloudy leaves into  
    1234. 

  1234. !                 /    |   |   |   |   |   |   |   |   / tree crowns with gaps (as shown in
    1235. 

  1235. !                /   O   O   O   O   O   O   O   O    / the left figure). We assume these
    1236. 

  1236. !               /    |   |   |   |   |   |   |   |   / tree crowns are evenly distributed
    1237. 

  1237. !              /   O   O   O   O   O   O   O   O    / within the gridcell with 100% veg
    1238. 

  1238. !             /    |   |   |   |   |   |   |   |   / fraction, but with gaps. The 'tile'
    1239. 

  1239. !            -------------------------------------- approach overlaps too much shadows.
    1240. 

  1240. ! --------------------------------------------------------------------------------------------------
    1241. 

  1241.   IMPLICIT NONE
    1242. 

  1242. ! --------------------------------------------------------------------------------------------------
    1243. 

  1243. ! inputs
    1244. 

  1244.   integer                           , INTENT(IN)    :: ILOC
    1245. 

  1245.   integer                           , INTENT(IN)    :: JLOC
    1246. 

  1246.   INTEGER                           , INTENT(IN)    :: ICE    !ice (ice = 1)
    1247. 

  1247.   INTEGER                           , INTENT(IN)    :: VEGTYP !vegetation physiology type
    1248. 

  1248.   INTEGER                           , INTENT(IN)    :: IST    !surface type: 1->soil; 2->lake
    1249. 

  1249.   INTEGER                           , INTENT(IN)    :: ISC    !soil color type (1-lighest; 8-darkest)
    1250. 

  1250.   INTEGER                           , INTENT(IN)    :: NSNOW  !maximum no. of snow layers        
    1251. 

  1251.   INTEGER                           , INTENT(IN)    :: NSOIL  !number of soil layers
    1252. 

  1252.   INTEGER                           , INTENT(IN)    :: NROOT  !number of root layers
    1253. 

  1253.   INTEGER                           , INTENT(IN)    :: ISNOW  !actual no. of snow layers
    1254. 

  1254.   REAL                              , INTENT(IN)    :: DT     !time step [sec]
    1255. 

  1255.   REAL                              , INTENT(IN)    :: QSNOW  !snowfall on the ground (mm/s)
    1256. 

  1256.   REAL                              , INTENT(IN)    :: RHOAIR !density air (kg/m3)
    1257. 

  1257.   REAL                              , INTENT(IN)    :: EAIR   !vapor pressure air (pa)
    1258. 

  1258.   REAL                              , INTENT(IN)    :: SFCPRS !pressure (pa)
    1259. 

  1259.   REAL                              , INTENT(IN)    :: QAIR   !specific humidity (kg/kg)
    1260. 

  1260.   REAL                              , INTENT(IN)    :: SFCTMP !air temperature (k)
    1261. 

  1261.   REAL                              , INTENT(IN)    :: THAIR  !potential temperature (k)
    1262. 

  1262.   REAL                              , INTENT(IN)    :: LWDN   !downward longwave radiation (w/m2)
    1263. 

  1263.   REAL                              , INTENT(IN)    :: UU     !wind speed in e-w dir (m/s)
    1264. 

  1264.   REAL                              , INTENT(IN)    :: VV     !wind speed in n-s dir (m/s)
    1265. 

  1265.   REAL   , DIMENSION(       1:    2), INTENT(IN)    :: SOLAD  !incoming direct solar rad. (w/m2)
    1266. 

  1266.   REAL   , DIMENSION(       1:    2), INTENT(IN)    :: SOLAI  !incoming diffuse solar rad. (w/m2)
    1267. 

  1267.   REAL                              , INTENT(IN)    :: COSZ   !cosine solar zenith angle (0-1)
    1268. 

  1268.   REAL                              , INTENT(IN)    :: ELAI   !LAI adjusted for burying by snow
    1269. 

  1269.   REAL                              , INTENT(IN)    :: ESAI   !LAI adjusted for burying by snow
    1270. 

  1270.   REAL                              , INTENT(IN)    :: CSOIL  !vol. soil heat capacity [j/m3/k]
    1271. 

  1271.   REAL                              , INTENT(IN)    :: FWET   !fraction of canopy that is wet [-]
    1272. 

  1272.   REAL                              , INTENT(IN)    :: HTOP   !top of canopy layer (m)
    1273. 

  1273.   REAL                              , INTENT(IN)    :: FVEG   !greeness vegetation fraction (-)
    1274. 

  1274.   REAL                              , INTENT(IN)    :: LAT    !latitude (radians)
    1275. 

  1275.   REAL                              , INTENT(IN)    :: CANLIQ !canopy-intercepted liquid water (mm)
    1276. 

  1276.   REAL                              , INTENT(IN)    :: CANICE !canopy-intercepted ice mass (mm)
    1277. 

  1277.   REAL                              , INTENT(IN)    :: FOLN   !foliage nitrogen (%)
    1278. 

  1278.   REAL                              , INTENT(IN)    :: CO2AIR !atmospheric co2 concentration (pa)
    1279. 

  1279.   REAL                              , INTENT(IN)    :: O2AIR  !atmospheric o2 concentration (pa)
    1280. 

  1280.   REAL                              , INTENT(IN)    :: IGS    !growing season index (0=off, 1=on)
    1281. 

  1281. 

  1282.   REAL                              , INTENT(IN)    :: ZREF   !reference height (m)
    1283. 

  1283.   REAL                              , INTENT(IN)    :: TBOT   !bottom condition for soil temp. (k) 
    1284. 

  1284.   REAL                              , INTENT(IN)    :: ZBOT   !depth for TBOT [m]
    1285. 

  1285.   REAL   , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)    :: ZSNSO  !layer-bottom depth from snow surf [m]
    1286. 

  1286.   REAL   , DIMENSION(       1:NSOIL), INTENT(IN)    :: ZSOIL  !layer-bottom depth from soil surf [m]
    1287. 

  1287.   REAL   , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)    :: DZSNSO !depth of snow & soil layer-bottom [m]
    1288. 

  1288. 

  1289. !jref:start; in 
    1290. 

  1290.   INTEGER                           , INTENT(IN)    :: ISURBAN
    1291. 

  1291.   INTEGER                           , INTENT(IN)    :: IZ0TLND
    1292. 

  1292.   REAL                              , INTENT(IN)    :: QC     !cloud water mixing ratio
    1293. 

  1293.   REAL                              , INTENT(IN)    :: PBLH   !planetary boundary layer height
    1294. 

  1294.   REAL                              , INTENT(INOUT) :: QSFC   !mixing ratio at lowest model layer
    1295. 

  1295.   REAL                              , INTENT(IN)    :: PSFC   !pressure at lowest model layer
    1296. 

  1296.   REAL                              , INTENT(IN)    :: DX     !horisontal resolution
    1297. 

  1297.   REAL                              , INTENT(IN)    :: DZ8W   !thickness of lowest layer
    1298. 

  1298.   REAL                              , INTENT(IN)    :: Q2     !mixing ratio (kg/kg)
    1299. 

  1299. !jref:end
    1300. 

  1300. 

  1301. ! outputs
    1302. 

  1302.   INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT)   :: IMELT  !phase change index [1-melt; 2-freeze]
    1303. 

  1303.   REAL   , DIMENSION(-NSNOW+1:    0), INTENT(OUT)   :: SNICEV !partial volume ice [m3/m3]
    1304. 

  1304.   REAL   , DIMENSION(-NSNOW+1:    0), INTENT(OUT)   :: SNLIQV !partial volume liq. water [m3/m3]
    1305. 

  1305.   REAL   , DIMENSION(-NSNOW+1:    0), INTENT(OUT)   :: EPORE  !effective porosity [m3/m3]
    1306. 

  1306.   REAL                              , INTENT(OUT)   :: FSNO   !snow cover fraction (-)
    1307. 

  1307.   REAL                              , INTENT(OUT)   :: QMELT  !snowmelt [mm/s]
    1308. 

  1308.   REAL                              , INTENT(OUT)   :: PONDING!pounding at ground [mm]
    1309. 

  1309.   REAL                              , INTENT(OUT)   :: SAV    !solar rad. absorbed by veg. (w/m2)
    1310. 

  1310.   REAL                              , INTENT(OUT)   :: SAG    !solar rad. absorbed by ground (w/m2)
    1311. 

  1311.   REAL                              , INTENT(OUT)   :: FSA    !tot. absorbed solar radiation (w/m2)
    1312. 

  1312.   REAL                              , INTENT(OUT)   :: FSR    !tot. reflected solar radiation (w/m2)
    1313. 

  1313.   REAL                              , INTENT(OUT)   :: TAUX   !wind stress: e-w (n/m2)
    1314. 

  1314.   REAL                              , INTENT(OUT)   :: TAUY   !wind stress: n-s (n/m2)
    1315. 

  1315.   REAL                              , INTENT(OUT)   :: FIRA   !total net LW. rad (w/m2)   [+ to atm]
    1316. 

  1316.   REAL                              , INTENT(OUT)   :: FSH    !total sensible heat (w/m2) [+ to atm]
    1317. 

  1317.   REAL                              , INTENT(OUT)   :: FCEV   !canopy evaporation (w/m2)  [+ to atm]
    1318. 

  1318.   REAL                              , INTENT(OUT)   :: FGEV   !ground evaporation (w/m2)  [+ to atm]
    1319. 

  1319.   REAL                              , INTENT(OUT)   :: FCTR   !transpiration (w/m2)       [+ to atm]
    1320. 

  1320.   REAL                              , INTENT(OUT)   :: TRAD   !radiative temperature (k)
    1321. 

  1321.   REAL                              , INTENT(OUT)   :: T2M    !2 m height air temperature (k)
    1322. 

  1322.   REAL                              , INTENT(OUT)   :: PSN    !total photosyn. (umolco2/m2/s) [+]
    1323. 

  1323.   REAL                              , INTENT(OUT)   :: APAR   !total photosyn. active energy (w/m2)
    1324. 

  1324.   REAL                              , INTENT(OUT)   :: SSOIL  !ground heat flux (w/m2)   [+ to soil]
    1325. 

  1325.   REAL   , DIMENSION(       1:NSOIL), INTENT(OUT)   :: BTRANI !soil water transpiration factor (0-1)
    1326. 

  1326.   REAL                              , INTENT(OUT)   :: BTRAN  !soil water transpiration factor (0-1)
    1327. 

  1327.   REAL                              , INTENT(OUT)   :: LATHEA !latent heat vap./sublimation (j/kg)
    1328. 

  1328. 

  1329. !jref:start  
    1330. 

  1330.   REAL                              , INTENT(OUT)   :: FSRV    !veg. reflected solar radiation (w/m2)
    1331. 

  1331.   REAL                              , INTENT(OUT)   :: FSRG    !ground reflected solar radiation (w/m2)
    1332. 

  1332.   REAL, INTENT(OUT) :: RSSUN        !sunlit leaf stomatal resistance (s/m)
    1333. 

  1333.   REAL, INTENT(OUT) :: RSSHA        !shaded leaf stomatal resistance (s/m)
    1334. 

  1334. !jref:end - out for debug  
    1335. 

  1335. 

  1336. !jref:start; output
    1337. 

  1337.   REAL                              , INTENT(OUT)   :: CHSTAR !effective exchange coefficient
    1338. 

  1338.   REAL                              , INTENT(OUT)   :: TSTAR  !effective skin temperature
    1339. 

  1339.   REAL                              , INTENT(OUT)   :: T2MV   !2-m air temperature over vegetated part [k]
    1340. 

  1340.   REAL                              , INTENT(OUT)   :: T2MB   !2-m air temperature over bare ground part [k]
    1341. 

  1341.   REAL                              , INTENT(OUT)   :: BGAP
    1342. 

  1342.   REAL                              , INTENT(OUT)   :: WGAP
    1343. 

  1343.   REAL                              , INTENT(OUT)   :: GAP
    1344. 

  1344. !jref:end
    1345. 

  1345. 

  1346. ! input & output
    1347. 

  1347.   REAL                              , INTENT(INOUT) :: TS     !surface temperature (k)
    1348. 

  1348.   REAL                              , INTENT(INOUT) :: TV     !vegetation temperature (k)
    1349. 

  1349.   REAL                              , INTENT(INOUT) :: TG     !ground temperature (k)
    1350. 

  1350.   REAL   , DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC    !snow/soil temperature [k]
    1351. 

  1351.   REAL                              , INTENT(INOUT) :: SNOWH  !snow height [m]
    1352. 

  1352.   REAL                              , INTENT(INOUT) :: SNEQV  !snow mass (mm)
    1353. 

  1353.   REAL                              , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm)
    1354. 

  1354.   REAL   , DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O   !liquid soil moisture [m3/m3]
    1355. 

  1355.   REAL   , DIMENSION(       1:NSOIL), INTENT(INOUT) :: SMC    !soil moisture (ice + liq.) [m3/m3]
    1356. 

  1356.   REAL   , DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE  !snow ice mass (kg/m2)
    1357. 

  1357.   REAL   , DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ  !snow liq mass (kg/m2)
    1358. 

  1358.   REAL                              , INTENT(INOUT) :: EAH    !canopy air vapor pressure (pa)
    1359. 

  1359.   REAL                              , INTENT(INOUT) :: TAH    !canopy air temperature (k)
    1360. 

  1360.   REAL                              , INTENT(INOUT) :: ALBOLD !snow albedo at last time step(CLASS type)
    1361. 

  1361.   REAL                              , INTENT(INOUT) :: CM     !momentum drag coefficient
    1362. 

  1362.   REAL                              , INTENT(INOUT) :: CH     !sensible heat exchange coefficient
    1363. 

  1363.   REAL                              , INTENT(INOUT) :: Q1
    1364. 

  1364. !  REAL                                              :: Q2E
    1365. 

  1365.   REAL,                               INTENT(OUT)   :: EMISSI
    1366. 

  1366. 

  1367. ! local
    1368. 

  1368.   INTEGER                                           :: IZ     !do-loop index
    1369. 

  1369.   LOGICAL                                           :: VEG    !true if vegetated surface
    1370. 

  1370.   REAL                                              :: UR     !wind speed at height ZLVL (m/s)
    1371. 

  1371.   REAL                                              :: ZLVL   !reference height (m)
    1372. 

  1372.   REAL                                              :: FSUN   !sunlit fraction of canopy [-]
    1373. 

  1373.   REAL                                              :: RB     !leaf boundary layer resistance (s/m)
    1374. 

  1374.   REAL                                              :: RSURF  !ground surface resistance (s/m)
    1375. 

  1375.   REAL                                              :: L_RSURF!Dry-layer thickness for computing RSURF (Sakaguchi and Zeng, 2009)
    1376. 

  1376.   REAL                                              :: D_RSURF!Reduced vapor diffusivity in soil for computing RSURF (SZ09)
    1377. 

  1377.   REAL                                              :: BEVAP  !soil water evaporation factor (0- 1)
    1378. 

  1378.   REAL                                              :: MOL    !Monin-Obukhov length (m)
    1379. 

  1379.   REAL                                              :: VAI    !sum of LAI  + stem area index [m2/m2]
    1380. 

  1380.   REAL                                              :: CWP    !canopy wind extinction parameter
    1381. 

  1381.   REAL                                              :: ZPD    !zero plane displacement (m)
    1382. 

  1382.   REAL                                              :: Z0M    !z0 momentum (m)
    1383. 

  1383.   REAL                                              :: ZPDG   !zero plane displacement (m)
    1384. 

  1384.   REAL                                              :: Z0MG   !z0 momentum, ground (m)
    1385. 

  1385.   REAL                                              :: EMV    !vegetation emissivity
    1386. 

  1386.   REAL                                              :: EMG    !ground emissivity
    1387. 

  1387.   REAL                                              :: FIRE   !emitted IR (w/m2)
    1388. 

  1388. 

  1389.   REAL                                              :: LAISUN !sunlit leaf area index (m2/m2)
    1390. 

  1390.   REAL                                              :: LAISHA !shaded leaf area index (m2/m2)
    1391. 

  1391.   REAL                                              :: PSNSUN !sunlit photosynthesis (umolco2/m2/s)
    1392. 

  1392.   REAL                                              :: PSNSHA !shaded photosynthesis (umolco2/m2/s)
    1393. 

  1393. !jref:start - for debug  
    1394. 

  1394. !  REAL                                              :: RSSUN  !sunlit stomatal resistance (s/m)
    1395. 

  1395. !  REAL                                              :: RSSHA  !shaded stomatal resistance (s/m)
    1396. 

  1396. !jref:end - for debug
    1397. 

  1397.   REAL                                              :: PARSUN !par absorbed per sunlit LAI (w/m2)
    1398. 

  1398.   REAL                                              :: PARSHA !par absorbed per shaded LAI (w/m2)
    1399. 

  1399. 

  1400.   REAL, DIMENSION(-NSNOW+1:NSOIL)                   :: FACT   !temporary used in phase change
    1401. 

  1401.   REAL, DIMENSION(-NSNOW+1:NSOIL)                   :: DF     !thermal conductivity [w/m/k]
    1402. 

  1402.   REAL, DIMENSION(-NSNOW+1:NSOIL)                   :: HCPCT  !heat capacity [j/m3/k]
    1403. 

  1403.   REAL                                              :: BDSNO  !bulk density of snow (kg/m3)
    1404. 

  1404.   REAL                                              :: FMELT  !melting factor for snow cover frac
    1405. 

  1405.   REAL                                              :: GX     !temporary variable
    1406. 

  1406.   REAL, DIMENSION(-NSNOW+1:NSOIL)                   :: PHI    !light through water (w/m2)
    1407. 

  1407.   REAL                                              :: GAMMA  !psychrometric constant (pa/k)
    1408. 

  1408.   REAL                                              :: PSI    !surface layer soil matrix potential (m)
    1409. 

  1409.   REAL                                              :: RHSUR  !raltive humidity in surface soil/snow air space (-)
    1410. 

  1410. 

  1411. ! temperature and fluxes over vegetated fraction
    1412. 

  1412. 

  1413.   REAL                                              :: TAUXV  !wind stress: e-w dir [n/m2]
    1414. 

  1414.   REAL                                              :: TAUYV  !wind stress: n-s dir [n/m2]
    1415. 

  1415.   REAL                                              :: IRC    !canopy net LW rad. [w/m2] [+ to atm]
    1416. 

  1416.   REAL                                              :: IRG    !ground net LW rad. [w/m2] [+ to atm]
    1417. 

  1417.   REAL                                              :: SHC    !canopy sen. heat [w/m2]   [+ to atm]
    1418. 

  1418.   REAL                                              :: SHG    !ground sen. heat [w/m2]   [+ to atm]
    1419. 

  1419. !jref:start  
    1420. 

  1420.   REAL,INTENT(OUT)                                  :: Q2V
    1421. 

  1421.   REAL,INTENT(OUT)                                  :: Q2B
    1422. 

  1422.   REAL,INTENT(OUT)                                  :: Q2E
    1423. 

  1423. !jref:end  
    1424. 

  1424.   REAL                                              :: EVC    !canopy evap. heat [w/m2]  [+ to atm]
    1425. 

  1425.   REAL                                              :: EVG    !ground evap. heat [w/m2]  [+ to atm]
    1426. 

  1426.   REAL                                              :: TR     !transpiration heat [w/m2] [+ to atm]
    1427. 

  1427.   REAL                                              :: GHV    !ground heat flux [w/m2]  [+ to soil]
    1428. 

  1428.   REAL,INTENT(OUT)                                  :: TGV    !ground surface temp. [k]
    1429. 

  1429.   REAL                                              :: CMV    !momentum drag coefficient
    1430. 

  1430.   REAL,INTENT(OUT)                                  :: CHV    !sensible heat exchange coefficient
    1431. 

  1431. 

  1432. ! temperature and fluxes over bare soil fraction
    1433. 

  1433. 

  1434.   REAL                                              :: TAUXB  !wind stress: e-w dir [n/m2]
    1435. 

  1435.   REAL                                              :: TAUYB  !wind stress: n-s dir [n/m2]
    1436. 

  1436.   REAL                                              :: IRB    !net longwave rad. [w/m2] [+ to atm]
    1437. 

  1437.   REAL                                              :: SHB    !sensible heat [w/m2]     [+ to atm]
    1438. 

  1438.   REAL                                              :: EVB    !evaporation heat [w/m2]  [+ to atm]
    1439. 

  1439.   REAL                                              :: GHB    !ground heat flux [w/m2] [+ to soil]
    1440. 

  1440.   REAL,INTENT(OUT)                                  :: TGB    !ground surface temp. [k]
    1441. 

  1441.   REAL                                              :: CMB    !momentum drag coefficient
    1442. 

  1442.   REAL,INTENT(OUT)                                  :: CHB    !sensible heat exchange coefficient
    1443. 

  1443. !jref:start  
    1444. 

  1444.   REAL                                  :: CAH2    !sensible heat conductance, canopy air to ZLVL air (m/s)
    1445. 

  1445.   REAL                                  :: EHB2    !sensible heat conductance, canopy air to ZLVL air (m/s)
    1446. 

  1446.   REAL                                  :: noahmpres
    1447. 

  1447. 

  1448. !jref:end  
    1449. 

  1449. 

  1450.   REAL, PARAMETER                   :: MPE    = 1.E-6
    1451. 

  1451.   REAL, PARAMETER                   :: PSIWLT = -150.  !metric potential for wilting point (m)
    1452. 

  1452.   REAL, PARAMETER                   :: Z0     = 0.01   ! Bare-soil roughness length (m) (i.e., under the canopy)
    1453. 

  1453. 

  1454. ! ---------------------------------------------------------------------------------------------------
    1455. 

  1455. ! initialize fluxes from veg. fraction
    1456. 

  1456. 

  1457.     TAUXV     = 0.    
    1458. 

  1458.     TAUYV     = 0.
    1459. 

  1459.     IRC       = 0.
    1460. 

  1460.     SHC       = 0.
    1461. 

  1461.     IRG       = 0.
    1462. 

  1462.     SHG       = 0.
    1463. 

  1463.     EVG       = 0.       
    1464. 

  1464.     EVC       = 0.
    1465. 

  1465.     TR        = 0.
    1466. 

  1466.     GHV       = 0.       
    1467. 

  1467.     PSNSUN    = 0.
    1468. 

  1468.     PSNSHA    = 0.
    1469. 

  1469. 

  1470. ! wind speed at reference height: ur >= 1
    1471. 

  1471. 

  1472.     UR = MAX( SQRT(UU**2.+VV**2.), 1. )
    1473. 

  1473. 

  1474. ! vegetated or non-vegetated
    1475. 

  1475. 

  1476.     VAI = ELAI + ESAI
    1477. 

  1477.     VEG = .FALSE.
    1478. 

  1478.     IF(VAI > 0.) VEG = .TRUE.
    1479. 

  1479. 

  1480. ! ground snow cover fraction [Niu and Yang, 2007, JGR]
    1481. 

  1481. 

  1482.      FSNO = 0.
    1483. 

  1483.      IF(SNOWH.GT.0.)  THEN
    1484. 

  1484.          BDSNO    = SNEQV / SNOWH
    1485. 

  1485.          FMELT    = (BDSNO/100.)**M
    1486. 

  1486.          FSNO     = TANH( SNOWH /(2.5* Z0 * FMELT))
    1487. 

  1487.      ENDIF
    1488. 

  1488. 

  1489. ! ground roughness length
    1490. 

  1490. 

  1491.      IF(IST == 2) THEN
    1492. 

  1492.        IF(TG .LE. TFRZ) THEN
    1493. 

  1493.          Z0MG = 0.01 * (1.0-FSNO) + FSNO * Z0SNO
    1494. 

  1494.        ELSE
    1495. 

  1495.          Z0MG = 0.01  
    1496. 

  1496.        END IF
    1497. 

  1497.      ELSE
    1498. 

  1498.        Z0MG = Z0 * (1.0-FSNO) + FSNO * Z0SNO
    1499. 

  1499.      END IF
    1500. 

  1500. 

  1501. ! roughness length and displacement height
    1502. 

  1502. 

  1503.      ZPDG  = SNOWH
    1504. 

  1504.      IF(VEG) THEN
    1505. 

  1505.         Z0M  = Z0MVT(VEGTYP)
    1506. 

  1506.         ZPD  = 0.65 * HTOP
    1507. 

  1507.         IF(SNOWH.GT.ZPD) ZPD  = SNOWH
    1508. 

  1508.      ELSE
    1509. 

  1509.         Z0M  = Z0MG
    1510. 

  1510.         ZPD  = ZPDG
    1511. 

  1511.      END IF
    1512. 

  1512. 

  1513.      ZLVL = MAX(ZPD,HTOP) + ZREF
    1514. 

  1514.      IF(ZPDG >= ZLVL) ZLVL = ZPDG + ZREF
    1515. 

  1515. !     UR   = UR*LOG(ZLVL/Z0M)/LOG(10./Z0M)       !input UR is at 10m
    1516. 

  1516. 

  1517. ! canopy wind absorption coeffcient
    1518. 

  1518. 

  1519.      CWP = CWPVT(VEGTYP)
    1520. 

  1520. 

  1521. ! Thermal properties of soil, snow, lake, and frozen soil
    1522. 

  1522. 

  1523.   CALL THERMOPROP (NSOIL   ,NSNOW   ,ISNOW   ,IST     ,DZSNSO  , & !in
    1524. 

  1524.                    DT      ,SNOWH   ,SNICE   ,SNLIQ   ,CSOIL   , & !in
    1525. 

  1525.                    SMC     ,SH2O    ,TG      ,STC     ,UR      , & !in
    1526. 

  1526.                    LAT     ,Z0M     ,ZLVL    ,VEGTYP  ,ISURBAN , & !in
    1527. 

  1527.                    DF      ,HCPCT   ,SNICEV  ,SNLIQV  ,EPORE   , & !out
    1528. 

  1528.                    FACT    )                              !out
    1529. 

  1529. 

  1530. ! Solar radiation: absorbed & reflected by the ground and canopy
    1531. 

  1531. 

  1532.   CALL  RADIATION (VEGTYP  ,IST     ,ISC     ,ICE     ,NSOIL   , & !in 
    1533. 

  1533.                    SNEQVO  ,SNEQV   ,DT      ,COSZ    ,SNOWH   , & !in
    1534. 

  1534.                    TG      ,TV      ,FSNO    ,QSNOW   ,FWET    , & !in
    1535. 

  1535.                    ELAI    ,ESAI    ,SMC     ,SOLAD   ,SOLAI   , & !in
    1536. 

  1536.                    FVEG    ,ILOC    ,JLOC    ,                   & !in
    1537. 

  1537.                    ALBOLD  ,                                     & !inout
    1538. 

  1538.                    FSUN    ,LAISUN  ,LAISHA  ,PARSUN  ,PARSHA  , & !out
    1539. 

  1539.                    SAV     ,SAG     ,FSR     ,FSA     ,FSRV    , & 
    1540. 

  1540.                    FSRG    ,BGAP    ,WGAP    ,GAP)            !out
    1541. 

  1541. 

  1542. ! vegetation and ground emissivity
    1543. 

  1543. 

  1544.      EMV = 1. - EXP(-(ELAI+ESAI)/1.0)
    1545. 

  1545.      IF (ICE == 1) THEN
    1546. 

  1546.        EMG = 0.98*(1.-FSNO) + 1.0*FSNO
    1547. 

  1547.      ELSE
    1548. 

  1548.        EMG = EG(IST)*(1.-FSNO) + 1.0*FSNO
    1549. 

  1549.      END IF
    1550. 

  1550. 

  1551. ! soil moisture factor controlling stomatal resistance
    1552. 

  1552.    
    1553. 

  1553.      BTRAN = 0.
    1554. 

  1554. 

  1555.      IF(IST ==1 ) THEN
    1556. 

  1556.        DO IZ = 1, NROOT
    1557. 

  1557.           IF(OPT_BTR == 1) then                  ! Noah
    1558. 

  1558.             GX    = (SH2O(IZ)-SMCWLT) / (SMCREF-SMCWLT)
    1559. 

  1559.           END IF
    1560. 

  1560.           IF(OPT_BTR == 2) then                  ! CLM
    1561. 

  1561.             PSI   = MAX(PSIWLT,-PSISAT*(MAX(0.01,SH2O(IZ))/SMCMAX)**(-BEXP) )
    1562. 

  1562.             GX    = (1.-PSI/PSIWLT)/(1.+PSISAT/PSIWLT)
    1563. 

  1563.           END IF
    1564. 

  1564.           IF(OPT_BTR == 3) then                  ! SSiB
    1565. 

  1565.             PSI   = MAX(PSIWLT,-PSISAT*(MAX(0.01,SH2O(IZ))/SMCMAX)**(-BEXP) )
    1566. 

  1566.             GX    = 1.-EXP(-5.8*(LOG(PSIWLT/PSI))) 
    1567. 

  1567.           END IF
    1568. 

  1568.        
    1569. 

  1569.           GX = MIN(1.,MAX(0.,GX))
    1570. 

  1570.           BTRANI(IZ) = MAX(MPE,DZSNSO(IZ) / (-ZSOIL(NROOT)) * GX)
    1571. 

  1571.           BTRAN      = BTRAN + BTRANI(IZ)
    1572. 

  1572.        END DO
    1573. 

  1573.        BTRAN = MAX(MPE,BTRAN)
    1574. 

  1574. 

  1575.        BTRANI(1:NROOT) = BTRANI(1:NROOT)/BTRAN
    1576. 

  1576.      END IF
    1577. 

  1577. 

  1578. ! soil surface resistance for ground evap.
    1579. 

  1579. 

  1580.      BEVAP = MAX(0.0,SH2O(1)/SMCMAX)
    1581. 

  1581.      IF(IST == 2) THEN
    1582. 

  1582.        RSURF = 1.          ! avoid being divided by 0
    1583. 

  1583.        RHSUR = 1.0
    1584. 

  1584.      ELSE
    1585. 

  1585. 

  1586.         ! RSURF based on Sakaguchi and Zeng, 2009
    1587. 

  1587.         ! taking the "residual water content" to be the wilting point, 
    1588. 

  1588.         ! and correcting the exponent on the D term (typo in SZ09 ?)
    1589. 

  1589.         L_RSURF = (-ZSOIL(1)) * ( exp ( (1.0 - MIN(1.0,SH2O(1)/SMCMAX)) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 ) 
    1590. 

  1590.         D_RSURF = 2.2E-5 * SMCMAX * SMCMAX * ( 1.0 - SMCWLT / SMCMAX ) ** (2.0+3.0/BEXP)
    1591. 

  1591.         RSURF = L_RSURF / D_RSURF
    1592. 

  1592. 

  1593.         ! Older RSURF computations:
    1594. 

  1594.         !    RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-4.225*BEVAP) !Sellers (1992)
    1595. 

  1595.         !    RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-6.0  *BEVAP) !adjusted to decrease RSURF for wet soil
    1596. 

  1596. 

  1597.        IF(SH2O(1) < 0.01 .and. SNOWH == 0.) RSURF = 1.E6
    1598. 

  1598.        PSI   = -PSISAT*(MAX(0.01,SH2O(1))/SMCMAX)**(-BEXP)   
    1599. 

  1599.        RHSUR = FSNO + (1.-FSNO) * EXP(PSI*GRAV/(RW*TG)) 
    1600. 

  1600.      END IF
    1601. 

  1601. 

  1602. ! urban - jref 
    1603. 

  1603.      IF (VEGTYP == ISURBAN .and. SNOWH == 0. ) THEN
    1604. 

  1604.         RSURF = 1.E6
    1605. 

  1605.      ENDIF
    1606. 

  1606. 

  1607. ! set psychrometric constant
    1608. 

  1608. 

  1609.      IF (SFCTMP .GT. TFRZ) THEN
    1610. 

  1610.         LATHEA = HVAP
    1611. 

  1611.      ELSE
    1612. 

  1612.         LATHEA = HSUB
    1613. 

  1613.      END IF
    1614. 

  1614.      GAMMA = CPAIR*SFCPRS/(0.622*LATHEA)
    1615. 

  1615. 

  1616. ! Surface temperatures of the ground and canopy and energy fluxes
    1617. 

  1617. 

  1618.     IF (VEG) THEN 
    1619. 

  1619.     TGV = TG
    1620. 

  1620.     CMV = CM
    1621. 

  1621.     CHV = CH
    1622. 

  1622.     CALL VEGE_FLUX (NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
    1623. 

  1623.                     DT      ,SAV     ,SAG     ,LWDN    ,UR      , & !in
    1624. 

  1624.                     UU      ,VV      ,SFCTMP  ,THAIR   ,QAIR    , & !in
    1625. 

  1625.                     EAIR    ,RHOAIR  ,SNOWH   ,VAI     ,GAMMA   , & !in
    1626. 

  1626.                     FWET    ,LAISUN  ,LAISHA  ,CWP     ,DZSNSO  , & !in
    1627. 

  1627.                     HTOP    ,ZLVL    ,ZPD     ,Z0M     ,FVEG    , & !in
    1628. 

  1628.                     Z0MG    ,EMV     ,EMG     ,CANLIQ           , & !in
    1629. 

  1629.                     CANICE  ,STC     ,DF      ,RSSUN   ,RSSHA   , & !in
    1630. 

  1630.                     RSURF   ,LATHEA  ,PARSUN  ,PARSHA  ,IGS     , & !in
    1631. 

  1631.                     FOLN    ,CO2AIR  ,O2AIR   ,BTRAN   ,SFCPRS  , & !in
    1632. 

  1632.                     RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
    1633. 

  1633.                     EAH     ,TAH     ,TV      ,TGV     ,CMV     , & !inout
    1634. 

  1634.                     CHV     ,DX      ,DZ8W    ,                   & !inout
    1635. 

  1635.                     TAUXV   ,TAUYV   ,IRG     ,IRC     ,SHG     , & !out
    1636. 

  1636.                     SHC     ,EVG     ,EVC     ,TR      ,GHV     , & !out
    1637. 

  1637.                     T2MV    ,PSNSUN  ,PSNSHA  ,                   & !out
    1638. 

  1638. !jref:start
    1639. 

  1639.                     QC      ,PBLH    ,QSFC    ,PSFC    ,ISURBAN , & !in
    1640. 

  1640.                     IZ0TLND ,Q2V     ,CAH2)               !inout 
    1641. 

  1641. !jref:end                            
    1642. 

  1642.     END IF
    1643. 

  1643. 

  1644.     TGB = TG
    1645. 

  1645.     CMB = CM
    1646. 

  1646.     CHB = CH
    1647. 

  1647.     CALL BARE_FLUX (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,SAG     , & !in
    1648. 

  1648.                     LWDN    ,UR      ,UU      ,VV      ,SFCTMP  , & !in
    1649. 

  1649.                     THAIR   ,QAIR    ,EAIR    ,RHOAIR  ,SNOWH   , & !in
    1650. 

  1650.                     DZSNSO  ,ZLVL    ,ZPDG    ,Z0MG    ,          & !in
    1651. 

  1651.                     EMG     ,STC     ,DF      ,RSURF   ,LATHEA  , & !in
    1652. 

  1652.                     GAMMA   ,RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
    1653. 

  1653.                     TGB     ,CMB     ,CHB     ,                   & !inout
    1654. 

  1654.                     TAUXB   ,TAUYB   ,IRB     ,SHB     ,EVB     , & !out
    1655. 

  1655.                     GHB     ,T2MB    ,DX      ,DZ8W    ,VEGTYP  , & !out
    1656. 

  1656. !jref:start
    1657. 

  1657.                     QC      ,PBLH    ,QSFC    ,PSFC    ,ISURBAN , & !in
    1658. 

  1658.                     IZ0TLND ,SFCPRS  ,Q2B,   EHB2)                          !in 
    1659. 

  1659. !jref:end                            
    1660. 

  1660. 

  1661. !energy balance at vege canopy: SAV          =(IRC+SHC+EVC+TR)     *FVEG  at   FVEG 
    1662. 

  1662. !energy balance at vege ground: SAG*    FVEG =(IRG+SHG+EVG+GHV)    *FVEG  at   FVEG
    1663. 

  1663. !energy balance at bare ground: SAG*(1.-FVEG)=(IRB+SHB+EVB+GHB)*(1.-FVEG) at 1-FVEG
    1664. 

  1664. 

  1665.     IF (VEG) THEN 
    1666. 

  1666.         TAUX  = FVEG * TAUXV     + (1.0 - FVEG) * TAUXB
    1667. 

  1667.         TAUY  = FVEG * TAUYV     + (1.0 - FVEG) * TAUYB
    1668. 

  1668.         FIRA  = FVEG * IRG       + (1.0 - FVEG) * IRB       + FVEG * IRC
    1669. 

  1669.         FSH   = FVEG * SHG       + (1.0 - FVEG) * SHB       + FVEG * SHC
    1670. 

  1670.         FGEV  = FVEG * EVG       + (1.0 - FVEG) * EVB
    1671. 

  1671.         SSOIL = FVEG * GHV       + (1.0 - FVEG) * GHB
    1672. 

  1672.         FCEV  = FVEG * EVC
    1673. 

  1673.         FCTR  = FVEG * TR
    1674. 

  1674.         TG    = FVEG * TGV       + (1.0 - FVEG) * TGB
    1675. 

  1675.         T2M   = FVEG * T2MV      + (1.0 - FVEG) * T2MB
    1676. 

  1676.         TS    = FVEG * TV        + (1.0 - FVEG) * TGB
    1677. 

  1677.         CM    = FVEG * CMV       + (1.0 - FVEG) * CMB      ! better way to average?
    1678. 

  1678.         CH    = FVEG * CHV       + (1.0 - FVEG) * CHB
    1679. 

  1679.         Q1    = FVEG * (EAH*0.622/(SFCPRS - 0.378*EAH)) + (1.0 - FVEG)*QSFC
    1680. 

  1680.         Q2E   = FVEG * Q2V       + (1.0 - FVEG) * Q2B
    1681. 

  1681.     ELSE
    1682. 

  1682.         TAUX  = TAUXB
    1683. 

  1683.         TAUY  = TAUYB
    1684. 

  1684.         FIRA  = IRB
    1685. 

  1685.         FSH   = SHB
    1686. 

  1686.         FGEV  = EVB
    1687. 

  1687.         SSOIL = GHB
    1688. 

  1688.         TG    = TGB
    1689. 

  1689.         T2M   = T2MB
    1690. 

  1690.         FCEV  = 0.
    1691. 

  1691.         FCTR  = 0.
    1692. 

  1692.         TS    = TG
    1693. 

  1693.         CM    = CMB
    1694. 

  1694.         CH    = CHB
    1695. 

  1695.         Q1    = QSFC
    1696. 

  1696.         Q2E   = Q2B
    1697. 

  1697.     END IF
    1698. 

  1698. 

  1699.     FIRE = LWDN + FIRA
    1700. 

  1700. 

  1701.     IF(FIRE <=0.) THEN
    1702. 

  1702.        WRITE(6,*) 'emitted longwave <0; skin T may be wrong due to inconsistent'
    1703. 

  1703.        WRITE(6,*) 'input of SHDFAC with LAI'
    1704. 

  1704.        WRITE(6,*) ILOC, JLOC, 'SHDFAC=',FVEG,'VAI=',VAI,'TV=',TV,'TG=',TG
    1705. 

  1705.        WRITE(6,*) 'LWDN=',LWDN,'FIRA=',FIRA,'SNOWH=',SNOWH
    1706. 

  1706.        call wrf_error_fatal("STOP in Noah-MP")
    1707. 

  1707.     END IF
    1708. 

  1708. 

  1709.     ! Compute a net emissivity
    1710. 

  1710.     EMISSI = FVEG * ( EMG*(1-EMV) + EMV + EMV*(1-EMV)*(1-EMG) ) + &
    1711. 

  1711.          (1-FVEG) * EMG
    1712. 

  1712. 

  1713.     ! When we're computing a TRAD, subtract from the emitted IR the
    1714. 

  1714.     ! reflected portion of the incoming LWDN, so we're just
    1715. 

  1715.     ! considering the IR originating in the canopy/ground system.
    1716. 

  1716.     
    1717. 

  1717.     TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25
    1718. 

  1718. 

  1719.     ! Old TRAD calculation not taking into account Emissivity:
    1720. 

  1720.     ! TRAD = (FIRE/SB)**0.25
    1721. 

  1721. 

  1722.     APAR = PARSUN*LAISUN + PARSHA*LAISHA
    1723. 

  1723.     PSN  = PSNSUN*LAISUN + PSNSHA*LAISHA
    1724. 

  1724. 

  1725. ! effective parameters for PBL and diagnostics
    1726. 

  1726. 

  1727.     CALL EPARM(ILOC   ,JLOC   ,TAH    ,TGB    ,FVEG   ,&
    1728. 

  1728.                CHV    ,CHB    ,VEG    ,CHSTAR ,TSTAR)   !inout
    1729. 

  1729. 

  1730. ! 3L snow & 4L soil temperatures
    1731. 

  1731. 

  1732.     CALL TSNOSOI (ICE     ,NSOIL   ,NSNOW   ,ISNOW   ,IST     , & !in
    1733. 

  1733.                   TBOT    ,ZSNSO   ,SSOIL   ,DF      ,HCPCT   , & !in
    1734. 

  1734.                   ZBOT    ,SAG     ,DT      ,SNOWH   ,DZSNSO  , & !in
    1735. 

  1735.                   TG      ,ILOC    ,JLOC    ,                   & !in
    1736. 

  1736.                   STC     )                                       !inout
    1737. 

  1737. 

  1738. ! adjusting snow surface temperature
    1739. 

  1739.      IF(OPT_STC == 2) THEN
    1740. 

  1740.       IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN
    1741. 

  1741.         TGV = TFRZ
    1742. 

  1742.         TGB = TFRZ
    1743. 

  1743.           IF (VEG) THEN
    1744. 

  1744.              TG    = FVEG * TGV       + (1.0 - FVEG) * TGB
    1745. 

  1745.              TS    = FVEG * TV        + (1.0 - FVEG) * TGB
    1746. 

  1746.           ELSE
    1747. 

  1747.              TG    = TGB
    1748. 

  1748.              TS    = TGB
    1749. 

  1749.           END IF
    1750. 

  1750.       END IF
    1751. 

  1751.      END IF
    1752. 

  1752. 

  1753. ! Energy released or consumed by snow & frozen soil
    1754. 

  1754. 

  1755.  CALL PHASECHANGE (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , & !in
    1756. 

  1756.                    DZSNSO  ,HCPCT   ,IST     ,ILOC    ,JLOC    , & !in
    1757. 

  1757.                    STC     ,SNICE   ,SNLIQ   ,SNEQV   ,SNOWH   , & !inout
    1758. 

  1758.                    SMC     ,SH2O    ,                            & !inout
    1759. 

  1759.                    QMELT   ,IMELT   ,PONDING )                     !out
    1760. 

  1760. 

  1761. 

  1762.   END SUBROUTINE ENERGY
    1763. 

  1763. ! ==================================================================================================
    1764. 

  1764.   SUBROUTINE THERMOPROP (NSOIL   ,NSNOW   ,ISNOW   ,IST     ,DZSNSO  , & !in
    1765. 

  1765.                          DT      ,SNOWH   ,SNICE   ,SNLIQ   ,CSOIL   , & !in
    1766. 

  1766.                          SMC     ,SH2O    ,TG      ,STC     ,UR      , & !in
    1767. 

  1767.                          LAT     ,Z0M     ,ZLVL    ,VEGTYP  ,ISURBAN , & !in
    1768. 

  1768.                          DF      ,HCPCT   ,SNICEV  ,SNLIQV  ,EPORE   , & !out
    1769. 

  1769.                          FACT    )                                       !out
    1770. 

  1770. ! ------------------------------------------------------------------------------------------------- 
    1771. 

  1771. ! -------------------------------------------------------------------------------------------------
    1772. 

  1772.   IMPLICIT NONE
    1773. 

  1773. ! --------------------------------------------------------------------------------------------------
    1774. 

  1774. ! inputs
    1775. 

  1775.   INTEGER                        , INTENT(IN)  :: NSOIL   !number of soil layers
    1776. 

  1776.   INTEGER                        , INTENT(IN)  :: NSNOW   !maximum no. of snow layers        
    1777. 

  1777.   INTEGER                        , INTENT(IN)  :: ISNOW   !actual no. of snow layers
    1778. 

  1778.   INTEGER                        , INTENT(IN)  :: IST     !surface type
    1779. 

  1779.   REAL                           , INTENT(IN)  :: DT      !time step [s]
    1780. 

  1780.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)  :: SNICE   !snow ice mass (kg/m2)
    1781. 

  1781.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)  :: SNLIQ   !snow liq mass (kg/m2)
    1782. 

  1782.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: DZSNSO  !thickness of snow/soil layers [m]
    1783. 

  1783.   REAL, DIMENSION(       1:NSOIL), INTENT(IN)  :: SMC     !soil moisture (ice + liq.) [m3/m3]
    1784. 

  1784.   REAL, DIMENSION(       1:NSOIL), INTENT(IN)  :: SH2O    !liquid soil moisture [m3/m3]
    1785. 

  1785.   REAL                           , INTENT(IN)  :: SNOWH   !snow height [m]
    1786. 

  1786.   REAL                           , INTENT(IN)  :: CSOIL   !vol. soil heat capacity [j/m3/k]
    1787. 

  1787.   REAL,                            INTENT(IN)  :: TG      !surface temperature (k)
    1788. 

  1788.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: STC     !snow/soil/lake temp. (k)
    1789. 

  1789.   REAL,                            INTENT(IN)  :: UR      !wind speed at ZLVL (m/s)
    1790. 

  1790.   REAL,                            INTENT(IN)  :: LAT     !latitude (radians)
    1791. 

  1791.   REAL,                            INTENT(IN)  :: Z0M     !roughness length (m)
    1792. 

  1792.   REAL,                            INTENT(IN)  :: ZLVL    !reference height (m)
    1793. 

  1793.   INTEGER                        , INTENT(IN)  :: VEGTYP  !vegtyp type
    1794. 

  1794.   INTEGER                        , INTENT(IN)  :: ISURBAN !urban type
    1795. 

  1795. 

  1796. ! outputs
    1797. 

  1797.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF      !thermal conductivity [w/m/k]
    1798. 

  1798.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: HCPCT   !heat capacity [j/m3/k]
    1799. 

  1799.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: SNICEV  !partial volume of ice [m3/m3]
    1800. 

  1800.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: SNLIQV  !partial volume of liquid water [m3/m3]
    1801. 

  1801.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: EPORE   !effective porosity [m3/m3]
    1802. 

  1802.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: FACT    !computing energy for phase change
    1803. 

  1803. ! --------------------------------------------------------------------------------------------------
    1804. 

  1804. ! locals
    1805. 

  1805. 

  1806.   INTEGER :: IZ
    1807. 

  1807.   REAL, DIMENSION(-NSNOW+1:    0)              :: CVSNO   !volumetric specific heat (j/m3/k)
    1808. 

  1808.   REAL, DIMENSION(-NSNOW+1:    0)              :: TKSNO   !snow thermal conductivity (j/m3/k)
    1809. 

  1809.   REAL, DIMENSION(       1:NSOIL)              :: SICE    !soil ice content
    1810. 

  1810. ! --------------------------------------------------------------------------------------------------
    1811. 

  1811. 

  1812. ! compute snow thermal conductivity and heat capacity
    1813. 

  1813. 

  1814.     CALL CSNOW (ISNOW   ,NSNOW   ,NSOIL   ,SNICE   ,SNLIQ   ,DZSNSO  , & !in
    1815. 

  1815.                 TKSNO   ,CVSNO   ,SNICEV  ,SNLIQV  ,EPORE   )   !out
    1816. 

  1816. 

  1817.     DO IZ = ISNOW+1, 0
    1818. 

  1818.       DF   (IZ) = TKSNO(IZ)
    1819. 

  1819.       HCPCT(IZ) = CVSNO(IZ)
    1820. 

  1820.     END DO
    1821. 

  1821. 

  1822. ! compute soil thermal properties
    1823. 

  1823. 

  1824.     DO  IZ = 1, NSOIL
    1825. 

  1825.        SICE(IZ)  = SMC(IZ) - SH2O(IZ)
    1826. 

  1826.        HCPCT(IZ) = SH2O(IZ)*CWAT + (1.0-SMCMAX)*CSOIL &
    1827. 

  1827.                 + (SMCMAX-SMC(IZ))*CPAIR + SICE(IZ)*CICE
    1828. 

  1828.        CALL TDFCND (DF(IZ), SMC(IZ), SH2O(IZ))
    1829. 

  1829.     END DO
    1830. 

  1830.        
    1831. 

  1831.     IF ( VEGTYP == ISURBAN ) THEN
    1832. 

  1832.        DO IZ = 1,NSOIL
    1833. 

  1833.          DF(IZ) = 3.24
    1834. 

  1834.        END DO
    1835. 

  1835.     ENDIF
    1836. 

  1836. 

  1837. ! heat flux reduction effect from the overlying green canopy, adapted from 
    1838. 

  1838. ! section 2.1.2 of Peters-Lidard et al. (1997, JGR, VOL 102(D4)).
    1839. 

  1839. ! not in use because of the separation of the canopy layer from the ground.
    1840. 

  1840. ! but this may represent the effects of leaf litter (Niu comments)
    1841. 

  1841. !       DF1 = DF1 * EXP (SBETA * SHDFAC)
    1842. 

  1842. 

  1843. ! compute lake thermal properties 
    1844. 

  1844. ! (no consideration of turbulent mixing for this version)
    1845. 

  1845. 

  1846.     IF(IST == 2) THEN
    1847. 

  1847.        DO IZ = 1, NSOIL 
    1848. 

  1848.          IF(STC(IZ) > TFRZ) THEN
    1849. 

  1849.             HCPCT(IZ) = CWAT
    1850. 

  1850.             DF(IZ)    = TKWAT  !+ KEDDY * CWAT 
    1851. 

  1851.          ELSE
    1852. 

  1852.             HCPCT(IZ) = CICE
    1853. 

  1853.             DF(IZ)    = TKICE 
    1854. 

  1854.          END IF
    1855. 

  1855.        END DO
    1856. 

  1856.     END IF
    1857. 

  1857. 

  1858. ! combine a temporary variable used for melting/freezing of snow and frozen soil
    1859. 

  1859. 

  1860.     DO IZ = ISNOW+1,NSOIL
    1861. 

  1861.      FACT(IZ) = DT/(HCPCT(IZ)*DZSNSO(IZ))
    1862. 

  1862.     END DO
    1863. 

  1863. 

  1864. ! snow/soil interface
    1865. 

  1865. 

  1866.     IF(ISNOW == 0) THEN
    1867. 

  1867.        DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH)      / (SNOWH    +DZSNSO(1)) 
    1868. 

  1868.     ELSE
    1869. 

  1869.        DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1))
    1870. 

  1870.     END IF
    1871. 

  1871. 

  1872. 

  1873.   END SUBROUTINE THERMOPROP
    1874. 

  1874. ! ==================================================================================================
    1875. 

  1875. ! --------------------------------------------------------------------------------------------------
    1876. 

  1876.   SUBROUTINE CSNOW (ISNOW   ,NSNOW   ,NSOIL   ,SNICE   ,SNLIQ   ,DZSNSO  , & !in
    1877. 

  1877.                     TKSNO   ,CVSNO   ,SNICEV  ,SNLIQV  ,EPORE   )   !out
    1878. 

  1878. ! --------------------------------------------------------------------------------------------------
    1879. 

  1879. ! Snow bulk density,volumetric capacity, and thermal conductivity
    1880. 

  1880. !---------------------------------------------------------------------------------------------------
    1881. 

  1881.   IMPLICIT NONE
    1882. 

  1882. !---------------------------------------------------------------------------------------------------
    1883. 

  1883. ! inputs
    1884. 

  1884. 

  1885.   INTEGER,                          INTENT(IN) :: ISNOW  !number of snow layers (-)            
    1886. 

  1886.   INTEGER                        ,  INTENT(IN) :: NSNOW  !maximum no. of snow layers        
    1887. 

  1887.   INTEGER                        ,  INTENT(IN) :: NSOIL  !number of soil layers
    1888. 

  1888.   REAL, DIMENSION(-NSNOW+1:    0),  INTENT(IN) :: SNICE  !snow ice mass (kg/m2)
    1889. 

  1889.   REAL, DIMENSION(-NSNOW+1:    0),  INTENT(IN) :: SNLIQ  !snow liq mass (kg/m2) 
    1890. 

  1890.   REAL, DIMENSION(-NSNOW+1:NSOIL),  INTENT(IN) :: DZSNSO !snow/soil layer thickness [m]
    1891. 

  1891. 

  1892. ! outputs
    1893. 

  1893. 

  1894.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: CVSNO  !volumetric specific heat (j/m3/k)
    1895. 

  1895.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: TKSNO  !thermal conductivity (w/m/k)
    1896. 

  1896.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3]
    1897. 

  1897.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3]
    1898. 

  1898.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(OUT) :: EPORE  !effective porosity [m3/m3]
    1899. 

  1899. 

  1900. ! locals
    1901. 

  1901. 

  1902.   INTEGER :: IZ
    1903. 

  1903.   REAL, DIMENSION(-NSNOW+1:    0) :: BDSNOI  !bulk density of snow(kg/m3)
    1904. 

  1904. 

  1905. !---------------------------------------------------------------------------------------------------
    1906. 

  1906. ! thermal capacity of snow
    1907. 

  1907. 

  1908.   DO IZ = ISNOW+1, 0
    1909. 

  1909.       SNICEV(IZ)   = MIN(1., SNICE(IZ)/(DZSNSO(IZ)*DENICE) )
    1910. 

  1910.       EPORE(IZ)    = 1. - SNICEV(IZ)
    1911. 

  1911.       SNLIQV(IZ)   = MIN(EPORE(IZ),SNLIQ(IZ)/(DZSNSO(IZ)*DENH2O))
    1912. 

  1912.   ENDDO
    1913. 

  1913. 

  1914.   DO IZ = ISNOW+1, 0
    1915. 

  1915.       BDSNOI(IZ) = (SNICE(IZ)+SNLIQ(IZ))/DZSNSO(IZ)
    1916. 

  1916.       CVSNO(IZ) = CICE*SNICEV(IZ)+CWAT*SNLIQV(IZ)
    1917. 

  1917. !      CVSNO(IZ) = 0.525E06                          ! constant
    1918. 

  1918.   enddo
    1919. 

  1919. 

  1920. ! thermal conductivity of snow
    1921. 

  1921. 

  1922.   DO IZ = ISNOW+1, 0
    1923. 

  1923.      TKSNO(IZ) = 3.2217E-6*BDSNOI(IZ)**2.           ! Stieglitz(yen,1965)
    1924. 

  1924. !    TKSNO(IZ) = 2E-2+2.5E-6*BDSNOI(IZ)*BDSNOI(IZ)   ! Anderson, 1976
    1925. 

  1925. !    TKSNO(IZ) = 0.35                                ! constant
    1926. 

  1926. !    TKSNO(IZ) = 2.576E-6*BDSNOI(IZ)**2. + 0.074    ! Verseghy (1991)
    1927. 

  1927. !    TKSNO(IZ) = 2.22*(BDSNOI(IZ)/1000.)**1.88      ! Douvill(Yen, 1981)
    1928. 

  1928.   ENDDO
    1929. 

  1929. 

  1930.   END SUBROUTINE CSNOW
    1931. 

  1931. !===================================================================================================
    1932. 

  1932. ! --------------------------------------------------------------------------------------------------
    1933. 

  1933.   SUBROUTINE TDFCND ( DF, SMC, SH2O)
    1934. 

  1934. ! --------------------------------------------------------------------------------------------------
    1935. 

  1935. ! Calculate thermal diffusivity and conductivity of the soil.
    1936. 

  1936. ! Peters-Lidard approach (Peters-Lidard et al., 1998)
    1937. 

  1937. ! --------------------------------------------------------------------------------------------------
    1938. 

  1938. ! Code history:
    1939. 

  1939. ! June 2001 changes: frozen soil condition.
    1940. 

  1940. ! --------------------------------------------------------------------------------------------------
    1941. 

  1941.     IMPLICIT NONE
    1942. 

  1942.     REAL, INTENT(IN)       :: SMC    ! total soil water
    1943. 

  1943.     REAL, INTENT(IN)       :: SH2O   ! liq. soil water
    1944. 

  1944.     REAL, INTENT(OUT)      :: DF     ! thermal diffusivity
    1945. 

  1945. 

  1946. ! local variables
    1947. 

  1947.     REAL  :: AKE
    1948. 

  1948.     REAL  :: GAMMD
    1949. 

  1949.     REAL  :: THKDRY
    1950. 

  1950.     REAL  :: THKO     ! thermal conductivity for other soil components         
    1951. 

  1951.     REAL  :: THKQTZ   ! thermal conductivity for quartz
    1952. 

  1952.     REAL  :: THKSAT   ! 
    1953. 

  1953.     REAL  :: THKS     ! thermal conductivity for the solids
    1954. 

  1954.     REAL  :: THKW     ! water thermal conductivity
    1955. 

  1955.     REAL  :: SATRATIO
    1956. 

  1956.     REAL  :: XU
    1957. 

  1957.     REAL  :: XUNFROZ
    1958. 

  1958. ! --------------------------------------------------------------------------------------------------
    1959. 

  1959. ! We now get quartz as an input argument (set in routine redprm):
    1960. 

  1960. !      DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52,
    1961. 

  1961. !     &             0.35, 0.60, 0.40, 0.82/
    1962. 

  1962. ! --------------------------------------------------------------------------------------------------
    1963. 

  1963. ! If the soil has any moisture content compute a partial sum/product
    1964. 

  1964. ! otherwise use a constant value which works well with most soils
    1965. 

  1965. ! --------------------------------------------------------------------------------------------------
    1966. 

  1966. !  QUARTZ ....QUARTZ CONTENT (SOIL TYPE DEPENDENT)
    1967. 

  1967. ! --------------------------------------------------------------------------------------------------
    1968. 

  1968. ! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975).
    1969. 

  1969. 

  1970. !                                  PABLO GRUNMANN, 08/17/98
    1971. 

  1971. ! Refs.:
    1972. 

  1972. !      Farouki, O.T.,1986: Thermal properties of soils. Series on Rock
    1973. 

  1973. !              and Soil Mechanics, Vol. 11, Trans Tech, 136 pp.
    1974. 

  1974. !      Johansen, O., 1975: Thermal conductivity of soils. PH.D. Thesis,
    1975. 

  1975. !              University of Trondheim,
    1976. 

  1976. !      Peters-Lidard, C. D., et al., 1998: The effect of soil thermal
    1977. 

  1977. !              conductivity parameterization on surface energy fluxes
    1978. 

  1978. !              and temperatures. Journal of The Atmospheric Sciences,
    1979. 

  1979. !              Vol. 55, pp. 1209-1224.
    1980. 

  1980. ! --------------------------------------------------------------------------------------------------
    1981. 

  1981. ! NEEDS PARAMETERS
    1982. 

  1982. ! POROSITY(SOIL TYPE):
    1983. 

  1983. !      POROS = SMCMAX
    1984. 

  1984. ! SATURATION RATIO:
    1985. 

  1985. ! PARAMETERS  W/(M.K)
    1986. 

  1986.     SATRATIO = SMC / SMCMAX
    1987. 

  1987.     THKW = 0.57
    1988. 

  1988. !      IF (QUARTZ .LE. 0.2) THKO = 3.0
    1989. 

  1989.     THKO = 2.0
    1990. 

  1990. ! SOLIDS' CONDUCTIVITY
    1991. 

  1991. ! QUARTZ' CONDUCTIVITY
    1992. 

  1992.     THKQTZ = 7.7
    1993. 

  1993. 

  1994. ! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN))
    1995. 

  1995.     THKS = (THKQTZ ** QUARTZ)* (THKO ** (1. - QUARTZ))
    1996. 

  1996. 

  1997. ! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ)
    1998. 

  1998.     XUNFROZ = SH2O / SMC
    1999. 

  1999. ! SATURATED THERMAL CONDUCTIVITY
    2000. 

  2000.     XU = XUNFROZ * SMCMAX
    2001. 

  2001. 

  2002. ! DRY DENSITY IN KG/M3
    2003. 

  2003.     THKSAT = THKS ** (1. - SMCMAX)* TKICE ** (SMCMAX - XU)* THKW **   &
    2004. 

  2004.          (XU)
    2005. 

  2005. 

  2006. ! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1
    2007. 

  2007.     GAMMD = (1. - SMCMAX)*2700.
    2008. 

  2008. 

  2009.     THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD)
    2010. 

  2010. ! FROZEN
    2011. 

  2011.     IF ( (SH2O + 0.0005) <  SMC ) THEN
    2012. 

  2012.        AKE = SATRATIO
    2013. 

  2013. ! UNFROZEN
    2014. 

  2014. ! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE)
    2015. 

  2015.     ELSE
    2016. 

  2016. 

  2017. ! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT
    2018. 

  2018. ! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.)
    2019. 

  2019. ! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998).
    2020. 

  2020. 

  2021.        IF ( SATRATIO >  0.1 ) THEN
    2022. 

  2022. 

  2023.           AKE = LOG10 (SATRATIO) + 1.0
    2024. 

  2024. 

  2025. ! USE K = KDRY
    2026. 

  2026.        ELSE
    2027. 

  2027. 

  2028.           AKE = 0.0
    2029. 

  2029.        END IF
    2030. 

  2030. !  THERMAL CONDUCTIVITY
    2031. 

  2031. 

  2032.     END IF
    2033. 

  2033. 

  2034.     DF = AKE * (THKSAT - THKDRY) + THKDRY
    2035. 

  2035. 

  2036. 

  2037.   end subroutine TDFCND
    2038. 

  2038. ! ==================================================================================================
    2039. 

  2039.   SUBROUTINE RADIATION (VEGTYP  ,IST     ,ISC     ,ICE     ,NSOIL   , & !in
    2040. 

  2040.                         SNEQVO  ,SNEQV   ,DT      ,COSZ    ,SNOWH   , & !in
    2041. 

  2041.                         TG      ,TV      ,FSNO    ,QSNOW   ,FWET    , & !in
    2042. 

  2042.                         ELAI    ,ESAI    ,SMC     ,SOLAD   ,SOLAI   , & !in
    2043. 

  2043.                         FVEG    ,ILOC    ,JLOC    ,                   & !in
    2044. 

  2044.                         ALBOLD  ,                                     & !inout
    2045. 

  2045.                         FSUN    ,LAISUN  ,LAISHA  ,PARSUN  ,PARSHA  , & !out
    2046. 

  2046.                         SAV     ,SAG     ,FSR     ,FSA     ,FSRV    , &
    2047. 

  2047.                         FSRG    ,BGAP    ,WGAP,GAP)            !out
    2048. 

  2048. ! --------------------------------------------------------------------------------------------------
    2049. 

  2049.   IMPLICIT NONE
    2050. 

  2050. ! --------------------------------------------------------------------------------------------------
    2051. 

  2051. ! input
    2052. 

  2052.   INTEGER, INTENT(IN)                  :: ILOC
    2053. 

  2053.   INTEGER, INTENT(IN)                  :: JLOC
    2054. 

  2054.   INTEGER, INTENT(IN)                  :: VEGTYP !vegetation type
    2055. 

  2055.   INTEGER, INTENT(IN)                  :: IST    !surface type
    2056. 

  2056.   INTEGER, INTENT(IN)                  :: ISC    !soil color type (1-lighest; 8-darkest)
    2057. 

  2057.   INTEGER, INTENT(IN)                  :: ICE    !ice (ice = 1)
    2058. 

  2058.   INTEGER, INTENT(IN)                  :: NSOIL  !number of soil layers
    2059. 

  2059. 

  2060.   REAL, INTENT(IN)                     :: DT     !time step [s]
    2061. 

  2061.   REAL, INTENT(IN)                     :: QSNOW  !snowfall (mm/s)
    2062. 

  2062.   REAL, INTENT(IN)                     :: SNEQVO !snow mass at last time step(mm)
    2063. 

  2063.   REAL, INTENT(IN)                     :: SNEQV  !snow mass (mm)
    2064. 

  2064.   REAL, INTENT(IN)                     :: SNOWH  !snow height (mm)
    2065. 

  2065.   REAL, INTENT(IN)                     :: COSZ   !cosine solar zenith angle (0-1)
    2066. 

  2066.   REAL, INTENT(IN)                     :: TG     !ground temperature (k)
    2067. 

  2067.   REAL, INTENT(IN)                     :: TV     !vegetation temperature (k)
    2068. 

  2068.   REAL, INTENT(IN)                     :: ELAI   !LAI, one-sided, adjusted for burying by snow
    2069. 

  2069.   REAL, INTENT(IN)                     :: ESAI   !SAI, one-sided, adjusted for burying by snow
    2070. 

  2070.   REAL, INTENT(IN)                     :: FWET   !fraction of canopy that is wet
    2071. 

  2071.   REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC    !volumetric soil water [m3/m3]
    2072. 

  2072.   REAL, DIMENSION(1:2)    , INTENT(IN) :: SOLAD  !incoming direct solar radiation (w/m2)
    2073. 

  2073.   REAL, DIMENSION(1:2)    , INTENT(IN) :: SOLAI  !incoming diffuse solar radiation (w/m2)
    2074. 

  2074.   REAL, INTENT(IN)                     :: FSNO   !snow cover fraction (-)
    2075. 

  2075.   REAL, INTENT(IN)                     :: FVEG   !green vegetation fraction [0.0-1.0]
    2076. 

  2076. 

  2077. ! inout
    2078. 

  2078.   REAL,                  INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type)
    2079. 

  2079. 

  2080. ! output
    2081. 

  2081.   REAL, INTENT(OUT)                    :: FSUN   !sunlit fraction of canopy (-)
    2082. 

  2082.   REAL, INTENT(OUT)                    :: LAISUN !sunlit leaf area (-)
    2083. 

  2083.   REAL, INTENT(OUT)                    :: LAISHA !shaded leaf area (-)
    2084. 

  2084.   REAL, INTENT(OUT)                    :: PARSUN !average absorbed par for sunlit leaves (w/m2)
    2085. 

  2085.   REAL, INTENT(OUT)                    :: PARSHA !average absorbed par for shaded leaves (w/m2)
    2086. 

  2086.   REAL, INTENT(OUT)                    :: SAV    !solar radiation absorbed by vegetation (w/m2)
    2087. 

  2087.   REAL, INTENT(OUT)                    :: SAG    !solar radiation absorbed by ground (w/m2)
    2088. 

  2088.   REAL, INTENT(OUT)                    :: FSA    !total absorbed solar radiation (w/m2)
    2089. 

  2089.   REAL, INTENT(OUT)                    :: FSR    !total reflected solar radiation (w/m2)
    2090. 

  2090. 

  2091. !jref:start  
    2092. 

  2092.   REAL, INTENT(OUT)                    :: FSRV    !veg. reflected solar radiation (w/m2)
    2093. 

  2093.   REAL, INTENT(OUT)                    :: FSRG    !ground reflected solar radiation (w/m2)
    2094. 

  2094.   REAL, INTENT(OUT)                    :: BGAP
    2095. 

  2095.   REAL, INTENT(OUT)                    :: WGAP
    2096. 

  2096.   REAL, INTENT(OUT)                    :: GAP
    2097. 

  2097. !jref:end  
    2098. 

  2098. 

  2099. ! local
    2100. 

  2100.   REAL                                 :: FAGE   !snow age function (0 - new snow)
    2101. 

  2101.   REAL, DIMENSION(1:2)                 :: ALBGRD !ground albedo (direct)
    2102. 

  2102.   REAL, DIMENSION(1:2)                 :: ALBGRI !ground albedo (diffuse)
    2103. 

  2103.   REAL, DIMENSION(1:2)                 :: ALBD   !surface albedo (direct)
    2104. 

  2104.   REAL, DIMENSION(1:2)                 :: ALBI   !surface albedo (diffuse)
    2105. 

  2105.   REAL, DIMENSION(1:2)                 :: FABD   !flux abs by veg (per unit direct flux)
    2106. 

  2106.   REAL, DIMENSION(1:2)                 :: FABI   !flux abs by veg (per unit diffuse flux)
    2107. 

  2107.   REAL, DIMENSION(1:2)                 :: FTDD   !down direct flux below veg (per unit dir flux)
    2108. 

  2108.   REAL, DIMENSION(1:2)                 :: FTID   !down diffuse flux below veg (per unit dir flux)
    2109. 

  2109.   REAL, DIMENSION(1:2)                 :: FTII   !down diffuse flux below veg (per unit dif flux)
    2110. 

  2110. !jref:start  
    2111. 

  2111.   REAL, DIMENSION(1:2)                 :: FREVI
    2112. 

  2112.   REAL, DIMENSION(1:2)                 :: FREVD
    2113. 

  2113.   REAL, DIMENSION(1:2)                 :: FREGI
    2114. 

  2114.   REAL, DIMENSION(1:2)                 :: FREGD
    2115. 

  2115. !jref:end
    2116. 

  2116. 

  2117.   REAL                                 :: FSHA   !shaded fraction of canopy
    2118. 

  2118.   REAL                                 :: VAI    !total LAI + stem area index, one sided
    2119. 

  2119. 

  2120.   REAL,PARAMETER :: MPE = 1.E-6
    2121. 

  2121.   LOGICAL VEG  !true: vegetated for surface temperature calculation
    2122. 

  2122. 

  2123. ! --------------------------------------------------------------------------------------------------
    2124. 

  2124. 

  2125. ! surface abeldo
    2126. 

  2126. 

  2127.    CALL ALBEDO (VEGTYP ,IST    ,ISC    ,ICE    ,NSOIL  , & !in
    2128. 

  2128.                 DT     ,COSZ   ,FAGE   ,ELAI   ,ESAI   , & !in
    2129. 

  2129.                 TG     ,TV     ,SNOWH  ,FSNO   ,FWET   , & !in
    2130. 

  2130.                 SMC    ,SNEQVO ,SNEQV  ,QSNOW  ,FVEG   , & !in
    2131. 

  2131.                 ILOC   ,JLOC   ,                         & !in
    2132. 

  2132.                 ALBOLD ,                                 & !inout
    2133. 

  2133.                 ALBGRD ,ALBGRI ,ALBD   ,ALBI   ,FABD   , & !out
    2134. 

  2134.                 FABI   ,FTDD   ,FTID   ,FTII   ,FSUN   , & !)   !out
    2135. 

  2135.                 FREVI  ,FREVD   ,FREGD ,FREGI  ,BGAP   , & !inout
    2136. 

  2136.                 WGAP   ,GAP)
    2137. 

  2137. 

  2138. ! surface radiation
    2139. 

  2139. 

  2140.      FSHA = 1.-FSUN
    2141. 

  2141.      LAISUN = ELAI*FSUN
    2142. 

  2142.      LAISHA = ELAI*FSHA
    2143. 

  2143.      VAI = ELAI+ ESAI
    2144. 

  2144.      IF (VAI .GT. 0.) THEN
    2145. 

  2145.         VEG = .TRUE.
    2146. 

  2146.      ELSE
    2147. 

  2147.         VEG = .FALSE.
    2148. 

  2148.      END IF
    2149. 

  2149. 

  2150.    CALL SURRAD (MPE    ,FSUN   ,FSHA   ,ELAI   ,VAI    , & !in
    2151. 

  2151.                 LAISUN ,LAISHA ,SOLAD  ,SOLAI  ,FABD   , & !in
    2152. 

  2152.                 FABI   ,FTDD   ,FTID   ,FTII   ,ALBGRD , & !in
    2153. 

  2153.                 ALBGRI ,ALBD   ,ALBI   ,ILOC   ,JLOC   , & !in
    2154. 

  2154.                 PARSUN ,PARSHA ,SAV    ,SAG    ,FSA    , & !out
    2155. 

  2155.                 FSR    ,                                 & !out
    2156. 

  2156.                 FREVI  ,FREVD  ,FREGD  ,FREGI  ,FSRV   , & !inout
    2157. 

  2157.                 FSRG)
    2158. 

  2158. 

  2159.   END SUBROUTINE RADIATION
    2160. 

  2160. ! ==================================================================================================
    2161. 

  2161. ! --------------------------------------------------------------------------------------------------
    2162. 

  2162.   SUBROUTINE ALBEDO (VEGTYP ,IST    ,ISC    ,ICE    ,NSOIL  , & !in
    2163. 

  2163.                      DT     ,COSZ   ,FAGE   ,ELAI   ,ESAI   , & !in
    2164. 

  2164.                      TG     ,TV     ,SNOWH  ,FSNO   ,FWET   , & !in
    2165. 

  2165.                      SMC    ,SNEQVO ,SNEQV  ,QSNOW  ,FVEG   , & !in
    2166. 

  2166.                      ILOC   ,JLOC   ,                         & !in
    2167. 

  2167.                      ALBOLD ,                                 & !inout
    2168. 

  2168.                      ALBGRD ,ALBGRI ,ALBD   ,ALBI   ,FABD   , & !out
    2169. 

  2169.                      FABI   ,FTDD   ,FTID   ,FTII   ,FSUN   , & !out
    2170. 

  2170.                      FREVI  ,FREVD  ,FREGD  ,FREGI  ,BGAP   , & !out
    2171. 

  2171.                      WGAP   ,GAP)
    2172. 

  2172. 

  2173. ! --------------------------------------------------------------------------------------------------
    2174. 

  2174. ! surface albedos. also fluxes (per unit incoming direct and diffuse
    2175. 

  2175. ! radiation) reflected, transmitted, and absorbed by vegetation.
    2176. 

  2176. ! also sunlit fraction of the canopy.
    2177. 

  2177. ! --------------------------------------------------------------------------------------------------
    2178. 

  2178.   USE NOAHMP_VEG_PARAMETERS
    2179. 

  2179. ! --------------------------------------------------------------------------------------------------
    2180. 

  2180.   IMPLICIT NONE
    2181. 

  2181. ! --------------------------------------------------------------------------------------------------
    2182. 

  2182. ! input
    2183. 

  2183.   INTEGER,                  INTENT(IN)  :: ILOC
    2184. 

  2184.   INTEGER,                  INTENT(IN)  :: JLOC
    2185. 

  2185.   INTEGER,                  INTENT(IN)  :: NSOIL  !number of soil layers
    2186. 

  2186.   INTEGER,                  INTENT(IN)  :: VEGTYP !vegetation type
    2187. 

  2187.   INTEGER,                  INTENT(IN)  :: IST    !surface type
    2188. 

  2188.   INTEGER,                  INTENT(IN)  :: ISC    !soil color type (1-lighest; 8-darkest)
    2189. 

  2189.   INTEGER,                  INTENT(IN)  :: ICE    !ice (ice = 1)
    2190. 

  2190. 

  2191.   REAL,                     INTENT(IN)  :: DT     !time step [sec]
    2192. 

  2192.   REAL,                     INTENT(IN)  :: QSNOW  !snowfall
    2193. 

  2193.   REAL,                     INTENT(IN)  :: COSZ   !cosine solar zenith angle for next time step
    2194. 

  2194.   REAL,                     INTENT(IN)  :: SNOWH  !snow height (mm)
    2195. 

  2195.   REAL,                     INTENT(IN)  :: TG     !ground temperature (k)
    2196. 

  2196.   REAL,                     INTENT(IN)  :: TV     !vegetation temperature (k)
    2197. 

  2197.   REAL,                     INTENT(IN)  :: ELAI   !LAI, one-sided, adjusted for burying by snow
    2198. 

  2198.   REAL,                     INTENT(IN)  :: ESAI   !SAI, one-sided, adjusted for burying by snow
    2199. 

  2199.   REAL,                     INTENT(IN)  :: FSNO   !fraction of grid covered by snow
    2200. 

  2200.   REAL,                     INTENT(IN)  :: FWET   !fraction of canopy that is wet
    2201. 

  2201.   REAL,                     INTENT(IN)  :: SNEQVO !snow mass at last time step(mm)
    2202. 

  2202.   REAL,                     INTENT(IN)  :: SNEQV  !snow mass (mm)
    2203. 

  2203.   REAL,                     INTENT(IN)  :: FVEG   !green vegetation fraction [0.0-1.0]
    2204. 

  2204.   REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: SMC    !volumetric soil water (m3/m3)
    2205. 

  2205. 

  2206. ! inout
    2207. 

  2207.   REAL,                  INTENT(INOUT)  :: ALBOLD !snow albedo at last time step (CLASS type)
    2208. 

  2208. 

  2209. ! output
    2210. 

  2210.   REAL, DIMENSION(1:    2), INTENT(OUT) :: ALBGRD !ground albedo (direct)
    2211. 

  2211.   REAL, DIMENSION(1:    2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse)
    2212. 

  2212.   REAL, DIMENSION(1:    2), INTENT(OUT) :: ALBD   !surface albedo (direct)
    2213. 

  2213.   REAL, DIMENSION(1:    2), INTENT(OUT) :: ALBI   !surface albedo (diffuse)
    2214. 

  2214.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FABD   !flux abs by veg (per unit direct flux)
    2215. 

  2215.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FABI   !flux abs by veg (per unit diffuse flux)
    2216. 

  2216.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FTDD   !down direct flux below veg (per unit dir flux)
    2217. 

  2217.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FTID   !down diffuse flux below veg (per unit dir flux)
    2218. 

  2218.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FTII   !down diffuse flux below veg (per unit dif flux)
    2219. 

  2219.   REAL,                     INTENT(OUT) :: FSUN   !sunlit fraction of canopy (-)
    2220. 

  2220. !jref:start
    2221. 

  2221.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FREVD
    2222. 

  2222.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FREVI
    2223. 

  2223.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FREGD
    2224. 

  2224.   REAL, DIMENSION(1:    2), INTENT(OUT) :: FREGI
    2225. 

  2225.   REAL, INTENT(OUT) :: BGAP
    2226. 

  2226.   REAL, INTENT(OUT) :: WGAP
    2227. 

  2227.   REAL, INTENT(OUT) :: GAP
    2228. 

  2228. !jref:end
    2229. 

  2229. 

  2230. ! ------------------------------------------------------------------------
    2231. 

  2231. ! ------------------------ local variables -------------------------------
    2232. 

  2232. ! local
    2233. 

  2233.   REAL                 :: FAGE     !snow age function
    2234. 

  2234.   REAL                 :: ALB
    2235. 

  2235.   INTEGER              :: IB       !indices
    2236. 

  2236.   INTEGER              :: NBAND    !number of solar radiation wave bands
    2237. 

  2237.   INTEGER              :: IC       !direct beam: ic=0; diffuse: ic=1
    2238. 

  2238. 

  2239.   REAL                 :: WL       !fraction of LAI+SAI that is LAI
    2240. 

  2240.   REAL                 :: WS       !fraction of LAI+SAI that is SAI
    2241. 

  2241.   REAL                 :: MPE      !prevents overflow for division by zero
    2242. 

  2242. 

  2243.   REAL, DIMENSION(1:2) :: RHO      !leaf/stem reflectance weighted by fraction LAI and SAI
    2244. 

  2244.   REAL, DIMENSION(1:2) :: TAU      !leaf/stem transmittance weighted by fraction LAI and SAI
    2245. 

  2245.   REAL, DIMENSION(1:2) :: FTDI     !down direct flux below veg per unit dif flux = 0
    2246. 

  2246.   REAL, DIMENSION(1:2) :: ALBSND   !snow albedo (direct)
    2247. 

  2247.   REAL, DIMENSION(1:2) :: ALBSNI   !snow albedo (diffuse)
    2248. 

  2248. 

  2249.   REAL                 :: VAI      !ELAI+ESAI
    2250. 

  2250.   REAL                 :: GDIR     !average projected leaf/stem area in solar direction
    2251. 

  2251.   REAL                 :: EXT      !optical depth direct beam per unit leaf + stem area
    2252. 

  2252. 

  2253. ! --------------------------------------------------------------------------------------------------
    2254. 

  2254. 

  2255.   NBAND = 2
    2256. 

  2256.   MPE = 1.E-06
    2257. 

  2257.   BGAP = 0.
    2258. 

  2258.   WGAP = 0.
    2259. 

  2259.   GAP  = 0.
    2260. 

  2260. 

  2261. ! initialize output because solar radiation only done if COSZ > 0
    2262. 

  2262. 

  2263.   DO IB = 1, NBAND
    2264. 

  2264.     ALBD(IB) = 0.
    2265. 

  2265.     ALBI(IB) = 0.
    2266. 

  2266.     ALBGRD(IB) = 0.
    2267. 

  2267.     ALBGRI(IB) = 0.
    2268. 

  2268.     FABD(IB) = 0.
    2269. 

  2269.     FABI(IB) = 0.
    2270. 

  2270.     FTDD(IB) = 0.
    2271. 

  2271.     FTID(IB) = 0.
    2272. 

  2272.     FTII(IB) = 0.
    2273. 

  2273.     IF (IB.EQ.1) FSUN = 0.
    2274. 

  2274.   END DO
    2275. 

  2275. 

  2276.   IF(COSZ <= 0) GOTO 100
    2277. 

  2277. 

  2278. ! weight reflectance/transmittance by LAI and SAI
    2279. 

  2279. 

  2280.   DO IB = 1, NBAND
    2281. 

  2281.     VAI = ELAI + ESAI
    2282. 

  2282.     WL  = ELAI / MAX(VAI,MPE)
    2283. 

  2283.     WS  = ESAI / MAX(VAI,MPE)
    2284. 

  2284.     RHO(IB) = MAX(RHOL(VEGTYP,IB)*WL+RHOS(VEGTYP,IB)*WS, MPE)
    2285. 

  2285.     TAU(IB) = MAX(TAUL(VEGTYP,IB)*WL+TAUS(VEGTYP,IB)*WS, MPE)
    2286. 

  2286.   END DO
    2287. 

  2287. 

  2288. ! snow age
    2289. 

  2289. 

  2290.    CALL SNOW_AGE (DT,TG,SNEQVO,SNEQV,FAGE)
    2291. 

  2291. 

  2292. ! snow albedos: only if COSZ > 0 and FSNO > 0
    2293. 

  2293. 

  2294.   IF(OPT_ALB == 1) &
    2295. 

  2295.      CALL SNOWALB_BATS (NBAND, FSNO,COSZ,FAGE,ALBSND,ALBSNI)
    2296. 

  2296.   IF(OPT_ALB == 2) THEN
    2297. 

  2297.      CALL SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC)
    2298. 

  2298.      ALBOLD = ALB
    2299. 

  2299.   END IF
    2300. 

  2300. 

  2301. ! ground surface albedo
    2302. 

  2302. 

  2303.   CALL GROUNDALB (NSOIL   ,NBAND   ,ICE     ,IST     ,ISC     , & !in
    2304. 

  2304.                   FSNO    ,SMC     ,ALBSND  ,ALBSNI  ,COSZ    , & !in
    2305. 

  2305.                   TG      ,ILOC    ,JLOC    ,                   & !in
    2306. 

  2306.                   ALBGRD  ,ALBGRI  )                              !out
    2307. 

  2307. 

  2308. ! loop over NBAND wavebands to calculate surface albedos and solar
    2309. 

  2309. ! fluxes for unit incoming direct (IC=0) and diffuse flux (IC=1)
    2310. 

  2310. 

  2311.   DO IB = 1, NBAND
    2312. 

  2312.       IC = 0      ! direct
    2313. 

  2313.       CALL TWOSTREAM (IB     ,IC      ,VEGTYP  ,COSZ    ,VAI    , & !in
    2314. 

  2314.                       FWET   ,TV      ,ALBGRD  ,ALBGRI  ,RHO    , & !in
    2315. 

  2315.                       TAU    ,FVEG    ,IST     ,ILOC    ,JLOC   , & !in
    2316. 

  2316.                       FABD   ,ALBD    ,FTDD    ,FTID    ,GDIR   , &!)   !out
    2317. 

  2317.                       FREVD  ,FREGD   ,BGAP    ,WGAP    ,GAP)
    2318. 

  2318. 

  2319.       IC = 1      ! diffuse
    2320. 

  2320.       CALL TWOSTREAM (IB     ,IC      ,VEGTYP  ,COSZ    ,VAI    , & !in
    2321. 

  2321.                       FWET   ,TV      ,ALBGRD  ,ALBGRI  ,RHO    , & !in
    2322. 

  2322.                       TAU    ,FVEG    ,IST     ,ILOC    ,JLOC   , & !in
    2323. 

  2323.                       FABI   ,ALBI    ,FTDI    ,FTII    ,GDIR   , & !)   !out
    2324. 

  2324.                       FREVI  ,FREGI   ,BGAP    ,WGAP    ,GAP)
    2325. 

  2325. 

  2326.   END DO
    2327. 

  2327. 

  2328. ! sunlit fraction of canopy. set FSUN = 0 if FSUN < 0.01.
    2329. 

  2329. 

  2330.   EXT = GDIR/COSZ * SQRT(1.-RHO(1)-TAU(1))
    2331. 

  2331.   FSUN = (1.-EXP(-EXT*VAI)) / MAX(EXT*VAI,MPE)
    2332. 

  2332.   EXT = FSUN
    2333. 

  2333. 

  2334.   IF (EXT .LT. 0.01) THEN
    2335. 

  2335.      WL = 0.
    2336. 

  2336.   ELSE
    2337. 

  2337.      WL = EXT 
    2338. 

  2338.   END IF
    2339. 

  2339.   FSUN = WL
    2340. 

  2340. 

  2341. 100 CONTINUE
    2342. 

  2342. 

  2343.   END SUBROUTINE ALBEDO
    2344. 

  2344. ! ==================================================================================================
    2345. 

  2345. ! --------------------------------------------------------------------------------------------------
    2346. 

  2346.   SUBROUTINE SURRAD (MPE     ,FSUN    ,FSHA    ,ELAI    ,VAI     , & !in
    2347. 

  2347.                      LAISUN  ,LAISHA  ,SOLAD   ,SOLAI   ,FABD    , & !in
    2348. 

  2348.                      FABI    ,FTDD    ,FTID    ,FTII    ,ALBGRD  , & !in
    2349. 

  2349.                      ALBGRI  ,ALBD    ,ALBI    ,ILOC    ,JLOC    , & !in
    2350. 

  2350.                      PARSUN  ,PARSHA  ,SAV     ,SAG     ,FSA     , & !out
    2351. 

  2351.                      FSR     , & !)                                       !out
    2352. 

  2352.                      FREVI   ,FREVD   ,FREGD   ,FREGI   ,FSRV    , &
    2353. 

  2353.                      FSRG) !inout
    2354. 

  2354. 

  2355. ! --------------------------------------------------------------------------------------------------
    2356. 

  2356.   IMPLICIT NONE
    2357. 

  2357. ! --------------------------------------------------------------------------------------------------
    2358. 

  2358. ! input
    2359. 

  2359. 

  2360.   INTEGER, INTENT(IN)              :: ILOC
    2361. 

  2361.   INTEGER, INTENT(IN)              :: JLOC
    2362. 

  2362.   REAL, INTENT(IN)                 :: MPE     !prevents underflow errors if division by zero
    2363. 

  2363. 

  2364.   REAL, INTENT(IN)                 :: FSUN    !sunlit fraction of canopy
    2365. 

  2365.   REAL, INTENT(IN)                 :: FSHA    !shaded fraction of canopy
    2366. 

  2366.   REAL, INTENT(IN)                 :: ELAI    !leaf area, one-sided
    2367. 

  2367.   REAL, INTENT(IN)                 :: VAI     !leaf + stem area, one-sided
    2368. 

  2368.   REAL, INTENT(IN)                 :: LAISUN  !sunlit leaf area index, one-sided
    2369. 

  2369.   REAL, INTENT(IN)                 :: LAISHA  !shaded leaf area index, one-sided
    2370. 

  2370. 

  2371.   REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD   !incoming direct solar radiation (w/m2)
    2372. 

  2372.   REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI   !incoming diffuse solar radiation (w/m2)
    2373. 

  2373.   REAL, DIMENSION(1:2), INTENT(IN) :: FABD    !flux abs by veg (per unit incoming direct flux)
    2374. 

  2374.   REAL, DIMENSION(1:2), INTENT(IN) :: FABI    !flux abs by veg (per unit incoming diffuse flux)
    2375. 

  2375.   REAL, DIMENSION(1:2), INTENT(IN) :: FTDD    !down dir flux below veg (per incoming dir flux)
    2376. 

  2376.   REAL, DIMENSION(1:2), INTENT(IN) :: FTID    !down dif flux below veg (per incoming dir flux)
    2377. 

  2377.   REAL, DIMENSION(1:2), INTENT(IN) :: FTII    !down dif flux below veg (per incoming dif flux)
    2378. 

  2378.   REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD  !ground albedo (direct)
    2379. 

  2379.   REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI  !ground albedo (diffuse)
    2380. 

  2380.   REAL, DIMENSION(1:2), INTENT(IN) :: ALBD    !overall surface albedo (direct)
    2381. 

  2381.   REAL, DIMENSION(1:2), INTENT(IN) :: ALBI    !overall surface albedo (diffuse)
    2382. 

  2382. 

  2383.   REAL, DIMENSION(1:2), INTENT(IN) :: FREVD    !overall surface albedo veg (direct)
    2384. 

  2384.   REAL, DIMENSION(1:2), INTENT(IN) :: FREVI    !overall surface albedo veg (diffuse)
    2385. 

  2385.   REAL, DIMENSION(1:2), INTENT(IN) :: FREGD    !overall surface albedo grd (direct)
    2386. 

  2386.   REAL, DIMENSION(1:2), INTENT(IN) :: FREGI    !overall surface albedo grd (diffuse)
    2387. 

  2387. 

  2388. ! output
    2389. 

  2389. 

  2390.   REAL, INTENT(OUT)                :: PARSUN  !average absorbed par for sunlit leaves (w/m2)
    2391. 

  2391.   REAL, INTENT(OUT)                :: PARSHA  !average absorbed par for shaded leaves (w/m2)
    2392. 

  2392.   REAL, INTENT(OUT)                :: SAV     !solar radiation absorbed by vegetation (w/m2)
    2393. 

  2393.   REAL, INTENT(OUT)                :: SAG     !solar radiation absorbed by ground (w/m2)
    2394. 

  2394.   REAL, INTENT(OUT)                :: FSA     !total absorbed solar radiation (w/m2)
    2395. 

  2395.   REAL, INTENT(OUT)                :: FSR     !total reflected solar radiation (w/m2)
    2396. 

  2396.   REAL, INTENT(OUT)                :: FSRV    !reflected solar radiation by vegetation
    2397. 

  2397.   REAL, INTENT(OUT)                :: FSRG    !reflected solar radiation by ground
    2398. 

  2398. 

  2399. ! ------------------------ local variables ----------------------------------------------------
    2400. 

  2400.   INTEGER                          :: IB      !waveband number (1=vis, 2=nir)
    2401. 

  2401.   INTEGER                          :: NBAND   !number of solar radiation waveband classes
    2402. 

  2402. 

  2403.   REAL                             :: ABS     !absorbed solar radiation (w/m2)
    2404. 

  2404.   REAL                             :: RNIR    !reflected solar radiation [nir] (w/m2)
    2405. 

  2405.   REAL                             :: RVIS    !reflected solar radiation [vis] (w/m2)
    2406. 

  2406.   REAL                             :: LAIFRA  !leaf area fraction of canopy
    2407. 

  2407.   REAL                             :: TRD     !transmitted solar radiation: direct (w/m2)
    2408. 

  2408.   REAL                             :: TRI     !transmitted solar radiation: diffuse (w/m2)
    2409. 

  2409.   REAL, DIMENSION(1:2)             :: CAD     !direct beam absorbed by canopy (w/m2)
    2410. 

  2410.   REAL, DIMENSION(1:2)             :: CAI     !diffuse radiation absorbed by canopy (w/m2)
    2411. 

  2411. ! ---------------------------------------------------------------------------------------------
    2412. 

  2412.    NBAND = 2
    2413. 

  2413. 

  2414. ! zero summed solar fluxes
    2415. 

  2415. 

  2416.     SAG = 0.
    2417. 

  2417.     SAV = 0.
    2418. 

  2418.     FSA = 0.
    2419. 

  2419. 

  2420. ! loop over nband wavebands
    2421. 

  2421. 

  2422.   DO IB = 1, NBAND
    2423. 

  2423. 

  2424. ! absorbed by canopy
    2425. 

  2425. 

  2426.     CAD(IB) = SOLAD(IB)*FABD(IB)    
    2427. 

  2427.     CAI(IB) = SOLAI(IB)*FABI(IB)
    2428. 

  2428.     SAV     = SAV + CAD(IB) + CAI(IB)
    2429. 

  2429.     FSA     = FSA + CAD(IB) + CAI(IB)
    2430. 

  2430.  
    2431. 

  2431. ! transmitted solar fluxes incident on ground
    2432. 

  2432. 

  2433.     TRD = SOLAD(IB)*FTDD(IB)
    2434. 

  2434.     TRI = SOLAD(IB)*FTID(IB) + SOLAI(IB)*FTII(IB)
    2435. 

  2435. 

  2436. ! solar radiation absorbed by ground surface
    2437. 

  2437. 

  2438.     ABS = TRD*(1.-ALBGRD(IB)) + TRI*(1.-ALBGRI(IB))
    2439. 

  2439.     SAG = SAG + ABS
    2440. 

  2440.     FSA = FSA + ABS
    2441. 

  2441.   END DO
    2442. 

  2442. 

  2443. ! partition visible canopy absorption to sunlit and shaded fractions
    2444. 

  2444. ! to get average absorbed par for sunlit and shaded leaves
    2445. 

  2445. 

  2446.      LAIFRA = ELAI / MAX(VAI,MPE)
    2447. 

  2447.      IF (FSUN .GT. 0.) THEN
    2448. 

  2448.         PARSUN = (CAD(1)+FSUN*CAI(1)) * LAIFRA / MAX(LAISUN,MPE)
    2449. 

  2449.         PARSHA = (FSHA*CAI(1))*LAIFRA / MAX(LAISHA,MPE)
    2450. 

  2450.      ELSE
    2451. 

  2451.         PARSUN = 0.
    2452. 

  2452.         PARSHA = (CAD(1)+CAI(1))*LAIFRA /MAX(LAISHA,MPE)
    2453. 

  2453.      ENDIF
    2454. 

  2454. 

  2455. ! reflected solar radiation
    2456. 

  2456. 

  2457.      RVIS = ALBD(1)*SOLAD(1) + ALBI(1)*SOLAI(1)
    2458. 

  2458.      RNIR = ALBD(2)*SOLAD(2) + ALBI(2)*SOLAI(2)
    2459. 

  2459.      FSR  = RVIS + RNIR
    2460. 

  2460. 

  2461. ! reflected solar radiation of veg. and ground (combined ground)
    2462. 

  2462.      FSRV = FREVD(1)*SOLAD(1)+FREVI(1)*SOLAI(1)+FREVD(2)*SOLAD(2)+FREVI(2)*SOLAI(2)
    2463. 

  2463.      FSRG = FREGD(1)*SOLAD(1)+FREGI(1)*SOLAI(1)+FREGD(2)*SOLAD(2)+FREGI(2)*SOLAI(2)
    2464. 

  2464. 

  2465. 

  2466.   END SUBROUTINE SURRAD
    2467. 

  2467. ! ==================================================================================================
    2468. 

  2468. ! --------------------------------------------------------------------------------------------------
    2469. 

  2469.   SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,FAGE)
    2470. 

  2470. ! --------------------------------------------------------------------------------------------------
    2471. 

  2471.   IMPLICIT NONE
    2472. 

  2472. ! ------------------------ code history ------------------------------------------------------------
    2473. 

  2473. ! from BATS
    2474. 

  2474. ! ------------------------ input/output variables --------------------------------------------------
    2475. 

  2475. !input
    2476. 

  2476.    REAL, INTENT(IN) :: DT        !main time step (s)
    2477. 

  2477.    REAL, INTENT(IN) :: TG        !ground temperature (k)
    2478. 

  2478.    REAL, INTENT(IN) :: SNEQVO    !snow mass at last time step(mm)
    2479. 

  2479.    REAL, INTENT(IN) :: SNEQV     !snow water per unit ground area (mm)
    2480. 

  2480. 

  2481. !output
    2482. 

  2482.    REAL, INTENT(OUT) :: FAGE     !snow age
    2483. 

  2483. 

  2484. !local
    2485. 

  2485.    REAL            :: TAUSS      !non-dimensional snow age
    2486. 

  2486.    REAL            :: TAGE       !total aging effects
    2487. 

  2487.    REAL            :: AGE1       !effects of grain growth due to vapor diffusion
    2488. 

  2488.    REAL            :: AGE2       !effects of grain growth at freezing of melt water
    2489. 

  2489.    REAL            :: AGE3       !effects of soot
    2490. 

  2490.    REAL            :: DELA       !temporary variable
    2491. 

  2491.    REAL            :: SGE        !temporary variable
    2492. 

  2492.    REAL            :: DELS       !temporary variable
    2493. 

  2493.    REAL            :: DELA0      !temporary variable
    2494. 

  2494.    REAL            :: ARG        !temporary variable
    2495. 

  2495. ! See Yang et al. (1997) J.of Climate for detail.
    2496. 

  2496. !---------------------------------------------------------------------------------------------------
    2497. 

  2497. 

  2498.    IF(SNEQV.LE.0.0) THEN
    2499. 

  2499.           TAUSS = 0.
    2500. 

  2500.    ELSE IF (SNEQV.GT.800.) THEN
    2501. 

  2501.           TAUSS = 0.
    2502. 

  2502.    ELSE
    2503. 

  2503.           TAUSS = 0.
    2504. 

  2504.           DELA0 = 1.E-6*DT
    2505. 

  2505.           ARG   = 5.E3*(1./TFRZ-1./TG)
    2506. 

  2506.           AGE1  = EXP(ARG)
    2507. 

  2507.           AGE2  = EXP(AMIN1(0.,10.*ARG))
    2508. 

  2508.           AGE3  = 0.3
    2509. 

  2509.           TAGE  = AGE1+AGE2+AGE3
    2510. 

  2510.           DELA  = DELA0*TAGE
    2511. 

  2511.           DELS  = AMAX1(0.0,SNEQV-SNEQVO) / SWEMX
    2512. 

  2512.           SGE   = (TAUSS+DELA)*(1.0-DELS)
    2513. 

  2513.           TAUSS = AMAX1(0.,SGE)
    2514. 

  2514.    ENDIF
    2515. 

  2515. 

  2516.    FAGE= TAUSS/(TAUSS+1.)
    2517. 

  2517. 

  2518.   END SUBROUTINE SNOW_AGE
    2519. 

  2519. ! ==================================================================================================
    2520. 

  2520. ! --------------------------------------------------------------------------------------------------
    2521. 

  2521.   SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI)
    2522. 

  2522. ! --------------------------------------------------------------------------------------------------
    2523. 

  2523.   IMPLICIT NONE
    2524. 

  2524. ! --------------------------------------------------------------------------------------------------
    2525. 

  2525. ! input
    2526. 

  2526. 

  2527.   INTEGER,INTENT(IN) :: NBAND  !number of waveband classes
    2528. 

  2528. 

  2529.   REAL,INTENT(IN) :: COSZ    !cosine solar zenith angle
    2530. 

  2530.   REAL,INTENT(IN) :: FSNO    !snow cover fraction (-)
    2531. 

  2531.   REAL,INTENT(IN) :: FAGE    !snow age correction
    2532. 

  2532. 

  2533. ! output
    2534. 

  2534. 

  2535.   REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir)
    2536. 

  2536.   REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse
    2537. 

  2537. ! ---------------------------------------------------------------------------------------------
    2538. 

  2538. 

  2539. ! ------------------------ local variables ----------------------------------------------------
    2540. 

  2540.   INTEGER :: IB          !waveband class
    2541. 

  2541. 

  2542.   REAL :: FZEN                 !zenith angle correction
    2543. 

  2543.   REAL :: CF1                  !temperary variable
    2544. 

  2544.   REAL :: SL2                  !2.*SL
    2545. 

  2545.   REAL :: SL1                  !1/SL
    2546. 

  2546.   REAL :: SL                   !adjustable parameter
    2547. 

  2547.   REAL, PARAMETER :: C1 = 0.2  !default in BATS 
    2548. 

  2548.   REAL, PARAMETER :: C2 = 0.5  !default in BATS
    2549. 

  2549. !  REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's
    2550. 

  2550. !  REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects)
    2551. 

  2551. ! ---------------------------------------------------------------------------------------------
    2552. 

  2552. ! zero albedos for all points
    2553. 

  2553. 

  2554.         ALBSND(1: NBAND) = 0.
    2555. 

  2555.         ALBSNI(1: NBAND) = 0.
    2556. 

  2556. 

  2557. ! when cosz > 0
    2558. 

  2558. 

  2559.         SL=2.0
    2560. 

  2560.         SL1=1./SL
    2561. 

  2561.         SL2=2.*SL
    2562. 

  2562.         CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1)
    2563. 

  2563.         FZEN=AMAX1(CF1,0.)
    2564. 

  2564. 

  2565.         ALBSNI(1)=0.95*(1.-C1*FAGE)         
    2566. 

  2566.         ALBSNI(2)=0.65*(1.-C2*FAGE)        
    2567. 

  2567. 

  2568.         ALBSND(1)=ALBSNI(1)+0.4*FZEN*(1.-ALBSNI(1))    !  vis direct
    2569. 

  2569.         ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2))    !  nir direct
    2570. 

  2570. 

  2571.   END SUBROUTINE SNOWALB_BATS
    2572. 

  2572. ! ==================================================================================================
    2573. 

  2573. ! --------------------------------------------------------------------------------------------------
    2574. 

  2574.   SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC)
    2575. 

  2575. ! --------------------------------------------------------------------------------------------------
    2576. 

  2576.   IMPLICIT NONE
    2577. 

  2577. ! --------------------------------------------------------------------------------------------------
    2578. 

  2578. ! input
    2579. 

  2579. 

  2580.   INTEGER,INTENT(IN) :: ILOC !grid index
    2581. 

  2581.   INTEGER,INTENT(IN) :: JLOC !grid index
    2582. 

  2582.   INTEGER,INTENT(IN) :: NBAND  !number of waveband classes
    2583. 

  2583. 

  2584.   REAL,INTENT(IN) :: QSNOW     !snowfall (mm/s)
    2585. 

  2585.   REAL,INTENT(IN) :: DT        !time step (sec)
    2586. 

  2586.   REAL,INTENT(IN) :: ALBOLD    !snow albedo at last time step
    2587. 

  2587. 

  2588. ! in & out
    2589. 

  2589. 

  2590.   REAL,                INTENT(INOUT) :: ALB        ! 
    2591. 

  2591. ! output
    2592. 

  2592. 

  2593.   REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir)
    2594. 

  2594.   REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse
    2595. 

  2595. ! ---------------------------------------------------------------------------------------------
    2596. 

  2596. 

  2597. ! ------------------------ local variables ----------------------------------------------------
    2598. 

  2598.   INTEGER :: IB          !waveband class
    2599. 

  2599. 

  2600. ! ---------------------------------------------------------------------------------------------
    2601. 

  2601. ! zero albedos for all points
    2602. 

  2602. 

  2603.         ALBSND(1: NBAND) = 0.
    2604. 

  2604.         ALBSNI(1: NBAND) = 0.
    2605. 

  2605. 

  2606. ! when cosz > 0
    2607. 

  2607. 

  2608.          ALB = 0.55 + (ALBOLD-0.55) * EXP(-0.01*DT/3600.)
    2609. 

  2609. 

  2610. ! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3
    2611. 

  2611. ! here assume 1cm snow depth will fully cover the old snow
    2612. 

  2612. 

  2613.          IF (QSNOW > 0.) then
    2614. 

  2614.            ALB = ALB + MIN(QSNOW*DT,SWEMX) * (0.84-ALB)/(SWEMX)
    2615. 

  2615.          ENDIF
    2616. 

  2616. 

  2617.          ALBSNI(1)= ALB         ! vis diffuse
    2618. 

  2618.          ALBSNI(2)= ALB         ! nir diffuse
    2619. 

  2619.          ALBSND(1)= ALB         ! vis direct
    2620. 

  2620.          ALBSND(2)= ALB         ! nir direct
    2621. 

  2621. 

  2622.   END SUBROUTINE SNOWALB_CLASS
    2623. 

  2623. ! ==================================================================================================
    2624. 

  2624. ! --------------------------------------------------------------------------------------------------
    2625. 

  2625.   SUBROUTINE GROUNDALB (NSOIL   ,NBAND   ,ICE     ,IST     ,ISC     , & !in
    2626. 

  2626.                         FSNO    ,SMC     ,ALBSND  ,ALBSNI  ,COSZ    , & !in
    2627. 

  2627.                         TG      ,ILOC    ,JLOC    ,                   & !in
    2628. 

  2628.                         ALBGRD  ,ALBGRI  )                              !out
    2629. 

  2629. ! --------------------------------------------------------------------------------------------------
    2630. 

  2630.   USE NOAHMP_RAD_PARAMETERS
    2631. 

  2631. ! --------------------------------------------------------------------------------------------------
    2632. 

  2632.   IMPLICIT NONE
    2633. 

  2633. ! --------------------------------------------------------------------------------------------------
    2634. 

  2634. !input
    2635. 

  2635. 

  2636.   INTEGER,                  INTENT(IN)  :: ILOC   !grid index
    2637. 

  2637.   INTEGER,                  INTENT(IN)  :: JLOC   !grid index
    2638. 

  2638.   INTEGER,                  INTENT(IN)  :: NSOIL  !number of soil layers
    2639. 

  2639.   INTEGER,                  INTENT(IN)  :: NBAND  !number of solar radiation waveband classes
    2640. 

  2640.   INTEGER,                  INTENT(IN)  :: ICE    !value of ist for land ice
    2641. 

  2641.   INTEGER,                  INTENT(IN)  :: IST    !surface type
    2642. 

  2642.   INTEGER,                  INTENT(IN)  :: ISC    !soil color class (1-lighest; 8-darkest)
    2643. 

  2643.   REAL,                     INTENT(IN)  :: FSNO   !fraction of surface covered with snow (-)
    2644. 

  2644.   REAL,                     INTENT(IN)  :: TG     !ground temperature (k)
    2645. 

  2645.   REAL,                     INTENT(IN)  :: COSZ   !cosine solar zenith angle (0-1)
    2646. 

  2646.   REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: SMC    !volumetric soil water content (m3/m3)
    2647. 

  2647.   REAL, DIMENSION(1:    2), INTENT(IN)  :: ALBSND !direct beam snow albedo (vis, nir)
    2648. 

  2648.   REAL, DIMENSION(1:    2), INTENT(IN)  :: ALBSNI !diffuse snow albedo (vis, nir)
    2649. 

  2649. 

  2650. !output
    2651. 

  2651. 

  2652.   REAL, DIMENSION(1:    2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir)
    2653. 

  2653.   REAL, DIMENSION(1:    2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir)
    2654. 

  2654. 

  2655. !local 
    2656. 

  2656. 

  2657.   INTEGER                               :: IB     !waveband number (1=vis, 2=nir)
    2658. 

  2658.   REAL                                  :: INC    !soil water correction factor for soil albedo
    2659. 

  2659.   REAL                                  :: ALBSOD !soil albedo (direct)
    2660. 

  2660.   REAL                                  :: ALBSOI !soil albedo (diffuse)
    2661. 

  2661. ! --------------------------------------------------------------------------------------------------
    2662. 

  2662. 

  2663.   DO IB = 1, NBAND
    2664. 

  2664.         INC = MAX(0.11-0.40*SMC(1), 0.)
    2665. 

  2665.         IF (IST .EQ. 1)  THEN                     !soil
    2666. 

  2666.            ALBSOD = MIN(ALBSAT(ISC,IB)+INC,ALBDRY(ISC,IB))
    2667. 

  2667.            ALBSOI = ALBSOD
    2668. 

  2668.         ELSE IF (TG .GT. TFRZ) THEN               !unfrozen lake, wetland
    2669. 

  2669.            ALBSOD = 0.06/(MAX(0.01,COSZ)**1.7 + 0.15)
    2670. 

  2670.            ALBSOI = 0.06
    2671. 

  2671.         ELSE                                      !frozen lake, wetland
    2672. 

  2672.            ALBSOD = ALBLAK(IB)
    2673. 

  2673.            ALBSOI = ALBSOD
    2674. 

  2674.         END IF
    2675. 

  2675. 

  2676. ! increase desert and semi-desert albedos
    2677. 

  2677. 

  2678.         IF (IST .EQ. 1 .AND. ISC .EQ. 9) THEN
    2679. 

  2679.            ALBSOD = ALBSOD + 0.10
    2680. 

  2680.            ALBSOI = ALBSOI + 0.10
    2681. 

  2681.         end if
    2682. 

  2682. 

  2683.         ALBGRD(IB) = ALBSOD*(1.-FSNO) + ALBSND(IB)*FSNO
    2684. 

  2684.         ALBGRI(IB) = ALBSOI*(1.-FSNO) + ALBSNI(IB)*FSNO
    2685. 

  2685.   END DO
    2686. 

  2686. 

  2687.   END SUBROUTINE GROUNDALB
    2688. 

  2688. ! ==================================================================================================
    2689. 

  2689. ! --------------------------------------------------------------------------------------------------
    2690. 

  2690.   SUBROUTINE TWOSTREAM (IB     ,IC      ,VEGTYP  ,COSZ    ,VAI    , & !in
    2691. 

  2691.                         FWET   ,T       ,ALBGRD  ,ALBGRI  ,RHO    , & !in
    2692. 

  2692.                         TAU    ,FVEG    ,IST     ,ILOC    ,JLOC   , & !in
    2693. 

  2693.                         FAB    ,FRE     ,FTD     ,FTI     ,GDIR   , & !)   !out
    2694. 

  2694.                         FREV   ,FREG    ,BGAP    ,WGAP    ,GAP)
    2695. 

  2695. 

  2696. ! --------------------------------------------------------------------------------------------------
    2697. 

  2697. ! use two-stream approximation of Dickinson (1983) Adv Geophysics
    2698. 

  2698. ! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372
    2699. 

  2699. ! to calculate fluxes absorbed by vegetation, reflected by vegetation,
    2700. 

  2700. ! and transmitted through vegetation for unit incoming direct or diffuse
    2701. 

  2701. ! flux given an underlying surface with known albedo.
    2702. 

  2702. ! --------------------------------------------------------------------------------------------------
    2703. 

  2703.   USE NOAHMP_VEG_PARAMETERS
    2704. 

  2704.   USE NOAHMP_RAD_PARAMETERS
    2705. 

  2705. ! --------------------------------------------------------------------------------------------------
    2706. 

  2706.   IMPLICIT NONE
    2707. 

  2707. ! --------------------------------------------------------------------------------------------------
    2708. 

  2708. ! input
    2709. 

  2709. 

  2710.    INTEGER,              INTENT(IN)  :: ILOC    !grid index
    2711. 

  2711.    INTEGER,              INTENT(IN)  :: JLOC    !grid index
    2712. 

  2712.    INTEGER,              INTENT(IN)  :: IST     !surface type
    2713. 

  2713.    INTEGER,              INTENT(IN)  :: IB      !waveband number
    2714. 

  2714.    INTEGER,              INTENT(IN)  :: IC      !0=unit incoming direct; 1=unit incoming diffuse
    2715. 

  2715.    INTEGER,              INTENT(IN)  :: VEGTYP  !vegetation type
    2716. 

  2716. 

  2717.    REAL,                 INTENT(IN)  :: COSZ    !cosine of direct zenith angle (0-1)
    2718. 

  2718.    REAL,                 INTENT(IN)  :: VAI     !one-sided leaf+stem area index (m2/m2)
    2719. 

  2719.    REAL,                 INTENT(IN)  :: FWET    !fraction of lai, sai that is wetted (-)
    2720. 

  2720.    REAL,                 INTENT(IN)  :: T       !surface temperature (k)
    2721. 

  2721. 

  2722.    REAL, DIMENSION(1:2), INTENT(IN)  :: ALBGRD  !direct  albedo of underlying surface (-)
    2723. 

  2723.    REAL, DIMENSION(1:2), INTENT(IN)  :: ALBGRI  !diffuse albedo of underlying surface (-)
    2724. 

  2724.    REAL, DIMENSION(1:2), INTENT(IN)  :: RHO     !leaf+stem reflectance
    2725. 

  2725.    REAL, DIMENSION(1:2), INTENT(IN)  :: TAU     !leaf+stem transmittance
    2726. 

  2726.    REAL,                 INTENT(IN)  :: FVEG    !green vegetation fraction [0.0-1.0]
    2727. 

  2727. 

  2728. ! output
    2729. 

  2729. 

  2730.    REAL, DIMENSION(1:2), INTENT(OUT) :: FAB     !flux abs by veg layer (per unit incoming flux)
    2731. 

  2731.    REAL, DIMENSION(1:2), INTENT(OUT) :: FRE     !flux refl above veg layer (per unit incoming flux)
    2732. 

  2732.    REAL, DIMENSION(1:2), INTENT(OUT) :: FTD     !down dir flux below veg layer (per unit in flux)
    2733. 

  2733.    REAL, DIMENSION(1:2), INTENT(OUT) :: FTI     !down dif flux below veg layer (per unit in flux)
    2734. 

  2734.    REAL,                 INTENT(OUT) :: GDIR    !projected leaf+stem area in solar direction
    2735. 

  2735.    REAL, DIMENSION(1:2), INTENT(OUT) :: FREV    !flux reflected by veg layer   (per unit incoming flux) 
    2736. 

  2736.    REAL, DIMENSION(1:2), INTENT(OUT) :: FREG    !flux reflected by ground (per unit incoming flux)
    2737. 

  2737. 

  2738. ! local
    2739. 

  2739.    REAL                              :: OMEGA   !fraction of intercepted radiation that is scattered
    2740. 

  2740.    REAL                              :: OMEGAL  !omega for leaves
    2741. 

  2741.    REAL                              :: BETAI   !upscatter parameter for diffuse radiation
    2742. 

  2742.    REAL                              :: BETAIL  !betai for leaves
    2743. 

  2743.    REAL                              :: BETAD   !upscatter parameter for direct beam radiation
    2744. 

  2744.    REAL                              :: BETADL  !betad for leaves
    2745. 

  2745.    REAL                              :: EXT     !optical depth of direct beam per unit leaf area
    2746. 

  2746.    REAL                              :: AVMU    !average diffuse optical depth
    2747. 

  2747. 

  2748.    REAL                              :: COSZI   !0.001 <= cosz <= 1.000
    2749. 

  2749.    REAL                              :: ASU     !single scattering albedo
    2750. 

  2750.    REAL                              :: CHIL    ! -0.4 <= xl <= 0.6
    2751. 

  2751. 

  2752.    REAL                              :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9
    2753. 

  2753.    REAL                              :: P1,P2,P3,P4,S1,S2,U1,U2,U3
    2754. 

  2754.    REAL                              :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10
    2755. 

  2755.    REAL                              :: PHI1,PHI2,SIGMA
    2756. 

  2756.    REAL                              :: FTDS,FTIS,FRES
    2757. 

  2757. !jref:start
    2758. 

  2758.    REAL                              :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR
    2759. 

  2759.    REAL                              :: THETAZ
    2760. 

  2760. !jref:end   
    2761. 

  2761. 

  2762. !  variables for the modified two-stream scheme
    2763. 

  2763. !  Niu and Yang (2004), JGR
    2764. 

  2764. 

  2765.    REAL, PARAMETER :: PAI = 3.14159265 
    2766. 

  2766.    REAL :: HD       !crown depth (m)
    2767. 

  2767.    REAL :: BB       !vertical crown radius (m)
    2768. 

  2768.    REAL :: THETAP   !angle conversion from SZA 
    2769. 

  2769.    REAL :: FA       !foliage volume density (m-1)
    2770. 

  2770.    REAL :: NEWVAI   !effective LSAI (-)
    2771. 

  2771. 

  2772.    REAL,INTENT(INOUT) :: BGAP     !between canopy gap fraction for beam (-)
    2773. 

  2773.    REAL,INTENT(INOUT) :: WGAP     !within canopy gap fraction for beam (-)
    2774. 

  2774. 

  2775.    REAL :: KOPEN    !gap fraction for diffue light (-)
    2776. 

  2776.    REAL, INTENT(OUT) :: GAP      !total gap fraction for beam ( <=1-shafac )
    2777. 

  2777. 

  2778. ! -----------------------------------------------------------------
    2779. 

  2779. ! compute within and between gaps
    2780. 

  2780.      if(VAI == 0.0) THEN
    2781. 

  2781.          GAP     = 1.0
    2782. 

  2782.          KOPEN   = 1.0
    2783. 

  2783.      ELSE
    2784. 

  2784.          IF(OPT_RAD == 1) THEN
    2785. 

  2785.            HD      = HVT(VEGTYP) - HVB(VEGTYP)
    2786. 

  2786.            BB      = 0.5 * HD           
    2787. 

  2787.            THETAP  = ATAN(BB/RC(VEGTYP) * TAN(ACOS(MAX(0.01,COSZ))) )
    2788. 

  2788.            BGAP    = EXP(-DEN(VEGTYP) * PAI * RC(VEGTYP)**2/COS(THETAP) )
    2789. 

  2789.            FA      = VAI/(1.33 * PAI * RC(VEGTYP)**3.0 *(BB/RC(VEGTYP))*DEN(VEGTYP))
    2790. 

  2790.            NEWVAI  = HD*FA
    2791. 

  2791.            WGAP    = (1.0-BGAP) * EXP(-0.5*NEWVAI/COSZ)
    2792. 

  2792. 

  2793. !jref - BGAP scaled to be less or equal to (1.-FVEG)           
    2794. 

  2794.            BGAP    = (1.0-FVEG)*BGAP
    2795. 

  2795.            WGAP    = FVEG*WGAP
    2796. 

  2796. 

  2797.            GAP     = MIN(1.0-FVEG, BGAP+WGAP)
    2798. 

  2798.            KOPEN   = 0.05
    2799. 

  2799.          END IF
    2800. 

  2800. 

  2801.          IF(OPT_RAD == 2) THEN
    2802. 

  2802.            GAP     = 0.0
    2803. 

  2803.            KOPEN   = 0.0
    2804. 

  2804.          END IF
    2805. 

  2805. 

  2806.          IF(OPT_RAD == 3) THEN
    2807. 

  2807.            GAP     = 1.0-FVEG
    2808. 

  2808.            KOPEN   = 0.0
    2809. 

  2809.          END IF
    2810. 

  2810.      end if
    2811. 

  2811. 

  2812. ! calculate two-stream parameters OMEGA, BETAD, BETAI, AVMU, GDIR, EXT.
    2813. 

  2813. ! OMEGA, BETAD, BETAI are adjusted for snow. values for OMEGA*BETAD
    2814. 

  2814. ! and OMEGA*BETAI are calculated and then divided by the new OMEGA
    2815. 

  2815. ! because the product OMEGA*BETAI, OMEGA*BETAD is used in solution.
    2816. 

  2816. ! also, the transmittances and reflectances (TAU, RHO) are linear
    2817. 

  2817. ! weights of leaf and stem values.
    2818. 

  2818. 

  2819.      COSZI  = MAX(0.001, COSZ)
    2820. 

  2820.      CHIL   = MIN( MAX(XL(VEGTYP), -0.4), 0.6)
    2821. 

  2821.      IF (ABS(CHIL) .LE. 0.01) CHIL = 0.01
    2822. 

  2822.      PHI1   = 0.5 - 0.633*CHIL - 0.330*CHIL*CHIL
    2823. 

  2823.      PHI2   = 0.877 * (1.-2.*PHI1)
    2824. 

  2824.      GDIR   = PHI1 + PHI2*COSZI
    2825. 

  2825.      EXT    = GDIR/COSZI
    2826. 

  2826.      AVMU   = ( 1. - PHI1/PHI2 * LOG((PHI1+PHI2)/PHI1) ) / PHI2
    2827. 

  2827.      OMEGAL = RHO(IB) + TAU(IB)
    2828. 

  2828.      TMP0   = GDIR + PHI2*COSZI
    2829. 

  2829.      TMP1   = PHI1*COSZI
    2830. 

  2830.      ASU    = 0.5*OMEGAL*GDIR/TMP0 * ( 1.-TMP1/TMP0*LOG((TMP1+TMP0)/TMP1) )
    2831. 

  2831.      BETADL = (1.+AVMU*EXT)/(OMEGAL*AVMU*EXT)*ASU
    2832. 

  2832.      BETAIL = 0.5 * ( RHO(IB)+TAU(IB) + (RHO(IB)-TAU(IB))   &
    2833. 

  2833.             * ((1.+CHIL)/2.)**2 ) / OMEGAL
    2834. 

  2834. 

  2835. ! adjust omega, betad, and betai for intercepted snow
    2836. 

  2836. 

  2837.      IF (T .GT. TFRZ) THEN                                !no snow
    2838. 

  2838.         TMP0 = OMEGAL
    2839. 

  2839.         TMP1 = BETADL
    2840. 

  2840.         TMP2 = BETAIL
    2841. 

  2841.      ELSE
    2842. 

  2842.         TMP0 =   (1.-FWET)*OMEGAL        + FWET*OMEGAS(IB)
    2843. 

  2843.         TMP1 = ( (1.-FWET)*OMEGAL*BETADL + FWET*OMEGAS(IB)*BETADS ) / TMP0
    2844. 

  2844.         TMP2 = ( (1.-FWET)*OMEGAL*BETAIL + FWET*OMEGAS(IB)*BETAIS ) / TMP0
    2845. 

  2845.      END IF
    2846. 

  2846. 

  2847.      OMEGA = TMP0
    2848. 

  2848.      BETAD = TMP1
    2849. 

  2849.      BETAI = TMP2
    2850. 

  2850. 

  2851. ! absorbed, reflected, transmitted fluxes per unit incoming radiation
    2852. 

  2852. 

  2853.      B = 1. - OMEGA + OMEGA*BETAI
    2854. 

  2854.      C = OMEGA*BETAI
    2855. 

  2855.      TMP0 = AVMU*EXT
    2856. 

  2856.      D = TMP0 * OMEGA*BETAD
    2857. 

  2857.      F = TMP0 * OMEGA*(1.-BETAD)
    2858. 

  2858.      TMP1 = B*B - C*C
    2859. 

  2859.      H = SQRT(TMP1) / AVMU
    2860. 

  2860.      SIGMA = TMP0*TMP0 - TMP1
    2861. 

  2861.      if(SIGMA == 0.) SIGMA = 1.e-6
    2862. 

  2862.      P1 = B + AVMU*H
    2863. 

  2863.      P2 = B - AVMU*H
    2864. 

  2864.      P3 = B + TMP0
    2865. 

  2865.      P4 = B - TMP0
    2866. 

  2866.      S1 = EXP(-H*VAI)
    2867. 

  2867.      S2 = EXP(-EXT*VAI)
    2868. 

  2868.      IF (IC .EQ. 0) THEN
    2869. 

  2869.         U1 = B - C/ALBGRD(IB)
    2870. 

  2870.         U2 = B - C*ALBGRD(IB)
    2871. 

  2871.         U3 = F + C*ALBGRD(IB)
    2872. 

  2872.      ELSE
    2873. 

  2873.         U1 = B - C/ALBGRI(IB)
    2874. 

  2874.         U2 = B - C*ALBGRI(IB)
    2875. 

  2875.         U3 = F + C*ALBGRI(IB)
    2876. 

  2876.      END IF
    2877. 

  2877.      TMP2 = U1 - AVMU*H
    2878. 

  2878.      TMP3 = U1 + AVMU*H
    2879. 

  2879.      D1 = P1*TMP2/S1 - P2*TMP3*S1
    2880. 

  2880.      TMP4 = U2 + AVMU*H
    2881. 

  2881.      TMP5 = U2 - AVMU*H
    2882. 

  2882.      D2 = TMP4/S1 - TMP5*S1
    2883. 

  2883.      H1 = -D*P4 - C*F
    2884. 

  2884.      TMP6 = D - H1*P3/SIGMA
    2885. 

  2885.      TMP7 = ( D - C - H1/SIGMA*(U1+TMP0) ) * S2
    2886. 

  2886.      H2 = ( TMP6*TMP2/S1 - P2*TMP7 ) / D1
    2887. 

  2887.      H3 = - ( TMP6*TMP3*S1 - P1*TMP7 ) / D1
    2888. 

  2888.      H4 = -F*P3 - C*D
    2889. 

  2889.      TMP8 = H4/SIGMA
    2890. 

  2890.      TMP9 = ( U3 - TMP8*(U2-TMP0) ) * S2
    2891. 

  2891.      H5 = - ( TMP8*TMP4/S1 + TMP9 ) / D2
    2892. 

  2892.      H6 = ( TMP8*TMP5*S1 + TMP9 ) / D2
    2893. 

  2893.      H7 = (C*TMP2) / (D1*S1)
    2894. 

  2894.      H8 = (-C*TMP3*S1) / D1
    2895. 

  2895.      H9 = TMP4 / (D2*S1)
    2896. 

  2896.      H10 = (-TMP5*S1) / D2
    2897. 

  2897. 

  2898. ! downward direct and diffuse fluxes below vegetation
    2899. 

  2899. ! Niu and Yang (2004), JGR.
    2900. 

  2900. 

  2901.      IF (IC .EQ. 0) THEN
    2902. 

  2902.         FTDS = S2                           *(1.0-GAP) + GAP
    2903. 

  2903.         FTIS = (H4*S2/SIGMA + H5*S1 + H6/S1)*(1.0-GAP)
    2904. 

  2904.      ELSE
    2905. 

  2905.         FTDS = 0.
    2906. 

  2906.         FTIS = (H9*S1 + H10/S1)*(1.0-KOPEN) + KOPEN
    2907. 

  2907.      END IF
    2908. 

  2908.      FTD(IB) = FTDS
    2909. 

  2909.      FTI(IB) = FTIS
    2910. 

  2910. 

  2911. ! flux reflected by the surface (veg. and ground)
    2912. 

  2912. 

  2913.      IF (IC .EQ. 0) THEN
    2914. 

  2914.         FRES = (H1/SIGMA + H2 + H3)*(1.0-GAP  ) + ALBGRD(IB)*GAP
    2915. 

  2915. !jref - separate veg. and ground reflection        
    2916. 

  2916.         FREVEG = (H1/SIGMA + H2 + H3)*(1.0-GAP  ) 
    2917. 

  2917.         FREBAR = ALBGRD(IB)*GAP
    2918. 

  2918.      ELSE
    2919. 

  2919.         FRES = (H7 + H8)           *(1.0-KOPEN) + ALBGRI(IB)*KOPEN
    2920. 

  2920. !jref - separate veg. and ground reflection        
    2921. 

  2921.         FREVEG = (H7 + H8)           *(1.0-KOPEN)+ALBGRI(IB)*KOPEN
    2922. 

  2922.         FREBAR = 0
    2923. 

  2923.      END IF
    2924. 

  2924.      FRE(IB) = FRES
    2925. 

  2925. 

  2926.      FREV(IB) = FREVEG 
    2927. 

  2927.      FREG(IB) = FREBAR 
    2928. 

  2928. 

  2929. ! flux absorbed by vegetation
    2930. 

  2930. 

  2931.      FAB(IB) = 1. - FRE(IB) - (1.-ALBGRD(IB))*FTD(IB) &
    2932. 

  2932.                             - (1.-ALBGRI(IB))*FTI(IB)
    2933. 

  2933. 

  2934.   END SUBROUTINE TWOSTREAM
    2935. 

  2935. ! ==================================================================================================
    2936. 

  2936.   SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
    2937. 

  2937.                        DT      ,SAV     ,SAG     ,LWDN    ,UR      , & !in
    2938. 

  2938.                        UU      ,VV      ,SFCTMP  ,THAIR   ,QAIR    , & !in
    2939. 

  2939.                        EAIR    ,RHOAIR  ,SNOWH   ,VAI     ,GAMMA   , & !in
    2940. 

  2940.                        FWET    ,LAISUN  ,LAISHA  ,CWP     ,DZSNSO  , & !in
    2941. 

  2941.                        HTOP    ,ZLVL    ,ZPD     ,Z0M     ,FVEG    , & !in
    2942. 

  2942.                        Z0MG    ,EMV     ,EMG     ,CANLIQ  ,          & !in
    2943. 

  2943.                        CANICE  ,STC     ,DF      ,RSSUN   ,RSSHA   , & !in
    2944. 

  2944.                        RSURF   ,LATHEA  ,PARSUN  ,PARSHA  ,IGS     , & !in
    2945. 

  2945.                        FOLN    ,CO2AIR  ,O2AIR   ,BTRAN   ,SFCPRS  , & !in
    2946. 

  2946.                        RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
    2947. 

  2947.                        EAH     ,TAH     ,TV      ,TG      ,CM      , & !inout
    2948. 

  2948.                        CH      ,DX      ,DZ8W    ,                   & !
    2949. 

  2949.                        TAUXV   ,TAUYV   ,IRG     ,IRC     ,SHG     , & !out
    2950. 

  2950.                        SHC     ,EVG     ,EVC     ,TR      ,GH      , & !out
    2951. 

  2951.                        T2MV    ,PSNSUN  ,PSNSHA  ,                   & !out
    2952. 

  2952.                        QC      ,PBLH    ,QSFC    ,PSFC    ,ISURBAN , & !in
    2953. 

  2953.                        IZ0TLND ,Q2V     ,CAH2)              !inout 
    2954. 

  2954. 

  2955. ! --------------------------------------------------------------------------------------------------
    2956. 

  2956. ! use newton-raphson iteration to solve for vegetation (tv) and
    2957. 

  2957. ! ground (tg) temperatures that balance the surface energy budgets
    2958. 

  2958. 

  2959. ! vegetated:
    2960. 

  2960. ! -SAV + IRC[TV] + SHC[TV] + EVC[TV] + TR[TV] = 0
    2961. 

  2961. ! -SAG + IRG[TG] + SHG[TG] + EVG[TG] + GH[TG] = 0
    2962. 

  2962. ! --------------------------------------------------------------------------------------------------
    2963. 

  2963.   USE NOAHMP_VEG_PARAMETERS
    2964. 

  2964.   USE MODULE_MODEL_CONSTANTS
    2965. 

  2965. ! --------------------------------------------------------------------------------------------------
    2966. 

  2966.   IMPLICIT NONE
    2967. 

  2967. ! --------------------------------------------------------------------------------------------------
    2968. 

  2968. ! input
    2969. 

  2969.   INTEGER,                         INTENT(IN) :: ILOC   !grid index
    2970. 

  2970.   INTEGER,                         INTENT(IN) :: JLOC   !grid index
    2971. 

  2971.   LOGICAL,                         INTENT(IN) :: VEG    !true if vegetated surface
    2972. 

  2972.   INTEGER,                         INTENT(IN) :: NSNOW  !maximum no. of snow layers        
    2973. 

  2973.   INTEGER,                         INTENT(IN) :: NSOIL  !number of soil layers
    2974. 

  2974.   INTEGER,                         INTENT(IN) :: ISNOW  !actual no. of snow layers
    2975. 

  2975.   INTEGER,                         INTENT(IN) :: VEGTYP !vegetation physiology type
    2976. 

  2976.   REAL,                            INTENT(IN) :: FVEG   !greeness vegetation fraction (-)
    2977. 

  2977.   REAL,                            INTENT(IN) :: SAV    !solar rad absorbed by veg (w/m2)
    2978. 

  2978.   REAL,                            INTENT(IN) :: SAG    !solar rad absorbed by ground (w/m2)
    2979. 

  2979.   REAL,                            INTENT(IN) :: LWDN   !atmospheric longwave radiation (w/m2)
    2980. 

  2980.   REAL,                            INTENT(IN) :: UR     !wind speed at height zlvl (m/s)
    2981. 

  2981.   REAL,                            INTENT(IN) :: UU     !wind speed in eastward dir (m/s)
    2982. 

  2982.   REAL,                            INTENT(IN) :: VV     !wind speed in northward dir (m/s)
    2983. 

  2983.   REAL,                            INTENT(IN) :: SFCTMP !air temperature at reference height (k)
    2984. 

  2984.   REAL,                            INTENT(IN) :: THAIR  !potential temp at reference height (k)
    2985. 

  2985.   REAL,                            INTENT(IN) :: EAIR   !vapor pressure air at zlvl (pa)
    2986. 

  2986.   REAL,                            INTENT(IN) :: QAIR   !specific humidity at zlvl (kg/kg)
    2987. 

  2987.   REAL,                            INTENT(IN) :: RHOAIR !density air (kg/m**3)
    2988. 

  2988.   REAL,                            INTENT(IN) :: DT     !time step (s)
    2989. 

  2989. 

  2990.   REAL,                            INTENT(IN) :: SNOWH  !actual snow depth [m]
    2991. 

  2991.   REAL,                            INTENT(IN) :: FWET   !wetted fraction of canopy
    2992. 

  2992.   REAL,                            INTENT(IN) :: HTOP   !top of canopy layer (m)
    2993. 

  2993.   REAL,                            INTENT(IN) :: CWP    !canopy wind parameter
    2994. 

  2994. 

  2995.   REAL,                            INTENT(IN) :: VAI    !total leaf area index + stem area index
    2996. 

  2996.   REAL,                            INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided (m2/m2)
    2997. 

  2997.   REAL,                            INTENT(IN) :: LAISHA !shaded leaf area index, one-sided (m2/m2)
    2998. 

  2998.   REAL,                            INTENT(IN) :: ZLVL   !reference height (m)
    2999. 

  2999.   REAL,                            INTENT(IN) :: ZPD    !zero plane displacement (m)
    3000. 

  3000.   REAL,                            INTENT(IN) :: Z0M    !roughness length, momentum (m)
    3001. 

  3001.   REAL,                            INTENT(IN) :: Z0MG   !roughness length, momentum, ground (m)
    3002. 

  3002.   REAL,                            INTENT(IN) :: EMV    !vegetation emissivity
    3003. 

  3003.   REAL,                            INTENT(IN) :: EMG    !ground emissivity
    3004. 

  3004. 

  3005.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC    !soil/snow temperature (k)
    3006. 

  3006.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF     !thermal conductivity of snow/soil (w/m/k)
    3007. 

  3007.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thinkness of snow/soil layers (m)
    3008. 

  3008.   REAL,                            INTENT(IN) :: CANLIQ !intercepted liquid water (mm)
    3009. 

  3009.   REAL,                            INTENT(IN) :: CANICE !intercepted ice mass (mm)
    3010. 

  3010.   REAL,                            INTENT(IN) :: RSURF  !ground surface resistance (s/m)
    3011. 

  3011.   REAL,                            INTENT(IN) :: GAMMA  !psychrometric constant (pa/K)
    3012. 

  3012.   REAL,                            INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg)
    3013. 

  3013.   REAL,                            INTENT(IN) :: PARSUN !par absorbed per unit sunlit lai (w/m2)
    3014. 

  3014.   REAL,                            INTENT(IN) :: PARSHA !par absorbed per unit shaded lai (w/m2)
    3015. 

  3015.   REAL,                            INTENT(IN) :: FOLN   !foliage nitrogen (%)
    3016. 

  3016.   REAL,                            INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa)
    3017. 

  3017.   REAL,                            INTENT(IN) :: O2AIR  !atmospheric o2 concentration (pa)
    3018. 

  3018.   REAL,                            INTENT(IN) :: IGS    !growing season index (0=off, 1=on)
    3019. 

  3019.   REAL,                            INTENT(IN) :: SFCPRS !pressure (pa)
    3020. 

  3020.   REAL,                            INTENT(IN) :: BTRAN  !soil water transpiration factor (0 to 1)
    3021. 

  3021.   REAL,                            INTENT(IN) :: RHSUR  !raltive humidity in surface soil/snow air space (-)
    3022. 

  3022. 

  3023.   INTEGER                        , INTENT(IN) :: ISURBAN
    3024. 

  3024.   INTEGER                        , INTENT(IN) :: IZ0TLND
    3025. 

  3025.   REAL                           , INTENT(IN) :: QC     !cloud water mixing ratio
    3026. 

  3026.   REAL                           , INTENT(IN) :: PBLH   !planetary boundary layer height
    3027. 

  3027.   REAL                           , INTENT(IN) :: PSFC   !pressure at lowest model layer
    3028. 

  3028.   REAL                           , INTENT(IN) :: DX     !grid spacing
    3029. 

  3029.   REAL                           , INTENT(IN) :: Q2     !mixing ratio (kg/kg)
    3030. 

  3030.   REAL                           , INTENT(IN) :: DZ8W   !thickness of lowest layer
    3031. 

  3031.   REAL                           , INTENT(INOUT) :: QSFC   !mixing ratio at lowest model layer
    3032. 

  3032. 

  3033. ! input/output
    3034. 

  3034.   REAL,                         INTENT(INOUT) :: EAH    !canopy air vapor pressure (pa)
    3035. 

  3035.   REAL,                         INTENT(INOUT) :: TAH    !canopy air temperature (k)
    3036. 

  3036.   REAL,                         INTENT(INOUT) :: TV     !vegetation temperature (k)
    3037. 

  3037.   REAL,                         INTENT(INOUT) :: TG     !ground temperature (k)
    3038. 

  3038.   REAL,                         INTENT(INOUT) :: CM     !momentum drag coefficient
    3039. 

  3039.   REAL,                         INTENT(INOUT) :: CH     !sensible heat exchange coefficient
    3040. 

  3040. 

  3041. ! output
    3042. 

  3042. ! -FSA + FIRA + FSH + (FCEV + FCTR + FGEV) + FCST + SSOIL = 0
    3043. 

  3043.   REAL,                           INTENT(OUT) :: TAUXV  !wind stress: e-w (n/m2)
    3044. 

  3044.   REAL,                           INTENT(OUT) :: TAUYV  !wind stress: n-s (n/m2)
    3045. 

  3045.   REAL,                           INTENT(OUT) :: IRC    !net longwave radiation (w/m2) [+= to atm]
    3046. 

  3046.   REAL,                           INTENT(OUT) :: SHC    !sensible heat flux (w/m2)     [+= to atm]
    3047. 

  3047.   REAL,                           INTENT(OUT) :: EVC    !evaporation heat flux (w/m2)  [+= to atm]
    3048. 

  3048.   REAL,                           INTENT(OUT) :: IRG    !net longwave radiation (w/m2) [+= to atm]
    3049. 

  3049.   REAL,                           INTENT(OUT) :: SHG    !sensible heat flux (w/m2)     [+= to atm]
    3050. 

  3050.   REAL,                           INTENT(OUT) :: EVG    !evaporation heat flux (w/m2)  [+= to atm]
    3051. 

  3051.   REAL,                           INTENT(OUT) :: TR     !transpiration heat flux (w/m2)[+= to atm]
    3052. 

  3052.   REAL,                           INTENT(OUT) :: GH     !ground heat (w/m2) [+ = to soil]
    3053. 

  3053.   REAL,                           INTENT(OUT) :: T2MV   !2 m height air temperature (k)
    3054. 

  3054.   REAL,                           INTENT(OUT) :: PSNSUN !sunlit leaf photosynthesis (umolco2/m2/s)
    3055. 

  3055.   REAL,                           INTENT(OUT) :: PSNSHA !shaded leaf photosynthesis (umolco2/m2/s)
    3056. 

  3056. 

  3057.   REAL,                           INTENT(OUT) :: Q2V
    3058. 

  3058.   REAL :: CAH    !sensible heat conductance, canopy air to ZLVL air (m/s)
    3059. 

  3059.   REAL :: U10V    !10 m wind speed in eastward dir (m/s) 
    3060. 

  3060.   REAL :: V10V    !10 m wind speed in eastward dir (m/s) 
    3061. 

  3061.   REAL :: WSPD
    3062. 

  3062. 

  3063. ! ------------------------ local variables ----------------------------------------------------
    3064. 

  3064.   REAL :: CW           !water vapor exchange coefficient
    3065. 

  3065.   REAL :: FV           !friction velocity (m/s)
    3066. 

  3066.   REAL :: WSTAR        !friction velocity n vertical direction (m/s) (only for SFCDIF2)
    3067. 

  3067.   REAL :: Z0H          !roughness length, sensible heat (m)
    3068. 

  3068.   REAL :: Z0HG         !roughness length, sensible heat (m)
    3069. 

  3069.   REAL :: RB           !bulk leaf boundary layer resistance (s/m)
    3070. 

  3070.   REAL :: RAMC         !aerodynamic resistance for momentum (s/m)
    3071. 

  3071.   REAL :: RAHC         !aerodynamic resistance for sensible heat (s/m)
    3072. 

  3072.   REAL :: RAWC         !aerodynamic resistance for water vapor (s/m)
    3073. 

  3073.   REAL :: RAMG         !aerodynamic resistance for momentum (s/m)
    3074. 

  3074.   REAL :: RAHG         !aerodynamic resistance for sensible heat (s/m)
    3075. 

  3075.   REAL :: RAWG         !aerodynamic resistance for water vapor (s/m)
    3076. 

  3076. 

  3077.   REAL, INTENT(OUT) :: RSSUN        !sunlit leaf stomatal resistance (s/m)
    3078. 

  3078.   REAL, INTENT(OUT) :: RSSHA        !shaded leaf stomatal resistance (s/m)
    3079. 

  3079. 

  3080.   REAL :: MOL          !Monin-Obukhov length (m)
    3081. 

  3081.   REAL :: DTV          !change in tv, last iteration (k)
    3082. 

  3082.   REAL :: DTG          !change in tg, last iteration (k)
    3083. 

  3083. 

  3084.   REAL :: AIR,CIR      !coefficients for ir as function of ts**4
    3085. 

  3085.   REAL :: CSH          !coefficients for sh as function of ts
    3086. 

  3086.   REAL :: CEV          !coefficients for ev as function of esat[ts]
    3087. 

  3087.   REAL :: CGH          !coefficients for st as function of ts
    3088. 

  3088.   REAL :: ATR,CTR      !coefficients for tr as function of esat[ts]
    3089. 

  3089.   REAL :: ATA,BTA      !coefficients for tah as function of ts
    3090. 

  3090.   REAL :: AEA,BEA      !coefficients for eah as function of esat[ts]
    3091. 

  3091. 

  3092.   REAL :: ESTV         !saturation vapor pressure at tv (pa)
    3093. 

  3093.   REAL :: ESTG         !saturation vapor pressure at tg (pa)
    3094. 

  3094.   REAL :: DESTV        !d(es)/dt at ts (pa/k)
    3095. 

  3095.   REAL :: DESTG        !d(es)/dt at tg (pa/k)
    3096. 

  3096.   REAL :: ESATW        !es for water
    3097. 

  3097.   REAL :: ESATI        !es for ice
    3098. 

  3098.   REAL :: DSATW        !d(es)/dt at tg (pa/k) for water
    3099. 

  3099.   REAL :: DSATI        !d(es)/dt at tg (pa/k) for ice
    3100. 

  3100. 

  3101.   REAL :: FM           !momentum stability correction, weighted by prior iters
    3102. 

  3102.   REAL :: FH           !sen heat stability correction, weighted by prior iters
    3103. 

  3103.   REAL :: FHG          !sen heat stability correction, ground
    3104. 

  3104.   REAL :: HCAN         !canopy height (m) [note: hcan >= z0mg]
    3105. 

  3105. 

  3106.   REAL :: A            !temporary calculation
    3107. 

  3107.   REAL :: B            !temporary calculation
    3108. 

  3108.   REAL :: CVH          !sensible heat conductance, leaf surface to canopy air (m/s)
    3109. 

  3109.   REAL :: CAW          !latent heat conductance, canopy air ZLVL air (m/s)
    3110. 

  3110.   REAL :: CTW          !transpiration conductance, leaf to canopy air (m/s)
    3111. 

  3111.   REAL :: CEW          !evaporation conductance, leaf to canopy air (m/s)
    3112. 

  3112.   REAL :: CGW          !latent heat conductance, ground to canopy air (m/s)
    3113. 

  3113.   REAL :: COND         !sum of conductances (s/m)
    3114. 

  3114.   REAL :: UC           !wind speed at top of canopy (m/s)
    3115. 

  3115.   REAL :: KH           !turbulent transfer coefficient, sensible heat, (m2/s)
    3116. 

  3116.   REAL :: H            !temporary sensible heat flux (w/m2)
    3117. 

  3117.   REAL :: HG           !temporary sensible heat flux (w/m2)
    3118. 

  3118.   REAL :: MOZ          !Monin-Obukhov stability parameter
    3119. 

  3119.   REAL :: MOZG         !Monin-Obukhov stability parameter
    3120. 

  3120.   REAL :: MOZOLD       !Monin-Obukhov stability parameter from prior iteration
    3121. 

  3121.   
    3122. 

  3122. 

  3123.   REAL :: THVAIR
    3124. 

  3124.   REAL :: THAH 
    3125. 

  3125.   REAL :: RAHC2        !aerodynamic resistance for sensible heat (s/m)
    3126. 

  3126.   REAL :: RAWC2        !aerodynamic resistance for water vapor (s/m)
    3127. 

  3127.   REAL, INTENT(OUT):: CAH2         !sensible heat conductance for diagnostics
    3128. 

  3128.   REAL :: CH2V         !exchange coefficient for 2m over vegetation. 
    3129. 

  3129.   REAL :: CQ2V         !exchange coefficient for 2m over vegetation. 
    3130. 

  3130.   REAL :: EAH2         !2m vapor pressure over canopy
    3131. 

  3131.   REAL :: QFX        !moisture flux
    3132. 

  3132.   REAL :: E1           
    3133. 

  3133. 

  3134. 

  3135.   REAL :: VAIE         !total leaf area index + stem area index,effective
    3136. 

  3136.   REAL :: LAISUNE      !sunlit leaf area index, one-sided (m2/m2),effective
    3137. 

  3137.   REAL :: LAISHAE      !shaded leaf area index, one-sided (m2/m2),effective
    3138. 

  3138. 

  3139.   INTEGER :: K         !index
    3140. 

  3140.   INTEGER :: ITER      !iteration index
    3141. 

  3141. 

  3142. !jref - NITERC test from 5 to 20  
    3143. 

  3143.   INTEGER, PARAMETER :: NITERC = 20   !number of iterations for surface temperature
    3144. 

  3144. !jref - NITERG test from 3-5
    3145. 

  3145.   INTEGER, PARAMETER :: NITERG = 5   !number of iterations for ground temperature
    3146. 

  3146.   INTEGER :: MOZSGN    !number of times MOZ changes sign
    3147. 

  3147.   REAL    :: MPE       !prevents overflow error if division by zero
    3148. 

  3148. 

  3149.   INTEGER :: LITER     !Last iteration
    3150. 

  3150. 

  3151. 

  3152.   REAL :: T, TDC       !Kelvin to degree Celsius with limit -50 to +50
    3153. 

  3153. 

  3154.   character(len=80) ::  message
    3155. 

  3155. 

  3156.   TDC(T)   = MIN( 50., MAX(-50.,(T-TFRZ)) )
    3157. 

  3157. ! ---------------------------------------------------------------------------------------------
    3158. 

  3158. 

  3159.         MPE = 1E-6
    3160. 

  3160.         LITER = 0
    3161. 

  3161.         FV = 0.1
    3162. 

  3162. 

  3163. ! ---------------------------------------------------------------------------------------------
    3164. 

  3164. ! initialization variables that do not depend on stability iteration
    3165. 

  3165. ! ---------------------------------------------------------------------------------------------
    3166. 

  3166.         DTV = 0.
    3167. 

  3167.         DTG = 0.
    3168. 

  3168.         MOZSGN = 0
    3169. 

  3169.         MOZOLD = 0.
    3170. 

  3170.         HG     = 0.
    3171. 

  3171.         H      = 0.
    3172. 

  3172.         QFX    = 0.
    3173. 

  3173. 

  3174. ! convert grid-cell LAI to the fractional vegetated area (FVEG)
    3175. 

  3175. 

  3176.         VAIE    = MIN(6.,VAI    / FVEG)
    3177. 

  3177.         LAISUNE = MIN(6.,LAISUN / FVEG)
    3178. 

  3178.         LAISHAE = MIN(6.,LAISHA / FVEG)
    3179. 

  3179. 

  3180. ! saturation vapor pressure at ground temperature
    3181. 

  3181. 

  3182.         T = TDC(TG)
    3183. 

  3183.         CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
    3184. 

  3184.         IF (T .GT. 0.) THEN
    3185. 

  3185.            ESTG = ESATW
    3186. 

  3186.         ELSE
    3187. 

  3187.            ESTG = ESATI
    3188. 

  3188.         END IF
    3189. 

  3189. 

  3190. !jref - consistent surface specific humidity for sfcdif3 and sfcdif4
    3191. 

  3191. 

  3192.         QSFC = 0.622*EAIR/(PSFC-0.378*EAIR)  
    3193. 

  3193. 

  3194. ! canopy height
    3195. 

  3195. 

  3196.         HCAN = HTOP
    3197. 

  3197.         UC = UR*LOG(HCAN/Z0M)/LOG(ZLVL/Z0M)
    3198. 

  3198.         IF((HCAN-ZPD) <= 0.) THEN
    3199. 

  3199.           WRITE(message,*) "CRITICAL PROBLEM: HCAN <= ZPD"
    3200. 

  3200.           call wrf_message ( message )
    3201. 

  3201.           WRITE(message,*) 'i,j point=',ILOC, JLOC
    3202. 

  3202.           call wrf_message ( message )
    3203. 

  3203.           WRITE(message,*) 'HCAN  =',HCAN
    3204. 

  3204.           call wrf_message ( message )
    3205. 

  3205.           WRITE(message,*) 'ZPD   =',ZPD
    3206. 

  3206.           call wrf_message ( message )
    3207. 

  3207.           write (message, *) 'SNOWH =',SNOWH
    3208. 

  3208.           call wrf_message ( message )
    3209. 

  3209.           call wrf_error_fatal ( "CRITICAL PROBLEM IN MODULE_SF_NOAHMPLSM:VEGEFLUX" )
    3210. 

  3210.         END IF
    3211. 

  3211. 

  3212. ! prepare for longwave rad.
    3213. 

  3213. 

  3214.         AIR = -EMV*(1.+(1.-EMV)*(1.-EMG))*LWDN - EMV*EMG*SB*TG**4  
    3215. 

  3215.         CIR = (2.-EMV*(1.-EMG))*EMV*SB
    3216. 

  3216. ! ---------------------------------------------------------------------------------------------
    3217. 

  3217.       loop1: DO ITER = 1, NITERC    !  begin stability iteration
    3218. 

  3218. 

  3219.        IF(ITER == 1) THEN
    3220. 

  3220.             Z0H  = Z0M  
    3221. 

  3221.             Z0HG = Z0MG
    3222. 

  3222.        ELSE
    3223. 

  3223.             Z0H  = Z0M    !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M))
    3224. 

  3224.             Z0HG = Z0MG   !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0MG))
    3225. 

  3225.        END IF
    3226. 

  3226. 

  3227. ! aerodyn resistances between heights zlvl and d+z0v
    3228. 

  3228. 

  3229.        IF(OPT_SFC == 1) THEN
    3230. 

  3230.           CALL SFCDIF1(ITER   ,SFCTMP ,RHOAIR ,H      ,QAIR   , & !in
    3231. 

  3231.                        ZLVL   ,ZPD    ,Z0M    ,Z0H    ,UR     , & !in
    3232. 

  3232.                        MPE    ,ILOC   ,JLOC   ,                 & !in
    3233. 

  3233.                        MOZ    ,MOZSGN ,FM     ,FH     ,         & !inout
    3234. 

  3234.                        CM     ,CH     ,FV     )                   !out
    3235. 

  3235.        ENDIF
    3236. 

  3236.      
    3237. 

  3237.        IF(OPT_SFC == 2) THEN
    3238. 

  3238.           CALL SFCDIF2(ITER   ,Z0M    ,TAH    ,THAIR  ,UR     , & !in
    3239. 

  3239.                        CZIL   ,ZLVL   ,ILOC   ,JLOC   ,         & !in
    3240. 

  3240.                        CM     ,CH     ,MOZ    ,WSTAR  ,         & !in
    3241. 

  3241.                        FV     )                                   !out
    3242. 

  3242.           ! Undo the multiplication by windspeed that SFCDIF2 
    3243. 

  3243.           ! applies to exchange coefficients CH and CM:
    3244. 

  3244.           CH = CH / UR
    3245. 

  3245.           CM = CM / UR
    3246. 

  3246.        ENDIF
    3247. 

  3247. 

  3248.        IF(OPT_SFC == 3) THEN
    3249. 

  3249.           CALL SFCDIF3(ILOC   ,JLOC   ,TAH    ,QSFC   ,PSFC   ,&  !in 
    3250. 

  3250.                        PBLH   ,Z0M    ,Z0MG   ,VEGTYP ,ISURBAN,&  !in
    3251. 

  3251.                        IZ0TLND,UC     ,ITER   ,NITERC ,SFCTMP ,&  !in
    3252. 

  3252.                        THAIR  ,QAIR   ,QC     ,ZLVL   , &  !in
    3253. 

  3253.                        SFCPRS ,FV     ,CM     ,CH     ,CH2V   ,&  !inout
    3254. 

  3254.                        CQ2V   ,MOZ)                               !out
    3255. 

  3255.           ! Undo the multiplication by windspeed that SFCDIF3 
    3256. 

  3256.           ! applies to exchange coefficients CH and CM:
    3257. 

  3257.           CH   = CH / UR
    3258. 

  3258.           CM   = CM / UR
    3259. 

  3259.           CH2V = CH2V / UR
    3260. 

  3260.        ENDIF
    3261. 

  3261. 

  3262.        IF(OPT_SFC == 4) THEN
    3263. 

  3263.           CALL SFCDIF4(ILOC   ,JLOC   ,UU     ,VV     ,SFCTMP ,&  !in
    3264. 

  3264.                        SFCPRS ,PSFC   ,PBLH   ,DX     ,Z0M    ,&
    3265. 

  3265.                        TAH    ,QAIR   ,ZLVL   ,IZ0TLND,QSFC   ,&
    3266. 

  3266.                        H      ,QFX    ,CM     ,CH     ,CH2V   ,& 
    3267. 

  3267.                        CQ2V   ,MOZ    ,FV     ,U10V   ,V10V)
    3268. 

  3268.           ! Undo the multiplication by windspeed that SFCDIF4 
    3269. 

  3269.           ! applies to exchange coefficients CH and CM:
    3270. 

  3270.           CH   = CH / UR
    3271. 

  3271.           CM   = CM / UR
    3272. 

  3272.           CH2V = CH2V / UR
    3273. 

  3273.        ENDIF
    3274. 

  3274. 

  3275.        RAMC = MAX(1.,1./(CM*UR))
    3276. 

  3276.        RAHC = MAX(1.,1./(CH*UR))
    3277. 

  3277.        RAWC = RAHC
    3278. 

  3278. 

  3279.        IF (OPT_SFC == 3 .OR. OPT_SFC == 4 ) THEN
    3280. 

  3280.          RAHC2 = MAX(1.,1./(CH2V*UR))
    3281. 

  3281.          RAWC2 = RAHC2
    3282. 

  3282.          CAH2 = 1./RAHC2
    3283. 

  3283.          CQ2V = CAH2
    3284. 

  3284.        ENDIF
    3285. 

  3285. 

  3286. ! aerodyn resistance between heights z0g and d+z0v, RAG, and leaf
    3287. 

  3287. ! boundary layer resistance, RB
    3288. 

  3288.        
    3289. 

  3289.        CALL RAGRB(ITER   ,VAIE   ,RHOAIR ,HG     ,TAH    , & !in
    3290. 

  3290.                   ZPD    ,Z0MG   ,Z0HG   ,HCAN   ,UC     , & !in
    3291. 

  3291.                   Z0H    ,FV     ,CWP    ,VEGTYP ,MPE    , & !in
    3292. 

  3292.                   TV     ,MOZG   ,FHG    ,ILOC   ,JLOC   , & !inout
    3293. 

  3293.                   RAMG   ,RAHG   ,RAWG   ,RB     )           !out
    3294. 

  3294. 

  3295. ! es and d(es)/dt evaluated at tv
    3296. 

  3296. 

  3297.        T = TDC(TV)
    3298. 

  3298.        CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
    3299. 

  3299.        IF (T .GT. 0.) THEN
    3300. 

  3300.           ESTV  = ESATW
    3301. 

  3301.           DESTV = DSATW
    3302. 

  3302.        ELSE
    3303. 

  3303.           ESTV  = ESATI
    3304. 

  3304.           DESTV = DSATI
    3305. 

  3305.        END IF
    3306. 

  3306. 

  3307. ! stomatal resistance
    3308. 

  3308.         
    3309. 

  3309.      IF(ITER == 1) THEN
    3310. 

  3310.         IF (OPT_CRS == 1) then  ! Ball-Berry
    3311. 

  3311.          CALL STOMATA (VEGTYP,MPE   ,PARSUN ,FOLN  ,ILOC  , JLOC , & !in       
    3312. 

  3312.                        TV    ,ESTV  ,EAH    ,SFCTMP,SFCPRS, & !in
    3313. 

  3313.                        O2AIR ,CO2AIR,IGS    ,BTRAN ,RB    , & !in
    3314. 

  3314.                        RSSUN ,PSNSUN)                         !out
    3315. 

  3315. 

  3316.          CALL STOMATA (VEGTYP,MPE   ,PARSHA ,FOLN  ,ILOC  , JLOC , & !in
    3317. 

  3317.                        TV    ,ESTV  ,EAH    ,SFCTMP,SFCPRS, & !in
    3318. 

  3318.                        O2AIR ,CO2AIR,IGS    ,BTRAN ,RB    , & !in
    3319. 

  3319.                        RSSHA ,PSNSHA)                         !out
    3320. 

  3320.         END IF
    3321. 

  3321. 

  3322.         IF (OPT_CRS == 2) then  ! Jarvis
    3323. 

  3323.          CALL  CANRES (PARSUN,TV    ,BTRAN ,EAH    ,SFCPRS, & !in
    3324. 

  3324.                        RSSUN ,PSNSUN,ILOC  ,JLOC   )          !out
    3325. 

  3325. 

  3326.          CALL  CANRES (PARSHA,TV    ,BTRAN ,EAH    ,SFCPRS, & !in
    3327. 

  3327.                        RSSHA ,PSNSHA,ILOC  ,JLOC   )          !out
    3328. 

  3328.         END IF
    3329. 

  3329.      END IF
    3330. 

  3330. 

  3331. ! prepare for sensible heat flux above veg.
    3332. 

  3332. 

  3333.         CAH  = 1./RAHC
    3334. 

  3334.         CVH  = 2.*VAIE/RB
    3335. 

  3335.         CGH  = 1./RAHG
    3336. 

  3336.         COND = CAH + CVH + CGH
    3337. 

  3337.         ATA  = (SFCTMP*CAH + TG*CGH) / COND
    3338. 

  3338.         BTA  = CVH/COND
    3339. 

  3339.         CSH  = (1.-BTA)*RHOAIR*CPAIR*CVH
    3340. 

  3340. 

  3341. ! prepare for latent heat flux above veg.
    3342. 

  3342. 

  3343.         CAW  = 1./RAWC
    3344. 

  3344.         CEW  = FWET*VAIE/RB
    3345. 

  3345.         CTW  = (1.-FWET)*(LAISUNE/(RB+RSSUN) + LAISHAE/(RB+RSSHA))
    3346. 

  3346.         CGW  = 1./(RAWG+RSURF)
    3347. 

  3347.         COND = CAW + CEW + CTW + CGW
    3348. 

  3348.         AEA  = (EAIR*CAW + ESTG*CGW) / COND
    3349. 

  3349.         BEA  = (CEW+CTW)/COND
    3350. 

  3350.         CEV  = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMA
    3351. 

  3351.         CTR  = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMA
    3352. 

  3352. 

  3353. ! evaluate surface fluxes with current temperature and solve for dts
    3354. 

  3354. 

  3355.         TAH = ATA + BTA*TV               ! canopy air T.
    3356. 

  3356.         EAH = AEA + BEA*ESTV             ! canopy air e
    3357. 

  3357. 

  3358.         IRC = AIR + CIR*TV**4
    3359. 

  3359.         SHC = RHOAIR*CPAIR*CVH * (  TV-TAH)
    3360. 

  3360.         EVC = RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMA
    3361. 

  3361.         TR  = RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMA
    3362. 

  3362.         EVC = MIN(CANLIQ*LATHEA/DT,EVC)
    3363. 

  3363. 

  3364.         B   = SAV-IRC-SHC-EVC-TR                          !additional w/m2
    3365. 

  3365.         A   = 4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV !volumetric heat capacity
    3366. 

  3366.         DTV = B/A
    3367. 

  3367. 

  3368.         IRC = IRC + 4.*CIR*TV**3*DTV
    3369. 

  3369.         SHC = SHC + CSH*DTV
    3370. 

  3370.         EVC = EVC + CEV*DESTV*DTV
    3371. 

  3371.         TR  = TR  + CTR*DESTV*DTV                               
    3372. 

  3372. 

  3373. ! update vegetation surface temperature
    3374. 

  3374.         TV  = TV + DTV
    3375. 

  3375. 

  3376. ! for computing M-O length in the next iteration
    3377. 

  3377.         H  = RHOAIR*CPAIR*(TAH - SFCTMP) /RAHC        
    3378. 

  3378.         HG = RHOAIR*CPAIR*(TG  - TAH)   /RAHG
    3379. 

  3379. 

  3380. ! consistent specific humidity from canopy air vapor pressure
    3381. 

  3381.         QSFC = (0.622*EAH)/(SFCPRS-0.378*EAH)
    3382. 

  3382. 

  3383. ! added moisture flux for sfcdif4
    3384. 

  3384.         IF ( OPT_SFC == 4 ) THEN
    3385. 

  3385.            QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMA
    3386. 

  3386.         ENDIF
    3387. 

  3387. 

  3388.         IF (LITER == 1) THEN
    3389. 

  3389.            exit loop1 
    3390. 

  3390.         ENDIF
    3391. 

  3391.         IF (ITER >= 5 .AND. ABS(DTV) <= 0.01 .AND. LITER == 0) THEN
    3392. 

  3392.            LITER = 1
    3393. 

  3393.         ENDIF
    3394. 

  3394. 

  3395.      END DO loop1 ! end stability iteration
    3396. 

  3396. 

  3397. ! under-canopy fluxes and tg
    3398. 

  3398. 

  3399.         AIR = - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4
    3400. 

  3400.         CIR = EMG*SB
    3401. 

  3401.         CSH = RHOAIR*CPAIR/RAHG
    3402. 

  3402.         CEV = RHOAIR*CPAIR / (GAMMA*(RAWG+RSURF))
    3403. 

  3403.         CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1)
    3404. 

  3404. 

  3405.      loop2: DO ITER = 1, NITERG
    3406. 

  3406. 

  3407.         T = TDC(TG)
    3408. 

  3408.         CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
    3409. 

  3409.         IF (T .GT. 0.) THEN
    3410. 

  3410.             ESTG  = ESATW
    3411. 

  3411.             DESTG = DSATW
    3412. 

  3412.         ELSE
    3413. 

  3413.             ESTG  = ESATI
    3414. 

  3414.             DESTG = DSATI
    3415. 

  3415.         END IF
    3416. 

  3416. 

  3417.         IRG = CIR*TG**4 + AIR
    3418. 

  3418.         SHG = CSH * (TG         - TAH         )
    3419. 

  3419.         EVG = CEV * (ESTG*RHSUR - EAH         )
    3420. 

  3420.         GH  = CGH * (TG         - STC(ISNOW+1))
    3421. 

  3421. 

  3422.         B = SAG-IRG-SHG-EVG-GH
    3423. 

  3423.         A = 4.*CIR*TG**3+CSH+CEV*DESTG+CGH
    3424. 

  3424.         DTG = B/A
    3425. 

  3425. 

  3426.         IRG = IRG + 4.*CIR*TG**3*DTG
    3427. 

  3427.         SHG = SHG + CSH*DTG
    3428. 

  3428.         EVG = EVG + CEV*DESTG*DTG
    3429. 

  3429.         GH  = GH  + CGH*DTG
    3430. 

  3430.         TG  = TG  + DTG
    3431. 

  3431. 

  3432.      END DO loop2
    3433. 

  3433. 

  3434. ! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes.
    3435. 

  3435. 

  3436.      IF(OPT_STC == 1) THEN
    3437. 

  3437.      IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN
    3438. 

  3438.         TG  = TFRZ
    3439. 

  3439.         IRG = CIR*TG**4 - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4
    3440. 

  3440.         SHG = CSH * (TG         - TAH)
    3441. 

  3441.         EVG = CEV * (ESTG*RHSUR - EAH)
    3442. 

  3442.         GH  = SAG - (IRG+SHG+EVG)
    3443. 

  3443.      END IF
    3444. 

  3444.      END IF
    3445. 

  3445. 

  3446. ! wind stresses
    3447. 

  3447. 

  3448.      TAUXV = -RHOAIR*CM*UR*UU
    3449. 

  3449.      TAUYV = -RHOAIR*CM*UR*VV
    3450. 

  3450. 

  3451. ! consistent vegetation air temperature and vapor pressure since TG is not consistent with the TAH/EAH
    3452. 

  3452. ! calculation.
    3453. 

  3453.      TAH = SFCTMP + (SHG+SHC)/(RHOAIR*CPAIR*CAH) 
    3454. 

  3454.      EAH = EAIR + (EVC+TR+EVG)/(RHOAIR*CAW*CPAIR/GAMMA )
    3455. 

  3455.      QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMA
    3456. 

  3456. 

  3457. ! 2m temperature over vegetation ( corrected for low CQ2V values )
    3458. 

  3458.    IF (OPT_SFC == 1 .OR. OPT_SFC == 2) THEN
    3459. 

  3459.       CAH2 = FV*1./VKC*LOG((2.+Z0H)/Z0H)
    3460. 

  3460.       CQ2V = CAH2
    3461. 

  3461.       IF (CAH2 .LT. 1.E-5 ) THEN
    3462. 

  3462.          T2MV = TAH
    3463. 

  3463.          Q2V  = (EAH*0.622/(SFCPRS - 0.378*EAH))
    3464. 

  3464.       ELSE
    3465. 

  3465.          T2MV = TAH - (SHG+SHC)/(RHOAIR*CPAIR*FV) * 1./VKC * LOG((2.+Z0H)/Z0H)
    3466. 

  3466.          Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH))- QFX/(RHOAIR*FV)* 1./VKC * LOG((2.+Z0H)/Z0H)
    3467. 

  3467.       ENDIF
    3468. 

  3468.    ENDIF
    3469. 

  3469. 

  3470. ! myj/ysu consistent 2m temperature over vegetation (if CQ2V .lt. 1e-5? )
    3471. 

  3471.    IF (OPT_SFC == 3 .OR. OPT_SFC == 4 ) THEN
    3472. 

  3472.          IF (CAH2 .LT. 1.E-5 ) THEN
    3473. 

  3473.             T2MV = TAH
    3474. 

  3474.             Q2V  = (EAH*0.622/(SFCPRS - 0.378*EAH))
    3475. 

  3475.          ELSE
    3476. 

  3476.             T2MV = TAH - (SHG+SHC)/(RHOAIR*CPAIR*CAH2)
    3477. 

  3477.             Q2V  = (EAH*0.622/(SFCPRS - 0.378*EAH)) - QFX/(RHOAIR*CQ2V)
    3478. 

  3478.          ENDIF
    3479. 

  3479.    ENDIF  
    3480. 

  3480. 

  3481. ! update CH for output
    3482. 

  3482.      CH = CAH
    3483. 

  3483. 

  3484.   END SUBROUTINE VEGE_FLUX
    3485. 

  3485. ! ==================================================================================================
    3486. 

  3486.   SUBROUTINE BARE_FLUX (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,SAG     , & !in
    3487. 

  3487.                         LWDN    ,UR      ,UU      ,VV      ,SFCTMP  , & !in
    3488. 

  3488.                         THAIR   ,QAIR    ,EAIR    ,RHOAIR  ,SNOWH   , & !in
    3489. 

  3489.                         DZSNSO  ,ZLVL    ,ZPD     ,Z0M     ,          & !in
    3490. 

  3490.                         EMG     ,STC     ,DF      ,RSURF   ,LATHEA  , & !in
    3491. 

  3491.                         GAMMA   ,RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
    3492. 

  3492.                         TGB     ,CM      ,CH      ,          & !inout
    3493. 

  3493.                         TAUXB   ,TAUYB   ,IRB     ,SHB     ,EVB     , & !out
    3494. 

  3494.                         GHB     ,T2MB    ,DX      ,DZ8W    ,IVGTYP  , & !out
    3495. 

  3495.                         QC      ,PBLH    ,QSFC    ,PSFC    ,ISURBAN , & !in
    3496. 

  3496.                         IZ0TLND ,SFCPRS  ,Q2B     ,EHB2)      !in 
    3497. 

  3497. 

  3498. ! --------------------------------------------------------------------------------------------------
    3499. 

  3499. ! use newton-raphson iteration to solve ground (tg) temperature
    3500. 

  3500. ! that balances the surface energy budgets for bare soil fraction.
    3501. 

  3501. 

  3502. ! bare soil:
    3503. 

  3503. ! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0
    3504. 

  3504. ! ----------------------------------------------------------------------
    3505. 

  3505.   USE NOAHMP_VEG_PARAMETERS
    3506. 

  3506.   USE MODULE_MODEL_CONSTANTS
    3507. 

  3507. ! ----------------------------------------------------------------------
    3508. 

  3508.   IMPLICIT NONE
    3509. 

  3509. ! ----------------------------------------------------------------------
    3510. 

  3510. ! input
    3511. 

  3511.   integer                        , INTENT(IN) :: ILOC   !grid index
    3512. 

  3512.   integer                        , INTENT(IN) :: JLOC   !grid index
    3513. 

  3513.   INTEGER,                         INTENT(IN) :: NSNOW  !maximum no. of snow layers
    3514. 

  3514.   INTEGER,                         INTENT(IN) :: NSOIL  !number of soil layers
    3515. 

  3515.   INTEGER,                         INTENT(IN) :: ISNOW  !actual no. of snow layers
    3516. 

  3516.   REAL,                            INTENT(IN) :: DT     !time step (s)
    3517. 

  3517.   REAL,                            INTENT(IN) :: SAG    !solar radiation absorbed by ground (w/m2)
    3518. 

  3518.   REAL,                            INTENT(IN) :: LWDN   !atmospheric longwave radiation (w/m2)
    3519. 

  3519.   REAL,                            INTENT(IN) :: UR     !wind speed at height zlvl (m/s)
    3520. 

  3520.   REAL,                            INTENT(IN) :: UU     !wind speed in eastward dir (m/s)
    3521. 

  3521.   REAL,                            INTENT(IN) :: VV     !wind speed in northward dir (m/s)
    3522. 

  3522.   REAL,                            INTENT(IN) :: SFCTMP !air temperature at reference height (k)
    3523. 

  3523.   REAL,                            INTENT(IN) :: THAIR  !potential temperature at height zlvl (k)
    3524. 

  3524.   REAL,                            INTENT(IN) :: QAIR   !specific humidity at height zlvl (kg/kg)
    3525. 

  3525.   REAL,                            INTENT(IN) :: EAIR   !vapor pressure air at height (pa)
    3526. 

  3526.   REAL,                            INTENT(IN) :: RHOAIR !density air (kg/m3)
    3527. 

  3527.   REAL,                            INTENT(IN) :: SNOWH  !actual snow depth [m]
    3528. 

  3528.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers (m)
    3529. 

  3529.   REAL,                            INTENT(IN) :: ZLVL   !reference height (m)
    3530. 

  3530.   REAL,                            INTENT(IN) :: ZPD    !zero plane displacement (m)
    3531. 

  3531.   REAL,                            INTENT(IN) :: Z0M    !roughness length, momentum, ground (m)
    3532. 

  3532.   REAL,                            INTENT(IN) :: EMG    !ground emissivity
    3533. 

  3533.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC    !soil/snow temperature (k)
    3534. 

  3534.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF     !thermal conductivity of snow/soil (w/m/k)
    3535. 

  3535.   REAL,                            INTENT(IN) :: RSURF  !ground surface resistance (s/m)
    3536. 

  3536.   REAL,                            INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg)
    3537. 

  3537.   REAL,                            INTENT(IN) :: GAMMA  !psychrometric constant (pa/k)
    3538. 

  3538.   REAL,                            INTENT(IN) :: RHSUR  !raltive humidity in surface soil/snow air space (-)
    3539. 

  3539. 

  3540. !jref:start; in 
    3541. 

  3541.   INTEGER                        , INTENT(IN) :: ISURBAN
    3542. 

  3542.   INTEGER                        , INTENT(IN) :: IVGTYP
    3543. 

  3543.   INTEGER                        , INTENT(IN) :: IZ0TLND
    3544. 

  3544.   REAL                           , INTENT(IN) :: QC     !cloud water mixing ratio
    3545. 

  3545.   REAL                           , INTENT(IN) :: PBLH   !planetary boundary layer height
    3546. 

  3546.   REAL                           , INTENT(INOUT) :: QSFC   !mixing ratio at lowest model layer
    3547. 

  3547.   REAL                           , INTENT(IN) :: PSFC   !pressure at lowest model layer
    3548. 

  3548.   REAL                           , INTENT(IN) :: SFCPRS !pressure at lowest model layer
    3549. 

  3549.   REAL                           , INTENT(IN) :: DX     !horisontal grid spacing
    3550. 

  3550.   REAL                           , INTENT(IN) :: Q2     !mixing ratio (kg/kg)
    3551. 

  3551.   REAL                           , INTENT(IN) :: DZ8W   !thickness of lowest layer
    3552. 

  3552. !jref:end
    3553. 

  3553. 

  3554. ! input/output
    3555. 

  3555.   REAL,                         INTENT(INOUT) :: TGB    !ground temperature (k)
    3556. 

  3556.   REAL,                         INTENT(INOUT) :: CM     !momentum drag coefficient
    3557. 

  3557.   REAL,                         INTENT(INOUT) :: CH     !sensible heat exchange coefficient
    3558. 

  3558. 

  3559. ! output
    3560. 

  3560. ! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0
    3561. 

  3561. 

  3562.   REAL,                           INTENT(OUT) :: TAUXB  !wind stress: e-w (n/m2)
    3563. 

  3563.   REAL,                           INTENT(OUT) :: TAUYB  !wind stress: n-s (n/m2)
    3564. 

  3564.   REAL,                           INTENT(OUT) :: IRB    !net longwave rad (w/m2)   [+ to atm]
    3565. 

  3565.   REAL,                           INTENT(OUT) :: SHB    !sensible heat flux (w/m2) [+ to atm]
    3566. 

  3566.   REAL,                           INTENT(OUT) :: EVB    !latent heat flux (w/m2)   [+ to atm]
    3567. 

  3567.   REAL,                           INTENT(OUT) :: GHB    !ground heat flux (w/m2)  [+ to soil]
    3568. 

  3568.   REAL,                           INTENT(OUT) :: T2MB   !2 m height air temperature (k)
    3569. 

  3569. !jref:start
    3570. 

  3570.   REAL,                           INTENT(OUT) :: Q2B    !bare ground heat conductance
    3571. 

  3571.   REAL :: EHB    !bare ground heat conductance
    3572. 

  3572.   REAL :: U10B    !10 m wind speed in eastward dir (m/s)
    3573. 

  3573.   REAL :: V10B    !10 m wind speed in eastward dir (m/s)
    3574. 

  3574.   REAL :: WSPD
    3575. 

  3575. !jref:end
    3576. 

  3576. 

  3577. ! local variables 
    3578. 

  3578. 

  3579.   REAL :: TAUX       !wind stress: e-w (n/m2)
    3580. 

  3580.   REAL :: TAUY       !wind stress: n-s (n/m2)
    3581. 

  3581.   REAL :: FIRA       !total net longwave rad (w/m2)      [+ to atm]
    3582. 

  3582.   REAL :: FSH        !total sensible heat flux (w/m2)    [+ to atm]
    3583. 

  3583.   REAL :: FGEV       !ground evaporation heat flux (w/m2)[+ to atm]
    3584. 

  3584.   REAL :: SSOIL      !soil heat flux (w/m2)             [+ to soil]
    3585. 

  3585.   REAL :: FIRE       !emitted ir (w/m2)
    3586. 

  3586.   REAL :: TRAD       !radiative temperature (k)
    3587. 

  3587.   REAL :: TAH        !"surface" temperature at height z0h+zpd (k)
    3588. 

  3588. 

  3589.   REAL :: CW         !water vapor exchange coefficient
    3590. 

  3590.   REAL :: FV         !friction velocity (m/s)
    3591. 

  3591.   REAL :: WSTAR      !friction velocity n vertical direction (m/s) (only for SFCDIF2)
    3592. 

  3592.   REAL :: Z0H        !roughness length, sensible heat, ground (m)
    3593. 

  3593.   REAL :: RB         !bulk leaf boundary layer resistance (s/m)
    3594. 

  3594.   REAL :: RAMB       !aerodynamic resistance for momentum (s/m)
    3595. 

  3595.   REAL :: RAHB       !aerodynamic resistance for sensible heat (s/m)
    3596. 

  3596.   REAL :: RAWB       !aerodynamic resistance for water vapor (s/m)
    3597. 

  3597.   REAL :: MOL        !Monin-Obukhov length (m)
    3598. 

  3598.   REAL :: DTG        !change in tg, last iteration (k)
    3599. 

  3599. 

  3600.   REAL :: CIR        !coefficients for ir as function of ts**4
    3601. 

  3601.   REAL :: CSH        !coefficients for sh as function of ts
    3602. 

  3602.   REAL :: CEV        !coefficients for ev as function of esat[ts]
    3603. 

  3603.   REAL :: CGH        !coefficients for st as function of ts
    3604. 

  3604. 

  3605. !jref:start
    3606. 

  3606.   REAL :: RAHB2      !aerodynamic resistance for sensible heat 2m (s/m)
    3607. 

  3607.   REAL :: RAWB2      !aerodynamic resistance for water vapor 2m (s/m)
    3608. 

  3608.   REAL,INTENT(OUT) :: EHB2       !sensible heat conductance for diagnostics
    3609. 

  3609.   REAL :: CH2B       !exchange coefficient for 2m temp.
    3610. 

  3610.   REAL :: CQ2B       !exchange coefficient for 2m temp.
    3611. 

  3611.   REAL :: THVAIR     !virtual potential air temp
    3612. 

  3612.   REAL :: THGH       !potential ground temp
    3613. 

  3613.   REAL :: EMB        !momentum conductance
    3614. 

  3614.   REAL :: QFX        !moisture flux
    3615. 

  3615.   REAL :: ESTG2      !saturation vapor pressure at 2m (pa)
    3616. 

  3616.   INTEGER :: VEGTYP     !vegetation type set to isbarren
    3617. 

  3617.   REAL :: E1
    3618. 

  3618. !jref:end
    3619. 

  3619. 

  3620.   REAL :: ESTG       !saturation vapor pressure at tg (pa)
    3621. 

  3621.   REAL :: DESTG      !d(es)/dt at tg (pa/K)
    3622. 

  3622.   REAL :: ESATW      !es for water
    3623. 

  3623.   REAL :: ESATI      !es for ice
    3624. 

  3624.   REAL :: DSATW      !d(es)/dt at tg (pa/K) for water
    3625. 

  3625.   REAL :: DSATI      !d(es)/dt at tg (pa/K) for ice
    3626. 

  3626. 

  3627.   REAL :: A          !temporary calculation
    3628. 

  3628.   REAL :: B          !temporary calculation
    3629. 

  3629.   REAL :: H          !temporary sensible heat flux (w/m2)
    3630. 

  3630.   REAL :: MOZ        !Monin-Obukhov stability parameter
    3631. 

  3631.   REAL :: MOZOLD     !Monin-Obukhov stability parameter from prior iteration
    3632. 

  3632.   REAL :: FM         !momentum stability correction, weighted by prior iters
    3633. 

  3633.   REAL :: FH         !sen heat stability correction, weighted by prior iters
    3634. 

  3634.   INTEGER :: MOZSGN  !number of times MOZ changes sign
    3635. 

  3635. 

  3636.   INTEGER :: ITER    !iteration index
    3637. 

  3637.   INTEGER :: NITERB  !number of iterations for surface temperature
    3638. 

  3638.   REAL    :: MPE     !prevents overflow error if division by zero
    3639. 

  3639. !jref:start
    3640. 

  3640. !  DATA NITERB /3/
    3641. 

  3641.   DATA NITERB /5/
    3642. 

  3642.   SAVE NITERB
    3643. 

  3643.   REAL :: T, TDC     !Kelvin to degree Celsius with limit -50 to +50
    3644. 

  3644.   TDC(T)   = MIN( 50., MAX(-50.,(T-TFRZ)) )
    3645. 

  3645. 

  3646. ! -----------------------------------------------------------------
    3647. 

  3647. ! initialization variables that do not depend on stability iteration
    3648. 

  3648. ! -----------------------------------------------------------------
    3649. 

  3649.         MPE = 1E-6
    3650. 

  3650.         DTG = 0.
    3651. 

  3651.         MOZSGN = 0
    3652. 

  3652.         MOZOLD = 0.
    3653. 

  3653.         H      = 0.
    3654. 

  3654.         QFX    = 0.
    3655. 

  3655.         FV     = 0.1
    3656. 

  3656. 

  3657.         CIR = EMG*SB
    3658. 

  3658.         CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1)
    3659. 

  3659. 

  3660. ! -----------------------------------------------------------------
    3661. 

  3661.       loop3: DO ITER = 1, NITERB  ! begin stability iteration
    3662. 

  3662. 

  3663.         IF(ITER == 1) THEN
    3664. 

  3664.             Z0H = Z0M 
    3665. 

  3665.         ELSE
    3666. 

  3666.             Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M))
    3667. 

  3667.         END IF
    3668. 

  3668. 

  3669.         IF(OPT_SFC == 1) THEN
    3670. 

  3670.           CALL SFCDIF1(ITER   ,SFCTMP ,RHOAIR ,H      ,QAIR   , & !in
    3671. 

  3671.                        ZLVL   ,ZPD    ,Z0M    ,Z0H    ,UR     , & !in
    3672. 

  3672.                        MPE    ,ILOC   ,JLOC   ,                 & !in
    3673. 

  3673.                        MOZ    ,MOZSGN ,FM     ,FH     ,         & !inout
    3674. 

  3674.                        CM     ,CH     ,FV     )                   !out
    3675. 

  3675.         ENDIF
    3676. 

  3676. 

  3677.         IF(OPT_SFC == 2) THEN
    3678. 

  3678.           CALL SFCDIF2(ITER   ,Z0M    ,TGB    ,THAIR  ,UR     , & !in
    3679. 

  3679.                        CZIL   ,ZLVL   ,ILOC   ,JLOC   ,         & !in
    3680. 

  3680.                        CM     ,CH     ,MOZ    ,WSTAR  ,         & !in
    3681. 

  3681.                        FV     )                                   !out
    3682. 

  3682.           ! Undo the multiplication by windspeed that SFCDIF2 
    3683. 

  3683.           ! applies to exchange coefficients CH and CM:
    3684. 

  3684.           CH = CH / UR
    3685. 

  3685.           CM = CM / UR
    3686. 

  3686.           IF(SNOWH > 0.) THEN
    3687. 

  3687.              CM = MIN(0.01,CM)   ! CM & CH are too large, causing
    3688. 

  3688.              CH = MIN(0.01,CH)   ! computational instability
    3689. 

  3689.           END IF
    3690. 

  3690. 

  3691.         ENDIF
    3692. 

  3692. 

  3693.         IF(OPT_SFC == 3) THEN
    3694. 

  3694.           VEGTYP = ISBARREN
    3695. 

  3695.           CALL SFCDIF3(ILOC   ,JLOC   ,TGB    ,QSFC   ,PSFC   ,&  !in    
    3696. 

  3696.                        PBLH   ,Z0M    ,Z0M    ,VEGTYP ,ISURBAN,&  !in    
    3697. 

  3697.                        IZ0TLND,UR     ,ITER   ,NITERB ,SFCTMP ,&  !in    
    3698. 

  3698.                        THAIR  ,QAIR   ,QC     ,ZLVL   ,        &  !in            
    3699. 

  3699.                        SFCPRS ,FV     ,CM     ,CH     ,CH2B   ,&  !inout 
    3700. 

  3700.                        CQ2B   ,MOZ)                               !out   
    3701. 

  3701.           ! Undo the multiplication by windspeed that SFCDIF3 
    3702. 

  3702.           ! applies to exchange coefficients CH and CM:
    3703. 

  3703.           CH   = CH / UR
    3704. 

  3704.           CM   = CM / UR
    3705. 

  3705.           CH2B = CH2B / UR
    3706. 

  3706. 

  3707.           IF(SNOWH > 0.) THEN    ! jref: does this still count??
    3708. 

  3708.              CM = MIN(0.01,CM)   ! CM & CH are too large, causing
    3709. 

  3709.              CH = MIN(0.01,CH)   ! computational instability
    3710. 

  3710.              CH2B = MIN(0.01,CH2B)
    3711. 

  3711.              CQ2B = MIN(0.01,CQ2B)
    3712. 

  3712.           END IF
    3713. 

  3713.         ENDIF
    3714. 

  3714. 

  3715.        IF(OPT_SFC == 4) THEN
    3716. 

  3716.           CALL SFCDIF4(ILOC   ,JLOC   ,UU     ,VV     ,SFCTMP ,&  !in
    3717. 

  3717.                        SFCPRS ,PSFC   ,PBLH   ,DX     ,Z0M    ,&
    3718. 

  3718.                        TGB    ,QAIR   ,ZLVL   ,IZ0TLND,QSFC   ,&
    3719. 

  3719.                        H      ,QFX    ,CM     ,CH     ,CH2B   ,& 
    3720. 

  3720.                        CQ2B   ,MOZ    ,FV     ,U10B   ,V10B)
    3721. 

  3721.           ! Undo the multiplication by windspeed that SFCDIF4 
    3722. 

  3722.           ! applies to exchange coefficients CH and CM:
    3723. 

  3723.           CH   = CH / UR
    3724. 

  3724.           CM   = CM / UR
    3725. 

  3725.           CH2B = CH2B / UR
    3726. 

  3726. 

  3727.           IF(SNOWH > 0.) THEN    ! jref: does this still count??
    3728. 

  3728.              CM = MIN(0.01,CM)   ! CM & CH are too large, causing
    3729. 

  3729.              CH = MIN(0.01,CH)   ! computational instability
    3730. 

  3730.              CH2B = MIN(0.01,CH2B)
    3731. 

  3731.              CQ2B = MIN(0.01,CQ2B)
    3732. 

  3732.           END IF
    3733. 

  3733. 

  3734.        ENDIF
    3735. 

  3735. 

  3736.         RAMB = MAX(1.,1./(CM*UR))
    3737. 

  3737.         RAHB = MAX(1.,1./(CH*UR))
    3738. 

  3738.         RAWB = RAHB
    3739. 

  3739. 

  3740. !jref - variables for diagnostics         
    3741. 

  3741.         EMB = 1./RAMB
    3742. 

  3742.         EHB = 1./RAHB
    3743. 

  3743.         IF (OPT_SFC == 3 .OR. OPT_SFC == 4) THEN
    3744. 

  3744.           RAHB2 = MAX(1.,1./(CH2B*UR))
    3745. 

  3745.           EHB2 = 1./RAHB2
    3746. 

  3746.           CQ2B = EHB2
    3747. 

  3747.         END IF
    3748. 

  3748. 

  3749. ! es and d(es)/dt evaluated at tg
    3750. 

  3750. 

  3751.         T = TDC(TGB)
    3752. 

  3752.         CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
    3753. 

  3753.         IF (T .GT. 0.) THEN
    3754. 

  3754.             ESTG  = ESATW
    3755. 

  3755.             DESTG = DSATW
    3756. 

  3756.         ELSE
    3757. 

  3757.             ESTG  = ESATI
    3758. 

  3758.             DESTG = DSATI
    3759. 

  3759.         END IF
    3760. 

  3760. 

  3761.         CSH = RHOAIR*CPAIR/RAHB
    3762. 

  3762.         CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB)
    3763. 

  3763. 

  3764. ! surface fluxes and dtg
    3765. 

  3765. 

  3766.         IRB   = CIR * TGB**4 - EMG*LWDN
    3767. 

  3767.         SHB   = CSH * (TGB        - SFCTMP      )
    3768. 

  3768.         EVB   = CEV * (ESTG*RHSUR - EAIR        )
    3769. 

  3769.         GHB   = CGH * (TGB        - STC(ISNOW+1))
    3770. 

  3770. 

  3771.         B     = SAG-IRB-SHB-EVB-GHB
    3772. 

  3772.         A     = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH
    3773. 

  3773.         DTG   = B/A
    3774. 

  3774. 

  3775.         IRB = IRB + 4.*CIR*TGB**3*DTG
    3776. 

  3776.         SHB = SHB + CSH*DTG
    3777. 

  3777.         EVB = EVB + CEV*DESTG*DTG
    3778. 

  3778.         GHB = GHB + CGH*DTG
    3779. 

  3779. 

  3780. ! update ground surface temperature
    3781. 

  3781.         TGB = TGB + DTG
    3782. 

  3782. 

  3783. ! for M-O length
    3784. 

  3784.         H = CSH * (TGB - SFCTMP)
    3785. 

  3785. 

  3786.         T = TDC(TGB)
    3787. 

  3787.         CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
    3788. 

  3788.         IF (T .GT. 0.) THEN
    3789. 

  3789.             ESTG  = ESATW
    3790. 

  3790.         ELSE
    3791. 

  3791.             ESTG  = ESATI
    3792. 

  3792.         END IF
    3793. 

  3793.         QSFC = 0.622*(ESTG*RHSUR)/(PSFC-0.378*(ESTG*RHSUR))
    3794. 

  3794. 

  3795.         QFX = (QSFC-QAIR)*CEV*GAMMA/CPAIR
    3796. 

  3796. 

  3797.      END DO loop3 ! end stability iteration
    3798. 

  3798. ! -----------------------------------------------------------------
    3799. 

  3799. 

  3800. ! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes.
    3801. 

  3801. 

  3802.      IF(OPT_STC == 1) THEN
    3803. 

  3803.      IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN
    3804. 

  3804.           TGB = TFRZ
    3805. 

  3805.           IRB = CIR * TGB**4 - EMG*LWDN
    3806. 

  3806.           SHB = CSH * (TGB        - SFCTMP)
    3807. 

  3807.           EVB = CEV * (ESTG*RHSUR - EAIR )          !ESTG reevaluate ?
    3808. 

  3808.           GHB = SAG - (IRB+SHB+EVB)
    3809. 

  3809.      END IF
    3810. 

  3810.      END IF
    3811. 

  3811. 

  3812. ! wind stresses
    3813. 

  3813.          
    3814. 

  3814.      TAUXB = -RHOAIR*CM*UR*UU
    3815. 

  3815.      TAUYB = -RHOAIR*CM*UR*VV
    3816. 

  3816. 

  3817. !jref:start; errors in original equation corrected.
    3818. 

  3818. ! 2m air temperature
    3819. 

  3819.      IF(OPT_SFC == 1 .OR. OPT_SFC ==2) THEN
    3820. 

  3820.        EHB2  = FV*VKC/LOG((2.+Z0H)/Z0H)
    3821. 

  3821.        CQ2B  = EHB2
    3822. 

  3822.        IF (EHB2.lt.1.E-5 ) THEN
    3823. 

  3823.          T2MB  = TGB
    3824. 

  3824.          Q2B   = QSFC
    3825. 

  3825.        ELSE
    3826. 

  3826.          T2MB  = TGB - SHB/(RHOAIR*CPAIR*FV) * 1./VKC * LOG((2.+Z0H)/Z0H)
    3827. 

  3827.          Q2B   = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF)
    3828. 

  3828.        ENDIF
    3829. 

  3829.        IF (IVGTYP == ISURBAN) Q2B = QSFC
    3830. 

  3830.      END IF
    3831. 

  3831. 

  3832. ! myj consistent 2m temperature over bare soil
    3833. 

  3833.      IF(OPT_SFC ==3 .OR. OPT_SFC == 4) THEN
    3834. 

  3834.        IF (EHB2.lt.1.E-5 ) THEN
    3835. 

  3835.           T2MB = TGB
    3836. 

  3836.           Q2B  = QSFC
    3837. 

  3837.        ELSE
    3838. 

  3838.           T2MB = TGB - SHB/(RHOAIR*CPAIR*EHB2)
    3839. 

  3839.           Q2B  = QSFC - QFX/(RHOAIR*CQ2B)
    3840. 

  3840.        END IF
    3841. 

  3841. !       IF (IVGTYP == ISURBAN) THEN
    3842. 

  3842. !          Q2B = QSFC
    3843. 

  3843. !       END IF
    3844. 

  3844.      END IF
    3845. 

  3845. 

  3846. ! update CH 
    3847. 

  3847.      CH = EHB
    3848. 

  3848. 

  3849.   END SUBROUTINE BARE_FLUX
    3850. 

  3850. ! ==================================================================================================
    3851. 

  3851.   SUBROUTINE RAGRB(ITER   ,VAI    ,RHOAIR ,HG     ,TAH    , & !in
    3852. 

  3852.                    ZPD    ,Z0MG   ,Z0HG   ,HCAN   ,UC     , & !in
    3853. 

  3853.                    Z0H    ,FV     ,CWP    ,VEGTYP ,MPE    , & !in
    3854. 

  3854.                    TV     ,MOZG   ,FHG    ,ILOC   ,JLOC   , & !inout
    3855. 

  3855.                    RAMG   ,RAHG   ,RAWG   ,RB     )           !out
    3856. 

  3856. ! --------------------------------------------------------------------------------------------------
    3857. 

  3857. ! compute under-canopy aerodynamic resistance RAG and leaf boundary layer
    3858. 

  3858. ! resistance RB
    3859. 

  3859. ! --------------------------------------------------------------------------------------------------
    3860. 

  3860.   USE NOAHMP_VEG_PARAMETERS
    3861. 

  3861. ! --------------------------------------------------------------------------------------------------
    3862. 

  3862.   IMPLICIT NONE
    3863. 

  3863. ! --------------------------------------------------------------------------------------------------
    3864. 

  3864. ! inputs
    3865. 

  3865. 

  3866.   INTEGER,              INTENT(IN) :: ILOC   !grid index
    3867. 

  3867.   INTEGER,              INTENT(IN) :: JLOC   !grid index
    3868. 

  3868.   INTEGER,              INTENT(IN) :: ITER   !iteration index
    3869. 

  3869.   INTEGER,              INTENT(IN) :: VEGTYP !vegetation physiology type
    3870. 

  3870.   REAL,                 INTENT(IN) :: VAI    !total LAI + stem area index, one sided
    3871. 

  3871.   REAL,                 INTENT(IN) :: RHOAIR !density air (kg/m3)
    3872. 

  3872.   REAL,                 INTENT(IN) :: HG     !ground sensible heat flux (w/m2)
    3873. 

  3873.   REAL,                 INTENT(IN) :: TV     !vegetation temperature (k)
    3874. 

  3874.   REAL,                 INTENT(IN) :: TAH    !air temperature at height z0h+zpd (k)
    3875. 

  3875.   REAL,                 INTENT(IN) :: ZPD    !zero plane displacement (m)
    3876. 

  3876.   REAL,                 INTENT(IN) :: Z0MG   !roughness length, momentum, ground (m)
    3877. 

  3877.   REAL,                 INTENT(IN) :: HCAN   !canopy height (m) [note: hcan >= z0mg]
    3878. 

  3878.   REAL,                 INTENT(IN) :: UC     !wind speed at top of canopy (m/s)
    3879. 

  3879.   REAL,                 INTENT(IN) :: Z0H    !roughness length, sensible heat (m)
    3880. 

  3880.   REAL,                 INTENT(IN) :: Z0HG   !roughness length, sensible heat, ground (m)
    3881. 

  3881.   REAL,                 INTENT(IN) :: FV     !friction velocity (m/s)
    3882. 

  3882.   REAL,                 INTENT(IN) :: CWP    !canopy wind parameter
    3883. 

  3883.   REAL,                 INTENT(IN) :: MPE    !prevents overflow error if division by zero
    3884. 

  3884. 

  3885. ! in & out
    3886. 

  3886. 

  3887.   REAL,              INTENT(INOUT) :: MOZG   !Monin-Obukhov stability parameter
    3888. 

  3888.   REAL,              INTENT(INOUT) :: FHG    !stability correction
    3889. 

  3889. 

  3890. ! outputs
    3891. 

  3891.   REAL                             :: RAMG   !aerodynamic resistance for momentum (s/m)
    3892. 

  3892.   REAL                             :: RAHG   !aerodynamic resistance for sensible heat (s/m)
    3893. 

  3893.   REAL                             :: RAWG   !aerodynamic resistance for water vapor (s/m)
    3894. 

  3894.   REAL                             :: RB     !bulk leaf boundary layer resistance (s/m)
    3895. 

  3895. 

  3896. 

  3897.   REAL :: KH           !turbulent transfer coefficient, sensible heat, (m2/s)
    3898. 

  3898.   REAL :: TMP1         !temporary calculation
    3899. 

  3899.   REAL :: TMP2         !temporary calculation
    3900. 

  3900.   REAL :: TMPRAH2      !temporary calculation for aerodynamic resistances
    3901. 

  3901.   REAL :: TMPRB        !temporary calculation for rb
    3902. 

  3902.   real :: MOLG,FHGNEW,CWPC
    3903. 

  3903. ! --------------------------------------------------------------------------------------------------
    3904. 

  3904. ! stability correction to below canopy resistance
    3905. 

  3905. 

  3906.        MOZG = 0.
    3907. 

  3907.        MOLG = 0.
    3908. 

  3908. 

  3909.        IF(ITER > 1) THEN
    3910. 

  3910.         TMP1 = VKC * (GRAV/TAH) * HG/(RHOAIR*CPAIR)
    3911. 

  3911.         IF (ABS(TMP1) .LE. MPE) TMP1 = MPE
    3912. 

  3912.         MOLG = -1. * FV**3 / TMP1
    3913. 

  3913.         MOZG = MIN( (ZPD-Z0MG)/MOLG, 1.)
    3914. 

  3914.        END IF
    3915. 

  3915. 

  3916.        IF (MOZG < 0.) THEN
    3917. 

  3917.           FHGNEW  = (1. - 15.*MOZG)**(-0.25)
    3918. 

  3918.        ELSE
    3919. 

  3919.           FHGNEW  = 1.+ 4.7*MOZG
    3920. 

  3920.        ENDIF
    3921. 

  3921. 

  3922.        IF (ITER == 1) THEN
    3923. 

  3923.           FHG = FHGNEW
    3924. 

  3924.        ELSE
    3925. 

  3925.           FHG = 0.5 * (FHG+FHGNEW)
    3926. 

  3926.        ENDIF
    3927. 

  3927. 

  3928.        CWPC = (CWP * VAI * HCAN * FHG)**0.5
    3929. 

  3929. !       CWPC = (CWP*FHG)**0.5
    3930. 

  3930. 

  3931.        TMP1 = EXP( -CWPC*Z0HG/HCAN )
    3932. 

  3932.        TMP2 = EXP( -CWPC*(Z0H+ZPD)/HCAN )
    3933. 

  3933.        TMPRAH2 = HCAN*EXP(CWPC) / CWPC * (TMP1-TMP2)
    3934. 

  3934. 

  3935. ! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg.
    3936. 

  3936. 

  3937.        KH  = MAX ( VKC*FV*(HCAN-ZPD), MPE )
    3938. 

  3938.        RAMG = 0.
    3939. 

  3939.        RAHG = TMPRAH2 / KH
    3940. 

  3940.        RAWG = RAHG
    3941. 

  3941. 

  3942. ! leaf boundary layer resistance
    3943. 

  3943. 

  3944.        TMPRB  = CWPC*50. / (1. - EXP(-CWPC/2.))
    3945. 

  3945.        RB     = TMPRB * SQRT(DLEAF(VEGTYP)/UC)
    3946. 

  3946. 

  3947.   END SUBROUTINE RAGRB
    3948. 

  3948. 

  3949. ! ==================================================================================================
    3950. 

  3950. 

  3951.   SUBROUTINE SFCDIF1(ITER   ,SFCTMP ,RHOAIR ,H      ,QAIR   , & !in
    3952. 

  3952.        &             ZLVL   ,ZPD    ,Z0M    ,Z0H    ,UR     , & !in
    3953. 

  3953.        &             MPE    ,ILOC   ,JLOC   ,                 & !in
    3954. 

  3954.        &             MOZ    ,MOZSGN ,FM     ,FH     ,         & !inout
    3955. 

  3955.        &             CM     ,CH     ,FV     )                   !out
    3956. 

  3956. ! -------------------------------------------------------------------------------------------------
    3957. 

  3957. ! computing surface drag coefficient CM for momentum and CH for heat
    3958. 

  3958. ! -------------------------------------------------------------------------------------------------
    3959. 

  3959.     IMPLICIT NONE
    3960. 

  3960. ! -------------------------------------------------------------------------------------------------
    3961. 

  3961. ! inputs
    3962. 

  3962.     
    3963. 

  3963.     INTEGER,              INTENT(IN) :: ILOC   !grid index
    3964. 

  3964.     INTEGER,              INTENT(IN) :: JLOC   !grid index
    3965. 

  3965.     INTEGER,              INTENT(IN) :: ITER   !iteration index
    3966. 

  3966.     REAL,                 INTENT(IN) :: SFCTMP !temperature at reference height (k)
    3967. 

  3967.     REAL,                 INTENT(IN) :: RHOAIR !density air (kg/m**3)
    3968. 

  3968.     REAL,                 INTENT(IN) :: H      !sensible heat flux (w/m2) [+ to atm]
    3969. 

  3969.     REAL,                 INTENT(IN) :: QAIR   !specific humidity at reference height (kg/kg)
    3970. 

  3970.     REAL,                 INTENT(IN) :: ZLVL   !reference height  (m)
    3971. 

  3971.     REAL,                 INTENT(IN) :: ZPD    !zero plane displacement (m)
    3972. 

  3972.     REAL,                 INTENT(IN) :: Z0H    !roughness length, sensible heat, ground (m)
    3973. 

  3973.     REAL,                 INTENT(IN) :: Z0M    !roughness length, momentum, ground (m)
    3974. 

  3974.     REAL,                 INTENT(IN) :: UR     !wind speed (m/s)
    3975. 

  3975.     REAL,                 INTENT(IN) :: MPE    !prevents overflow error if division by zero
    3976. 

  3976. ! in & out
    3977. 

  3977. 

  3978.     INTEGER,           INTENT(INOUT) :: MOZSGN !number of times moz changes sign
    3979. 

  3979.     REAL,              INTENT(INOUT) :: MOZ    !Monin-Obukhov stability (z/L)
    3980. 

  3980.     REAL,              INTENT(INOUT) :: FM     !momentum stability correction, weighted by prior iters
    3981. 

  3981.     REAL,              INTENT(INOUT) :: FH     !sen heat stability correction, weighted by prior iters
    3982. 

  3982. 

  3983. ! outputs
    3984. 

  3984. 

  3985.     REAL,                INTENT(OUT) :: CM     !drag coefficient for momentum
    3986. 

  3986.     REAL,                INTENT(OUT) :: CH     !drag coefficient for heat
    3987. 

  3987.     REAL,                INTENT(OUT) :: FV     !friction velocity (m/s)
    3988. 

  3988. 

  3989. ! locals
    3990. 

  3990.     REAL    :: MOL                      !Monin-Obukhov length (m)
    3991. 

  3991.     REAL    :: TMPCM                    !temporary calculation for CM
    3992. 

  3992.     REAL    :: TMPCH                    !temporary calculation for CH
    3993. 

  3993.     REAL    :: FMNEW                    !stability correction factor, momentum, for current moz
    3994. 

  3994.     REAL    :: FHNEW                    !stability correction factor, sen heat, for current moz
    3995. 

  3995.     REAL    :: MOZOLD                   !Monin-Obukhov stability parameter from prior iteration
    3996. 

  3996.     REAL    :: TMP1,TMP2,TMP3,TMP4,TMP5 !temporary calculation
    3997. 

  3997.     REAL    :: TVIR                     !temporary virtual temperature (k)
    3998. 

  3998. 

  3999.     REAL    :: CMFM, CHFH
    4000. 

  4000. ! -------------------------------------------------------------------------------------------------
    4001. 

  4001. ! Monin-Obukhov stability parameter moz for next iteration
    4002. 

  4002. 

  4003.     MOZOLD = MOZ
    4004. 

  4004.   
    4005. 

  4005.     IF(ZLVL <= ZPD) THEN
    4006. 

  4006.        write(*,*) 'critical problem: ZLVL <= ZPD; model stops'
    4007. 

  4007.        call wrf_error_fatal("STOP in Noah-MP")
    4008. 

  4008.     ENDIF
    4009. 

  4009. 

  4010.     TMPCM = LOG((ZLVL-ZPD) / Z0M)
    4011. 

  4011.     TMPCH = LOG((ZLVL-ZPD) / Z0H)
    4012. 

  4012. 

  4013.     IF(ITER == 1) THEN
    4014. 

  4014.        FV   = 0.0
    4015. 

  4015.        MOZ  = 0.0
    4016. 

  4016.        MOL  = 0.0
    4017. 

  4017.     ELSE
    4018. 

  4018.        TVIR = (1. + 0.61*QAIR) * SFCTMP
    4019. 

  4019.        TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR)
    4020. 

  4020.        IF (ABS(TMP1) .LE. MPE) TMP1 = MPE
    4021. 

  4021.        MOL  = -1. * FV**3 / TMP1
    4022. 

  4022.        MOZ  = MIN( (ZLVL-ZPD)/MOL, 1.)
    4023. 

  4023.     ENDIF
    4024. 

  4024. 

  4025. ! accumulate number of times moz changes sign.
    4026. 

  4026. 

  4027.     IF (MOZOLD*MOZ .LT. 0.) MOZSGN = MOZSGN+1
    4028. 

  4028.     IF (MOZSGN .GE. 2) THEN
    4029. 

  4029.        MOZ = 0.
    4030. 

  4030.        FM = 0.
    4031. 

  4031.        FH = 0.
    4032. 

  4032.     ENDIF
    4033. 

  4033. 

  4034. ! evaluate stability-dependent variables using moz from prior iteration
    4035. 

  4035.     IF (MOZ .LT. 0.) THEN
    4036. 

  4036.        TMP1 = (1. - 16.*MOZ)**0.25
    4037. 

  4037.        TMP2 = LOG((1.+TMP1*TMP1)/2.)
    4038. 

  4038.        TMP3 = LOG((1.+TMP1)/2.)
    4039. 

  4039.        FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963
    4040. 

  4040.        FHNEW = 2*TMP2
    4041. 

  4041.     ELSE
    4042. 

  4042.        FMNEW = -5.*MOZ
    4043. 

  4043.        FHNEW = FMNEW
    4044. 

  4044.     ENDIF
    4045. 

  4045. 

  4046. ! except for first iteration, weight stability factors for previous
    4047. 

  4047. ! iteration to help avoid flip-flops from one iteration to the next
    4048. 

  4048. 

  4049.     IF (ITER == 1) THEN
    4050. 

  4050.        FM = FMNEW
    4051. 

  4051.        FH = FHNEW
    4052. 

  4052.     ELSE
    4053. 

  4053.        FM = 0.5 * (FM+FMNEW)
    4054. 

  4054.        FH = 0.5 * (FH+FHNEW)
    4055. 

  4055.     ENDIF
    4056. 

  4056. 

  4057. ! exchange coefficients
    4058. 

  4058. 

  4059.     CMFM = TMPCM-FM
    4060. 

  4060.     CHFH = TMPCH-FH
    4061. 

  4061.     IF(ABS(CMFM) <= MPE) CMFM = MPE
    4062. 

  4062.     IF(ABS(CHFH) <= MPE) CHFH = MPE
    4063. 

  4063.     CM  = VKC*VKC/(CMFM*CMFM)
    4064. 

  4064.     CH  = VKC*VKC/(CMFM*CHFH)
    4065. 

  4065.         
    4066. 

  4066. ! friction velocity
    4067. 

  4067. 

  4068.     FV = UR * SQRT(CM)
    4069. 

  4069. 

  4070.   END SUBROUTINE SFCDIF1
    4071. 

  4071. 

  4072. ! ==================================================================================================
    4073. 

  4073. 

  4074.   SUBROUTINE SFCDIF2(ITER   ,Z0     ,THZ0   ,THLM   ,SFCSPD , & !in
    4075. 

  4075.                      CZIL   ,ZLM    ,ILOC   ,JLOC   ,         & !in
    4076. 

  4076.                      AKMS   ,AKHS   ,RLMO   ,WSTAR2 ,         & !in
    4077. 

  4077.                      USTAR  )                                   !out
    4078. 

  4078. 

  4079. ! -------------------------------------------------------------------------------------------------
    4080. 

  4080. ! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL)
    4081. 

  4081. ! -------------------------------------------------------------------------------------------------
    4082. 

  4082. ! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS.
    4083. 

  4083. ! SEE CHEN ET AL (1997, BLM)
    4084. 

  4084. ! -------------------------------------------------------------------------------------------------
    4085. 

  4085. 

  4086.     IMPLICIT NONE
    4087. 

  4087.     INTEGER, INTENT(IN) :: ILOC
    4088. 

  4088.     INTEGER, INTENT(IN) :: JLOC
    4089. 

  4089.     INTEGER, INTENT(IN) :: ITER
    4090. 

  4090.     REAL,    INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD, CZIL
    4091. 

  4091.     REAL, intent(INOUT) :: AKMS
    4092. 

  4092.     REAL, intent(INOUT) :: AKHS
    4093. 

  4093.     REAL, intent(INOUT) :: RLMO
    4094. 

  4094.     REAL, intent(INOUT) :: WSTAR2
    4095. 

  4095.     REAL,   intent(OUT) :: USTAR
    4096. 

  4096. 

  4097.     REAL     ZZ, PSLMU, PSLMS, PSLHU, PSLHS
    4098. 

  4098.     REAL     XX, PSPMU, YY, PSPMS, PSPHU, PSPHS
    4099. 

  4099.     REAL     ZILFC, ZU, ZT, RDZ, CXCH
    4100. 

  4100.     REAL     DTHV, DU2, BTGH, ZSLU, ZSLT, RLOGU, RLOGT
    4101. 

  4101.     REAL     ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4
    4102. 

  4102. 

  4103.     REAL     XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN,  &
    4104. 

  4104.          &         RLMA
    4105. 

  4105. 

  4106.     INTEGER  ILECH, ITR
    4107. 

  4107. 

  4108.     INTEGER, PARAMETER :: ITRMX  = 5
    4109. 

  4109.     REAL,    PARAMETER :: WWST   = 1.2
    4110. 

  4110.     REAL,    PARAMETER :: WWST2  = WWST * WWST
    4111. 

  4111.     REAL,    PARAMETER :: VKRM   = 0.40
    4112. 

  4112.     REAL,    PARAMETER :: EXCM   = 0.001
    4113. 

  4113.     REAL,    PARAMETER :: BETA   = 1.0 / 270.0
    4114. 

  4114.     REAL,    PARAMETER :: BTG    = BETA * GRAV
    4115. 

  4115.     REAL,    PARAMETER :: ELFC   = VKRM * BTG
    4116. 

  4116.     REAL,    PARAMETER :: WOLD   = 0.15
    4117. 

  4117.     REAL,    PARAMETER :: WNEW   = 1.0 - WOLD
    4118. 

  4118.     REAL,    PARAMETER :: PIHF   = 3.14159265 / 2.
    4119. 

  4119.     REAL,    PARAMETER :: EPSU2  = 1.E-4
    4120. 

  4120.     REAL,    PARAMETER :: EPSUST = 0.07
    4121. 

  4121.     REAL,    PARAMETER :: EPSIT  = 1.E-4
    4122. 

  4122.     REAL,    PARAMETER :: EPSA   = 1.E-8
    4123. 

  4123.     REAL,    PARAMETER :: ZTMIN  = -5.0
    4124. 

  4124.     REAL,    PARAMETER :: ZTMAX  = 1.0
    4125. 

  4125.     REAL,    PARAMETER :: HPBL   = 1000.0
    4126. 

  4126.     REAL,    PARAMETER :: SQVISC = 258.2
    4127. 

  4127.     REAL,    PARAMETER :: RIC    = 0.183
    4128. 

  4128.     REAL,    PARAMETER :: RRIC   = 1.0 / RIC
    4129. 

  4129.     REAL,    PARAMETER :: FHNEU  = 0.8
    4130. 

  4130.     REAL,    PARAMETER :: RFC    = 0.191
    4131. 

  4131.     REAL,    PARAMETER :: RFAC   = RIC / ( FHNEU * RFC * RFC )
    4132. 

  4132. 

  4133. ! ----------------------------------------------------------------------
    4134. 

  4134. ! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS
    4135. 

  4135. ! ----------------------------------------------------------------------
    4136. 

  4136. ! LECH'S SURFACE FUNCTIONS
    4137. 

  4137.     PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ)
    4138. 

  4138.     PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.))
    4139. 

  4139.     PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ)
    4140. 

  4140.     PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.))
    4141. 

  4141. ! PAULSON'S SURFACE FUNCTIONS
    4142. 

  4142.     PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5)   &
    4143. 

  4143.          &        +2.* ATAN (XX)                                            &
    4144. 

  4144.          &- PIHF
    4145. 

  4145.     PSPMS (YY)= 5.* YY
    4146. 

  4146.     PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5)
    4147. 

  4147.     PSPHS (YY)= 5.* YY
    4148. 

  4148. 

  4149. ! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND
    4150. 

  4150. ! OVER SOLID SURFACE (LAND, SEA-ICE).
    4151. 

  4151. ! ----------------------------------------------------------------------
    4152. 

  4152. !     ZTFC: RATIO OF ZOH/ZOM  LESS OR EQUAL THAN 1
    4153. 

  4153. !     C......ZTFC=0.1
    4154. 

  4154. !     CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT
    4155. 

  4155. ! ----------------------------------------------------------------------
    4156. 

  4156.     ILECH = 0
    4157. 

  4157. 

  4158. ! ----------------------------------------------------------------------
    4159. 

  4159.     ZILFC = - CZIL * VKRM * SQVISC
    4160. 

  4160.     ZU = Z0
    4161. 

  4161.     RDZ = 1./ ZLM
    4162. 

  4162.     CXCH = EXCM * RDZ
    4163. 

  4163.     DTHV = THLM - THZ0
    4164. 

  4164. 

  4165. ! BELJARS CORRECTION OF USTAR
    4166. 

  4166.     DU2 = MAX (SFCSPD * SFCSPD,EPSU2)
    4167. 

  4167.     BTGH = BTG * HPBL
    4168. 

  4168. 

  4169.     IF(ITER == 1) THEN
    4170. 

  4170.         IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
    4171. 

  4171.            WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
    4172. 

  4172.         ELSE
    4173. 

  4173.            WSTAR2 = 0.0
    4174. 

  4174.         END IF
    4175. 

  4175.         USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
    4176. 

  4176.         RLMO = ELFC * AKHS * DTHV / USTAR **3
    4177. 

  4177.     END IF
    4178. 

  4178.  
    4179. 

  4179. ! ZILITINKEVITCH APPROACH FOR ZT
    4180. 

  4180.     ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0)
    4181. 

  4181.     ZSLU = ZLM + ZU
    4182. 

  4182.     ZSLT = ZLM + ZT
    4183. 

  4183.     RLOGU = log (ZSLU / ZU)
    4184. 

  4184.     RLOGT = log (ZSLT / ZT)
    4185. 

  4185. 

  4186. ! ----------------------------------------------------------------------
    4187. 

  4187. ! 1./MONIN-OBUKKHOV LENGTH-SCALE
    4188. 

  4188. ! ----------------------------------------------------------------------
    4189. 

  4189.     ZETALT = MAX (ZSLT * RLMO,ZTMIN)
    4190. 

  4190.     RLMO = ZETALT / ZSLT
    4191. 

  4191.     ZETALU = ZSLU * RLMO
    4192. 

  4192.     ZETAU = ZU * RLMO
    4193. 

  4193.     ZETAT = ZT * RLMO
    4194. 

  4194. 

  4195.     IF (ILECH .eq. 0) THEN
    4196. 

  4196.        IF (RLMO .lt. 0.)THEN
    4197. 

  4197.           XLU4 = 1. -16.* ZETALU
    4198. 

  4198.           XLT4 = 1. -16.* ZETALT
    4199. 

  4199.           XU4  = 1. -16.* ZETAU
    4200. 

  4200.           XT4  = 1. -16.* ZETAT
    4201. 

  4201.           XLU  = SQRT (SQRT (XLU4))
    4202. 

  4202.           XLT  = SQRT (SQRT (XLT4))
    4203. 

  4203.           XU   = SQRT (SQRT (XU4))
    4204. 

  4204. 

  4205.           XT = SQRT (SQRT (XT4))
    4206. 

  4206.           PSMZ = PSPMU (XU)
    4207. 

  4207.           SIMM = PSPMU (XLU) - PSMZ + RLOGU
    4208. 

  4208.           PSHZ = PSPHU (XT)
    4209. 

  4209.           SIMH = PSPHU (XLT) - PSHZ + RLOGT
    4210. 

  4210.        ELSE
    4211. 

  4211.           ZETALU = MIN (ZETALU,ZTMAX)
    4212. 

  4212.           ZETALT = MIN (ZETALT,ZTMAX)
    4213. 

  4213.           PSMZ = PSPMS (ZETAU)
    4214. 

  4214.           SIMM = PSPMS (ZETALU) - PSMZ + RLOGU
    4215. 

  4215.           PSHZ = PSPHS (ZETAT)
    4216. 

  4216.           SIMH = PSPHS (ZETALT) - PSHZ + RLOGT
    4217. 

  4217.        END IF
    4218. 

  4218. ! ----------------------------------------------------------------------
    4219. 

  4219. ! LECH'S FUNCTIONS
    4220. 

  4220. ! ----------------------------------------------------------------------
    4221. 

  4221.     ELSE
    4222. 

  4222.        IF (RLMO .lt. 0.)THEN
    4223. 

  4223.           PSMZ = PSLMU (ZETAU)
    4224. 

  4224.           SIMM = PSLMU (ZETALU) - PSMZ + RLOGU
    4225. 

  4225.           PSHZ = PSLHU (ZETAT)
    4226. 

  4226.           SIMH = PSLHU (ZETALT) - PSHZ + RLOGT
    4227. 

  4227.        ELSE
    4228. 

  4228.           ZETALU = MIN (ZETALU,ZTMAX)
    4229. 

  4229.           ZETALT = MIN (ZETALT,ZTMAX)
    4230. 

  4230.           PSMZ = PSLMS (ZETAU)
    4231. 

  4231.           SIMM = PSLMS (ZETALU) - PSMZ + RLOGU
    4232. 

  4232.           PSHZ = PSLHS (ZETAT)
    4233. 

  4233.           SIMH = PSLHS (ZETALT) - PSHZ + RLOGT
    4234. 

  4234.        END IF
    4235. 

  4235. ! ----------------------------------------------------------------------
    4236. 

  4236.        END IF
    4237. 

  4237. 

  4238. ! ----------------------------------------------------------------------
    4239. 

  4239. ! BELJAARS CORRECTION FOR USTAR
    4240. 

  4240. ! ----------------------------------------------------------------------
    4241. 

  4241.        USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
    4242. 

  4242. 

  4243. ! ZILITINKEVITCH FIX FOR ZT
    4244. 

  4244.        ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0)
    4245. 

  4245.        ZSLT = ZLM + ZT
    4246. 

  4246. !-----------------------------------------------------------------------
    4247. 

  4247.        RLOGT = log (ZSLT / ZT)
    4248. 

  4248.        USTARK = USTAR * VKRM
    4249. 

  4249.        AKMS = MAX (USTARK / SIMM,CXCH)
    4250. 

  4250. !-----------------------------------------------------------------------
    4251. 

  4251. ! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO
    4252. 

  4252. !-----------------------------------------------------------------------
    4253. 

  4253.        AKHS = MAX (USTARK / SIMH,CXCH)
    4254. 

  4254. 

  4255.        IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
    4256. 

  4256.           WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
    4257. 

  4257.        ELSE
    4258. 

  4258.           WSTAR2 = 0.0
    4259. 

  4259.        END IF
    4260. 

  4260. !-----------------------------------------------------------------------
    4261. 

  4261.        RLMN = ELFC * AKHS * DTHV / USTAR **3
    4262. 

  4262. !-----------------------------------------------------------------------
    4263. 

  4263. !     IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT)    GO TO 110
    4264. 

  4264. !-----------------------------------------------------------------------
    4265. 

  4265.        RLMA = RLMO * WOLD+ RLMN * WNEW
    4266. 

  4266. !-----------------------------------------------------------------------
    4267. 

  4267.        RLMO = RLMA
    4268. 

  4268. 

  4269. !       write(*,'(a20,10f15.6)')'SFCDIF: RLMO=',RLMO,RLMN,ELFC , AKHS , DTHV , USTAR
    4270. 

  4270. !    END DO
    4271. 

  4271. ! ----------------------------------------------------------------------
    4272. 

  4272.   END SUBROUTINE SFCDIF2
    4273. 

  4273. !jref:start 
    4274. 

  4274. ! ==================================================================================================
    4275. 

  4275.   SUBROUTINE SFCDIF3(ILOC   ,JLOC   ,TSK    ,QS     ,PSFC   ,&  !in  
    4276. 

  4276.                      PBLH   ,Z0     ,Z0BASE ,VEGTYP ,ISURBAN,&  !in  
    4277. 

  4277.                      IZ0TLND,SFCSPD ,ITER   ,ITRMX  ,TLOW   ,&  !in  
    4278. 

  4278.                      THLOW  ,QLOW   ,CWMLOW ,ZSL    ,        &  !in
    4279. 

  4279.                      PLOW   ,USTAR  ,AKMS   ,AKHS   ,CHS2   ,&  !inout
    4280. 

  4280.                      CQS2   ,RLMO   )                           !out 
    4281. 

  4281. 

  4282.   USE MODULE_SF_MYJSFC, ONLY :   &
    4283. 

  4283.      &                         EPSU2  , &  
    4284. 

  4284.      &                         EPSUST , &
    4285. 

  4285.      &                         EPSZT  , &  
    4286. 

  4286.      &                         BETA   , &  
    4287. 

  4287.      &                         EXCML  , &  
    4288. 

  4288.      &                         RIC    , &  
    4289. 

  4289.      &                         SQVISC , &
    4290. 

  4290.      &                         ZTFC   , &  
    4291. 

  4291.      &                         BTG    , &  
    4292. 

  4292.      &                         CZIV   , &  
    4293. 

  4293.      &                         PI     , &  
    4294. 

  4294.      &                         PIHF   , &  
    4295. 

  4295.      &                         KZTM   , &  
    4296. 

  4296.      &                         KZTM2  , &  
    4297. 

  4297.      &                         DZETA1 , &
    4298. 

  4298.      &                         DZETA2 , &
    4299. 

  4299.      &                         FH01   , &  
    4300. 

  4300.      &                         FH02   , &  
    4301. 

  4301.      &                         WWST2  , &  
    4302. 

  4302.      &                         WWST   , &  
    4303. 

  4303.      &                         ZTMAX1 , &
    4304. 

  4304.      &                         ZTMAX2 , &
    4305. 

  4305.      &                         ZTMIN1 , &
    4306. 

  4306.      &                         ZTMIN2 , &
    4307. 

  4307.      &                         PSIH1  , &  
    4308. 

  4308.      &                         PSIH2  , &  
    4309. 

  4309.      &                         PSIM1  , &  
    4310. 

  4310.      &                         PSIM2   
    4311. 

  4311. 

  4312.   USE MODULE_MODEL_CONSTANTS
    4313. 

  4313. 

  4314. !----------------------------------------------------------------------   
    4315. 

  4315. !  computing surface drag coefficient CM for momentum and CH for heat
    4316. 

  4316. !  Joakim Refslund, 2011, MYJ SFCLAY
    4317. 

  4317. !----------------------------------------------------------------------   
    4318. 

  4318.    IMPLICIT NONE     
    4319. 

  4319. !----------------------------------------------------------------------   
    4320. 

  4320. ! input
    4321. 

  4321.     INTEGER,INTENT(IN) :: ILOC
    4322. 

  4322.     INTEGER,INTENT(IN) :: JLOC
    4323. 

  4323.     REAL   ,INTENT(IN) :: TSK
    4324. 

  4324.     REAL   ,INTENT(IN) :: PSFC
    4325. 

  4325.     REAL   ,INTENT(IN) :: PBLH
    4326. 

  4326.     INTEGER,INTENT(IN) :: VEGTYP  !in routine
    4327. 

  4327.     INTEGER,INTENT(IN) :: ISURBAN !in veg_parm                    
    4328. 

  4328.     INTEGER,INTENT(IN) :: IZ0TLND
    4329. 

  4329.     REAL   ,INTENT(IN) :: QLOW
    4330. 

  4330.     REAL   ,INTENT(IN) :: THLOW
    4331. 

  4331.     REAL   ,INTENT(IN) :: TLOW
    4332. 

  4332.     REAL   ,INTENT(IN) :: CWMLOW
    4333. 

  4333.     REAL   ,INTENT(IN) :: SFCSPD
    4334. 

  4334.     REAL   ,INTENT(IN) :: PLOW
    4335. 

  4335.     REAL   ,INTENT(IN) :: ZSL
    4336. 

  4336.     REAL   ,INTENT(IN) :: Z0BASE
    4337. 

  4337.     INTEGER,INTENT(IN) :: ITER
    4338. 

  4338.     INTEGER,INTENT(IN) :: ITRMX
    4339. 

  4339. 

  4340. ! output                                                                        
    4341. 

  4341.     REAL   ,INTENT(OUT) :: CHS2
    4342. 

  4342.     REAL   ,INTENT(OUT) :: CQS2
    4343. 

  4343.     REAL   ,INTENT(OUT) :: RLMO
    4344. 

  4344. 

  4345. ! input/output
    4346. 

  4346.     REAL   ,INTENT(INOUT) :: AKHS
    4347. 

  4347.     REAL   ,INTENT(INOUT) :: AKMS
    4348. 

  4348.     REAL   :: QZ0
    4349. 

  4349.     REAL   ,INTENT(INOUT) :: USTAR
    4350. 

  4350.     REAL   ,INTENT(IN) :: Z0
    4351. 

  4351.     REAL   ,INTENT(INOUT):: QS
    4352. 

  4352.     REAL                :: RIB
    4353. 

  4353. 

  4354. ! local
    4355. 

  4355.     INTEGER :: ITR,K
    4356. 

  4356.     REAL :: THZ0
    4357. 

  4357.     REAL :: THVLOW
    4358. 

  4358.     REAL :: CT
    4359. 

  4359.     REAL :: BTGH
    4360. 

  4360.     REAL :: BTGX
    4361. 

  4361.     REAL :: CXCHL
    4362. 

  4362.     REAL :: DTHV
    4363. 

  4363.     REAL :: DU2
    4364. 

  4364.     REAL :: ELFC
    4365. 

  4365.     REAL :: PSH02
    4366. 

  4366.     REAL :: PSH10
    4367. 

  4367.     REAL :: PSHZ
    4368. 

  4368.     REAL :: PSHZL
    4369. 

  4369.     REAL :: PSM10
    4370. 

  4370.     REAL :: PSMZ
    4371. 

  4371.     REAL :: PSMZL
    4372. 

  4372.     REAL :: RDZ
    4373. 

  4373.     REAL :: RDZT
    4374. 

  4374.     REAL :: RLMA !???
    4375. 

  4375.     REAL :: RLMN !???
    4376. 

  4376.     REAL :: RLOGT
    4377. 

  4377.     REAL :: RLOGU
    4378. 

  4378.     REAL :: RZ
    4379. 

  4379.     REAL :: SIMH
    4380. 

  4380.     REAL :: SIMM
    4381. 

  4381.     REAL :: USTARK
    4382. 

  4382.     REAL :: WSTAR2
    4383. 

  4383.     REAL :: WSTAR
    4384. 

  4384.     REAL :: CHS
    4385. 

  4385.     REAL :: RZSU
    4386. 

  4386.     REAL :: RZST
    4387. 

  4387.     REAL :: X,XLT,XLT4,XLU,XLU4,XT,XT4,XU,XU4,ZETALT,ZETALU         , &
    4388. 

  4388.             ZETAT,ZETAU,ZQ,ZSLT,ZSLU,ZT,ZU,TOPOTERM,ZZIL
    4389. 

  4389.     REAL :: AKHS02,AKHS10,AKMS02,AKMS10
    4390. 

  4390.     REAL :: ZU10
    4391. 

  4391.     REAL :: ZT02
    4392. 

  4392.     REAL :: ZT10
    4393. 

  4393.     REAL :: RLNU10
    4394. 

  4394.     REAL :: RLNT02
    4395. 

  4395.     REAL :: RLNT10
    4396. 

  4396.     REAL :: ZTAU10
    4397. 

  4397.     REAL :: ZTAT02
    4398. 

  4398.     REAL :: ZTAT10
    4399. 

  4399.     REAL :: SIMM10
    4400. 

  4400.     REAL :: SIMH02
    4401. 

  4401.     REAL :: SIMH10
    4402. 

  4402.     REAL :: ZUUZ
    4403. 

  4403.     REAL :: EKMS10
    4404. 

  4404.     REAL :: test
    4405. 

  4405.     REAL :: E1
    4406. 

  4406. 

  4407.    REAL,    PARAMETER :: VKRM    = 0.40
    4408. 

  4408.    REAL,    PARAMETER :: CZETMAX = 10.
    4409. 

  4409. 

  4410. ! diagnostic terms                                                         
    4411. 

  4411. 

  4412.    REAL :: CZIL
    4413. 

  4413.    REAL :: ZILFC
    4414. 

  4414. 

  4415. ! KTMZ,KTMZ2,DZETA1,DZETA2,FH01,FH02,ZTMAX1,ZTMAX2,ZTMIN1,ZTMIN2,
    4416. 

  4416. ! PSIH1,PSIH2,PSIM1,PSIM2 ARE DEFINED IN MODULE_SF_MYJSFC
    4417. 

  4417. 

  4418. !----------------------------------------------------------------------   
    4419. 

  4419. !    IF (ILOC.eq.39 .and. JLOC.eq.63 .and. ITER == 1 ) then
    4420. 

  4420. !      write(*,*) "THZ0=",THZ0
    4421. 

  4421. !      write(*,*) "QS =",QS
    4422. 

  4422. !      write(*,*) "PSFC=",PSFC
    4423. 

  4423. !      write(*,*) "PBLH=",PBLH
    4424. 

  4424. !      write(*,*) "Z0=",Z0
    4425. 

  4425. !      write(*,*) "Z0BASE=",Z0BASE
    4426. 

  4426. !      write(*,*) "VEGTYP=",VEGTYP
    4427. 

  4427. !      write(*,*) "ISURBAN=",ISURBAN
    4428. 

  4428. !      write(*,*) "IZ0TLND=",IZ0TLND
    4429. 

  4429. !      write(*,*) "SFCSPD=",SFCSPD
    4430. 

  4430. !      write(*,*) "TLOW=",TLOW
    4431. 

  4431. !      write(*,*) "THLOW=",THLOW
    4432. 

  4432. !      write(*,*) "THVLOW=",THVLOW
    4433. 

  4433. !      write(*,*) "QLOW=",QLOW
    4434. 

  4434. !      write(*,*) "CWMLOW=",CWMLOW
    4435. 

  4435. !      write(*,*) "ZSL=",ZSL
    4436. 

  4436. !      write(*,*) "PLOW=",PLOW
    4437. 

  4437. !      write(*,*) "USTAR=",USTAR
    4438. 

  4438. !      write(*,*) "AKMS=",AKMS
    4439. 

  4439. !      write(*,*) "AKHS=",AKHS
    4440. 

  4440. !      write(*,*) "CHS2=",CHS2
    4441. 

  4441. !      write(*,*) "CQS2=",CQS2
    4442. 

  4442. !      write(*,*) "RLMO=",RLMO
    4443. 

  4443. !      write(*,*) "ITER=",ITER
    4444. 

  4444. !      call wrf_error_fatal("STOP in SFCDIF3")
    4445. 

  4445. !    ENDIF
    4446. 

  4446. 

  4447. ! calculate potential and virtual potential temperatures
    4448. 

  4448.     THVLOW = THLOW*(1.+EP_1*QLOW)
    4449. 

  4449.     THZ0   = TSK*(P1000mb/PSFC)**RCP
    4450. 

  4450. 

  4451. ! calculate initial values
    4452. 

  4452.     ZU = Z0
    4453. 

  4453.     ZT = ZU*ZTFC      !ZTFC = ZOH/ZOM =<1 set to 1 at beginning                                                 
    4454. 

  4454.     ZQ = ZT
    4455. 

  4455.     QZ0 = QS
    4456. 

  4456. 

  4457.     RDZ = 1./ZSL
    4458. 

  4458.     CXCHL = EXCML*RDZ
    4459. 

  4459.     DTHV = THVLOW-THZ0*(0.608*QZ0+1.)    !delta pot. virtual temperature 
    4460. 

  4460. 

  4461.     BTGX=GRAV/THLOW
    4462. 

  4462.     ELFC=VKRM*BTGX
    4463. 

  4463. 

  4464. ! Minimum PBLH is >= 1000.
    4465. 

  4465.     IF(PBLH > 1000.)THEN  
    4466. 

  4466.        BTGH = BTGX*PBLH
    4467. 

  4467.     ELSE
    4468. 

  4468.        BTGH = BTGX*1000.
    4469. 

  4469.     ENDIF
    4470. 

  4470. 

  4471.     DU2 = MAX(SFCSPD*SFCSPD,EPSU2)  !Wind speed - EPSU2 parm = 1*10^-6                    
    4472. 

  4472.     RIB = BTGX*DTHV*ZSL/DU2         !Bulk richardson stability                               
    4473. 

  4473. 

  4474.     ZSLU = ZSL+ZU
    4475. 

  4475.     RZSU = ZSLU/ZU
    4476. 

  4476.     RLOGU = LOG(RZSU)       !log(z/z0) 
    4477. 

  4477. 

  4478.     ZSLT = ZSL + ZU
    4479. 

  4479. 

  4480.     IF ( (IZ0TLND==0) .or. (VEGTYP == ISURBAN) ) THEN    ! ARE IZ0TLND DEFINED HERE?           
    4481. 

  4481.         ! Just use the original CZIL value.                          
    4482. 

  4482.         CZIL = 0.1
    4483. 

  4483.     ELSE
    4484. 

  4484.         ! Modify CZIL according to Chen & Zhang, 2009                
    4485. 

  4485.         ! CZIL = 10 ** -0.40 H, ( where H = 10*Zo )                  
    4486. 

  4486.         CZIL = 10.0 ** ( -0.40 * ( Z0 / 0.07 ) )
    4487. 

  4487.     ENDIF
    4488. 

  4488.     ZILFC=-CZIL*VKRM*SQVISC     !SQVISC parm                                 
    4489. 

  4489. 

  4490. ! stable                                                                  
    4491. 

  4491.     IF(DTHV>0.)THEN
    4492. 

  4492.        IF (RIB<RIC) THEN
    4493. 

  4493.           ZZIL=ZILFC*(1.0+(RIB/RIC)*(RIB/RIC)*CZETMAX)
    4494. 

  4494.        ELSE
    4495. 

  4495.           ZZIL=ZILFC*(1.0+CZETMAX)
    4496. 

  4496.        ENDIF
    4497. 

  4497. ! unstable                                                                
    4498. 

  4498.     ELSE
    4499. 

  4499.        ZZIL=ZILFC
    4500. 

  4500.     ENDIF
    4501. 

  4501. 

  4502. !---  ZILITINKEVITCH FIX FOR ZT                                           
    4503. 

  4503. ! oldform   ZT=MAX(EXP(ZZIL*SQRT(USTAR*ZU))*ZU,EPSZT)                     
    4504. 

  4504.     ZT=MAX(EXP(ZZIL*SQRT(USTAR*Z0BASE))*Z0BASE,EPSZT)  !Z0 is backgrund roughness?           
    4505. 

  4505.     RZST=ZSLT/ZT
    4506. 

  4506.     RLOGT=LOG(RZST)
    4507. 

  4507. 

  4508. !----------------------------------------------------------------------   
    4509. 

  4509. !  1./MONIN-OBUKHOV LENGTH-SCALE                                       
    4510. 

  4510. !----------------------------------------------------------------------   
    4511. 

  4511.     RLMO=ELFC*AKHS*DTHV/USTAR**3
    4512. 

  4512. 

  4513.     ZETALU=ZSLU*RLMO
    4514. 

  4514.     ZETALT=ZSLT*RLMO
    4515. 

  4515.     ZETAU=ZU*RLMO
    4516. 

  4516.     ZETAT=ZT*RLMO
    4517. 

  4517. 

  4518.     ZETALU=MIN(MAX(ZETALU,ZTMIN2),ZTMAX2)
    4519. 

  4519.     ZETALT=MIN(MAX(ZETALT,ZTMIN2),ZTMAX2)
    4520. 

  4520.     ZETAU=MIN(MAX(ZETAU,ZTMIN2/RZSU),ZTMAX2/RZSU)
    4521. 

  4521.     ZETAT=MIN(MAX(ZETAT,ZTMIN2/RZST),ZTMAX2/RZST)
    4522. 

  4522. 

  4523. !----------------------------------------------------------------------   
    4524. 

  4524. !***  LAND FUNCTIONS                                                      
    4525. 

  4525. !----------------------------------------------------------------------   
    4526. 

  4526. 

  4527.     RZ=(ZETAU-ZTMIN2)/DZETA2
    4528. 

  4528.     K=INT(RZ)
    4529. 

  4529.     RDZT=RZ-REAL(K)
    4530. 

  4530.     K=MIN(K,KZTM2)
    4531. 

  4531.     K=MAX(K,0)
    4532. 

  4532.     PSMZ=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1)
    4533. 

  4533. 

  4534.     RZ=(ZETALU-ZTMIN2)/DZETA2
    4535. 

  4535.     K=INT(RZ)
    4536. 

  4536.     RDZT=RZ-REAL(K)
    4537. 

  4537.     K=MIN(K,KZTM2)
    4538. 

  4538.     K=MAX(K,0)
    4539. 

  4539.     PSMZL=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1)
    4540. 

  4540. 

  4541.     SIMM=PSMZL-PSMZ+RLOGU
    4542. 

  4542. 

  4543.     RZ=(ZETAT-ZTMIN2)/DZETA2
    4544. 

  4544.     K=INT(RZ)
    4545. 

  4545.     RDZT=RZ-REAL(K)
    4546. 

  4546.     K=MIN(K,KZTM2)
    4547. 

  4547.     K=MAX(K,0)
    4548. 

  4548.     PSHZ=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1)
    4549. 

  4549. 

  4550.     RZ=(ZETALT-ZTMIN2)/DZETA2
    4551. 

  4551.     K=INT(RZ)
    4552. 

  4552.     RDZT=RZ-REAL(K)
    4553. 

  4553.     K=MIN(K,KZTM2)
    4554. 

  4554.     K=MAX(K,0)
    4555. 

  4555.     PSHZL=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1)
    4556. 

  4556. 

  4557.     SIMH=(PSHZL-PSHZ+RLOGT)*FH02
    4558. 

  4558. !----------------------------------------------------------------------   
    4559. 

  4559.     USTARK=USTAR*VKRM
    4560. 

  4560.     AKMS=MAX(USTARK/SIMM,CXCHL)
    4561. 

  4561.     AKHS=MAX(USTARK/SIMH,CXCHL)
    4562. 

  4562. 

  4563. !----------------------------------------------------------------------   
    4564. 

  4564. !  BELJAARS CORRECTION FOR USTAR                                       
    4565. 

  4565. !----------------------------------------------------------------------   
    4566. 

  4566. 

  4567.     IF(DTHV<=0.)THEN                                           !zj
    4568. 

  4568.       WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.)                !zj
    4569. 

  4569.     ELSE                                                       !zj
    4570. 

  4570.       WSTAR2=0.                                                !zj
    4571. 

  4571.     ENDIF                                                      !zj
    4572. 

  4572. 

  4573.     USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST)
    4574. 

  4574. 

  4575.     CT=0.
    4576. 

  4576. !----------------------------------------------------------------------   
    4577. 

  4577. !***  THE FOLLOWING DIAGNOSTIC BLOCK PRODUCES 2-m and 10-m VALUES         
    4578. 

  4578. !***  FOR TEMPERATURE, MOISTURE, AND WINDS.  IT IS DONE HERE SINCE        
    4579. 

  4579. !***  THE VARIOUS QUANTITIES NEEDED FOR THE COMPUTATION ARE LOST          
    4580. 

  4580. !***  UPON EXIT FROM THE ROTUINE.                                         
    4581. 

  4581. !----------------------------------------------------------------------   
    4582. 

  4582.     WSTAR=SQRT(WSTAR2)/WWST
    4583. 

  4583. 

  4584. !jref: calculate in last iteration
    4585. 

  4585. !  IF (ITER == ITRMX) THEN
    4586. 

  4586. 

  4587.     ZU10=ZU+10.
    4588. 

  4588.     ZT02=ZT+02.
    4589. 

  4589.     ZT10=ZT+10.
    4590. 

  4590. 

  4591.     RLNU10=LOG(ZU10/ZU)
    4592. 

  4592.     RLNT02=LOG(ZT02/ZT)
    4593. 

  4593.     RLNT10=LOG(ZT10/ZT)
    4594. 

  4594. 

  4595.     ZTAU10=ZU10*RLMO
    4596. 

  4596.     ZTAT02=ZT02*RLMO
    4597. 

  4597.     ZTAT10=ZT10*RLMO
    4598. 

  4598. 

  4599.     ZTAU10=MIN(MAX(ZTAU10,ZTMIN2),ZTMAX2)
    4600. 

  4600.     ZTAT02=MIN(MAX(ZTAT02,ZTMIN2),ZTMAX2)
    4601. 

  4601.     ZTAT10=MIN(MAX(ZTAT10,ZTMIN2),ZTMAX2)
    4602. 

  4602. 

  4603. !jref: land diagnostic functions
    4604. 

  4604.     RZ=(ZTAU10-ZTMIN2)/DZETA2
    4605. 

  4605.     K=INT(RZ)
    4606. 

  4606.     RDZT=RZ-REAL(K)
    4607. 

  4607.     K=MIN(K,KZTM2)
    4608. 

  4608.     K=MAX(K,0)
    4609. 

  4609.     PSM10=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1)
    4610. 

  4610. 

  4611.     SIMM10=PSM10-PSMZ+RLNU10
    4612. 

  4612. 

  4613.     RZ=(ZTAT02-ZTMIN2)/DZETA2
    4614. 

  4614.     K=INT(RZ)
    4615. 

  4615.     RDZT=RZ-REAL(K)
    4616. 

  4616.     K=MIN(K,KZTM2)
    4617. 

  4617.     K=MAX(K,0)
    4618. 

  4618.     PSH02=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1)
    4619. 

  4619. 

  4620.     SIMH02=(PSH02-PSHZ+RLNT02)*FH02
    4621. 

  4621. 

  4622.     RZ=(ZTAT10-ZTMIN2)/DZETA2
    4623. 

  4623.     K=INT(RZ)
    4624. 

  4624.     RDZT=RZ-REAL(K)
    4625. 

  4625.     K=MIN(K,KZTM2)
    4626. 

  4626.     K=MAX(K,0)
    4627. 

  4627.     PSH10=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1)
    4628. 

  4628. 

  4629.     SIMH10=(PSH10-PSHZ+RLNT10)*FH02
    4630. 

  4630. 

  4631. !jref: diagnostic exchange coefficients                                                                    
    4632. 

  4632.     AKMS10=MAX(USTARK/SIMM10,CXCHL)
    4633. 

  4633.     AKHS02=MAX(USTARK/SIMH02,CXCHL)
    4634. 

  4634.     AKHS10=MAX(USTARK/SIMH10,CXCHL)
    4635. 

  4635. 

  4636. !jref: calculation of diagnostics for wind, humidity
    4637. 

  4637. 

  4638. !    WSTAR=SQRT(WSTAR2)/WWST
    4639. 

  4639. !
    4640. 

  4640. !    UMFLX=AKMS*(ULOW -UZ0 )
    4641. 

  4641. !    VMFLX=AKMS*(VLOW -VZ0 )
    4642. 

  4642. !    HSFLX=AKHS*(THLOW-THZ0)
    4643. 

  4643. !    HLFLX=AKHS*(QLOW -QZ0 )
    4644. 

  4644. 

  4645. !uncommented for now...
    4646. 

  4646. !    U10 =UMFLX/AKMS10+UZ0                                               
    4647. 

  4647. !    V10 =VMFLX/AKMS10+VZ0                                               
    4648. 

  4648. !    TH02=HSFLX/AKHS02+THZ0                                              
    4649. 

  4649. !                                                                         
    4650. 

  4650. !***  BE CERTAIN THAT THE 2-M THETA AND 10-M THETA ARE BRACKETED BY       
    4651. 

  4651. !***  THE VALUES OF THZ0 AND THLOW.                                       
    4652. 

  4652. !                                                                         
    4653. 

  4653. !      IF(THLOW>THZ0.AND.(TH02<THZ0.OR.TH02>THLOW).OR.                  &  
    4654. 

  4654. !         THLOW<THZ0.AND.(TH02>THZ0.OR.TH02<THLOW))THEN                    
    4655. 

  4655. !           TH02=THZ0+2.*RDZ*(THLOW-THZ0)                                  
    4656. 

  4656. !      ENDIF                                                               
    4657. 

  4657. !                                                                         
    4658. 

  4658. !uncommented for now
    4659. 

  4659. !      TH10=HSFLX/AKHS10+THZ0                                              
    4660. 

  4660. !                                                                         
    4661. 

  4661. !      IF(THLOW>THZ0.AND.(TH10<THZ0.OR.TH10>THLOW).OR.                  &  
    4662. 

  4662. !         THLOW<THZ0.AND.(TH10>THZ0.OR.TH10<THLOW))THEN                    
    4663. 

  4663. !           TH10=THZ0+10.*RDZ*(THLOW-THZ0)                                 
    4664. 

  4664. !      ENDIF                                                               
    4665. 

  4665. !                                                                         
    4666. 

  4666. !      Q02 =HLFLX/AKHS02+QZ0                                               
    4667. 

  4667. !      Q10 =HLFLX/AKHS10+QZ0                                               
    4668. 

  4668. !jref commented out     
    4669. 

  4669. !      TERM1=-0.068283/TLOW                                                
    4670. 

  4670. !      PSHLTR=PSFC*EXP(TERM1)                                              
    4671. 

  4671. !                                
    4672. 

  4672. !----------------------------------------------------------------------   
    4673. 

  4673. !***  COMPUTE "EQUIVALENT" Z0 TO APPROXIMATE LOCAL SHELTER READINGS.      
    4674. 

  4674. !----------------------------------------------------------------------   
    4675. 

  4675. !                                                                         
    4676. 

  4676. !      U10E=U10                                                            
    4677. 

  4677. !      V10E=V10                                                            
    4678. 

  4678. !                                                                         
    4679. 

  4679. !      IF(SEAMASK<0.5)THEN                                                 
    4680. 

  4680. !LAND :                                                                          
    4681. 

  4681. !1st        ZUUZ=MIN(0.5*ZU,0.1)                                          
    4682. 

  4682. !1st        ZU=MAX(0.1*ZU,ZUUZ)                                           
    4683. 

  4683. !tst        ZUUZ=amin1(ZU*0.50,0.3)                                       
    4684. 

  4684. !tst        ZU=amax1(ZU*0.3,ZUUZ)                                         
    4685. 

  4685. 

  4686.         ZUUZ=AMIN1(ZU*0.50,0.18)
    4687. 

  4687.         ZU=AMAX1(ZU*0.35,ZUUZ)
    4688. 

  4688. !                                                                         
    4689. 

  4689.         ZU10=ZU+10.
    4690. 

  4690.         RZSU=ZU10/ZU
    4691. 

  4691.         RLNU10=LOG(RZSU)
    4692. 

  4692. 

  4693.         ZETAU=ZU*RLMO
    4694. 

  4694.         ZTAU10=ZU10*RLMO
    4695. 

  4695. 

  4696.         ZTAU10=MIN(MAX(ZTAU10,ZTMIN2),ZTMAX2)
    4697. 

  4697.         ZETAU=MIN(MAX(ZETAU,ZTMIN2/RZSU),ZTMAX2/RZSU)
    4698. 

  4698. 

  4699.         RZ=(ZTAU10-ZTMIN2)/DZETA2
    4700. 

  4700.         K=INT(RZ)
    4701. 

  4701.         RDZT=RZ-REAL(K)
    4702. 

  4702.         K=MIN(K,KZTM2)
    4703. 

  4703.         K=MAX(K,0)
    4704. 

  4704.         PSM10=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1)
    4705. 

  4705.         SIMM10=PSM10-PSMZ+RLNU10
    4706. 

  4706.         EKMS10=MAX(USTARK/SIMM10,CXCHL)
    4707. 

  4707. 

  4708. !        U10E=UMFLX/EKMS10+UZ0                                             
    4709. 

  4709. !        V10E=VMFLX/EKMS10+VZ0                                             
    4710. 

  4710. 

  4711. !      ENDIF                                                               
    4712. 

  4712. !                                                                         
    4713. 

  4713. !      U10=U10E                                                            
    4714. 

  4714. !      V10=V10E                                                            
    4715. 

  4715. !                                                                         
    4716. 

  4716. !----------------------------------------------------------------------   
    4717. 

  4717. !***  SET OTHER WRF DRIVER ARRAYS                                         
    4718. 

  4718. !----------------------------------------------------------------------   
    4719. 

  4719. !                                                                         
    4720. 

  4720. !jref commented out
    4721. 

  4721. !      RLOW=PLOW/(R_D*TLOW)                                                
    4722. 

  4722.       CHS=AKHS
    4723. 

  4723.       CHS2=AKHS02
    4724. 

  4724.       CQS2=AKHS02
    4725. 

  4725. 

  4726. !  END IF
    4727. 

  4727.   END SUBROUTINE SFCDIF3
    4728. 

  4728. !jref:end
    4729. 

  4729. ! ==================================================================================================
    4730. 

  4730. !jref:start
    4731. 

  4731. !-------------------------------------------------------------------                                                      
    4732. 

  4732.    SUBROUTINE SFCDIF4(ILOC  ,JLOC  ,UX    ,VX     ,T1D  , &
    4733. 

  4733.                       P1D   ,PSFCPA,PBLH  ,DX     ,ZNT  , &
    4734. 

  4734.                       TSK   ,QX    ,ZLVL  ,IZ0TLND,QSFC , &
    4735. 

  4735.                       HFX   ,QFX   ,CM    ,CHS    ,CHS2 , &
    4736. 

  4736.                       CQS2  ,RMOL  ,UST   ,U10    ,V10)
    4737. 

  4737.                                                                                                                           
    4738. 

  4738.    USE MODULE_SF_SFCLAY                                                                                                   
    4739. 

  4739.    USE MODULE_MODEL_CONSTANTS                                                                                             
    4740. 

  4740. !-------------------------------------------------------------------                                                      
    4741. 

  4741. !  Compute surface drag coefficients CM for momentum and CH for heat                                                      
    4742. 

  4742. !  Joakim Refslund, 2011. Modified from YSU SFCLAY.                                                                                     
    4743. 

  4743. !-------------------------------------------------------------------                                                      
    4744. 

  4744.    IMPLICIT NONE                                                                                                          
    4745. 

  4745. !-------------------------------------------------------------------                                                      
    4746. 

  4746. ! parameters                                                                                                              
    4747. 

  4747.    REAL,   PARAMETER     :: XKA=2.4E-5                                                                                    
    4748. 

  4748.    REAL,   PARAMETER     :: PRT=1.     !prandtl number                                                                    
    4749. 

  4749.                                                                                                                           
    4750. 

  4750. ! input                                                                                                                   
    4751. 

  4751.    INTEGER,INTENT(IN )   :: ILOC                                                                                          
    4752. 

  4752.    INTEGER,INTENT(IN )   :: JLOC                                                                                          
    4753. 

  4753.                                                                                                                           
    4754. 

  4754.    REAL,   INTENT(IN )   :: PBLH      ! planetary boundary layer height                                                   
    4755. 

  4755.    REAL,   INTENT(IN )   :: TSK       ! skin temperature                                                                  
    4756. 

  4756.    REAL,   INTENT(IN )   :: PSFCPA    ! pressure in pascal                                                                
    4757. 

  4757.    REAL,   INTENT(IN )   :: P1D       !lowest model layer pressure (Pa)                                                      
    4758. 

  4758.    REAL,   INTENT(IN )   :: T1D       !lowest model layer temperature
    4759. 

  4759. !   REAL,   INTENT(IN )   :: QX        !water vapor mixing ratio (kg/kg)
    4760. 

  4760.    REAL,   INTENT(IN )   :: QX        !water vapor specific humidity (kg/kg)
    4761. 

  4761.    REAL,   INTENT(IN )   :: ZLVL      ! thickness of lowest full level layer
    4762. 

  4762.    REAL,   INTENT(IN )   :: HFX       ! sensible heat flux
    4763. 

  4763.    REAL,   INTENT(IN )   :: QFX       ! moisture flux
    4764. 

  4764.    REAL,   INTENT(IN )   :: DX        ! horisontal grid spacing
    4765. 

  4765.    REAL,   INTENT(IN )   :: UX
    4766. 

  4766.    REAL,   INTENT(IN )   :: VX
    4767. 

  4767.    REAL,   INTENT(IN )   :: ZNT                                                                                           
    4768. 

  4768.    REAL,   INTENT(INOUT ) :: QSFC
    4769. 

  4769. 

  4770.    REAL,   INTENT(INOUT) :: RMOL                                                                                          
    4771. 

  4771.    REAL,   INTENT(INOUT) :: UST                                                                                           
    4772. 

  4772.    REAL,   INTENT(INOUT) :: CHS2                                                                                          
    4773. 

  4773.    REAL,   INTENT(INOUT) :: CQS2                                                                                          
    4774. 

  4774.    REAL,   INTENT(INOUT) :: CHS                                                                                           
    4775. 

  4775.    REAL,   INTENT(INOUT) :: CM                
    4776. 

  4776.                                                                                                                           
    4777. 

  4777. ! diagnostics out                                                                                                         
    4778. 

  4778.    REAL,   INTENT(OUT)   :: U10                                                                                           
    4779. 

  4779.    REAL,   INTENT(OUT)   :: V10                                                                                           
    4780. 

  4780. !   REAL,   INTENT(OUT)   :: TH2                                                                                           
    4781. 

  4781. !   REAL,   INTENT(OUT)   :: T2                                                                                            
    4782. 

  4782. !   REAL,   INTENT(OUT)   :: Q2                                                                                            
    4783. 

  4783. !   REAL,   INTENT(OUT)   :: QSFC                                                                                          
    4784. 

  4784.                                                                                                                           
    4785. 

  4785. ! optional vars                                                                                                           
    4786. 

  4786.    INTEGER,OPTIONAL,INTENT(IN ) :: IZ0TLND                                                                                
    4787. 

  4787.                                                                                                                           
    4788. 

  4788. ! local                                                                                                                   
    4789. 

  4789.    INTEGER :: REGIME  ! Stability regime
    4790. 

  4790.    REAL    :: ZA      ! Height of full-sigma level                                                                        
    4791. 

  4791.    REAL    :: THVX    ! Virtual potential temperature                                                                     
    4792. 

  4792.    REAL    :: ZQKL    ! Height of upper half level                                                                        
    4793. 

  4793.    REAL    :: ZQKLP1  ! Height of lower half level (surface)                                                              
    4794. 

  4794.    REAL    :: THX     ! Potential temperature                                                                             
    4795. 

  4795.    REAL    :: PSIH    ! similarity function for heat                                                                      
    4796. 

  4796.    REAL    :: PSIH2   ! Similarity function for heat 2m                                                                   
    4797. 

  4797.    REAL    :: PSIH10  ! Similarity function for heat 10m                                                                  
    4798. 

  4798.    REAL    :: PSIM    ! similarity function for momentum                                                                  
    4799. 

  4799.    REAL    :: PSIM2   ! Similarity function for momentum 2m                                                               
    4800. 

  4800.    REAL    :: PSIM10  ! Similarity function for momentum 10m                                                              
    4801. 

  4801.    REAL    :: DENOMQ  ! Denominator used for flux calc.                                                                   
    4802. 

  4802.    REAL    :: DENOMQ2 ! Denominator used for flux calc.                                                                   
    4803. 

  4803.    REAL    :: DENOMT2 ! Denominator used for flux calc.                                                                   
    4804. 

  4804.    REAL    :: WSPDI   ! Initial wind speed                                                                                
    4805. 

  4805.    REAL    :: GZ1OZ0  ! log(za/z0)                                                                                        
    4806. 

  4806.    REAL    :: GZ2OZ0  ! log(z2/z0)                                                                                        
    4807. 

  4807.    REAL    :: GZ10OZ0 ! log(z10/z0)                                                                                       
    4808. 

  4808.    REAL    :: RHOX    ! density                                                                                           
    4809. 

  4809.    REAL    :: GOVRTH  ! g/theta for stability L                                                                           
    4810. 

  4810.    REAL    :: TGDSA   ! tsk                                                                                               
    4811. 

  4811. !   REAL    :: SCR3    ! temporal variable -> input variable T1D                                                                                
    4812. 

  4812.    REAL    :: TVIR    ! temporal variable SRC4 -> TVIR                                                                                
    4813. 

  4813.    REAL    :: THGB    ! Potential temperature ground                                                                      
    4814. 

  4814.    REAL    :: PSFC    ! Surface pressure                                                                                  
    4815. 

  4815.    REAL    :: BR      ! bulk richardson number                                                                            
    4816. 

  4816.    REAL    :: CPM                                                                                           
    4817. 

  4817.    REAL    :: MOL                                                                                           
    4818. 

  4818.    REAL    :: ZOL  
    4819. 

  4819.    REAL    :: QGH    
    4820. 

  4820.    REAL    :: WSPD                                                                                          
    4821. 

  4821.                                                                                                                           
    4822. 

  4822.    INTEGER :: N,I,K,KK,L,NZOL,NK,NZOL2,NZOL10                                                                             
    4823. 

  4823.                                                                                                                           
    4824. 

  4824.    REAL    ::  PL,THCON,TVCON,E1                                                                                          
    4825. 

  4825.    REAL    ::  ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10                                                    
    4826. 

  4826.    REAL    ::  DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10                                                         
    4827. 

  4827.    REAL    ::  FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2                                                                    
    4828. 

  4828. !-------------------------------------------------------------------                                                      
    4829. 

  4829.    
    4830. 

  4830.    MOL = 1./RMOL
    4831. 

  4831.    ZL=0.01                                                                                                                
    4832. 

  4832.    PSFC=PSFCPA/1000.                                                                                                      
    4833. 

  4833.                                                                                                                           
    4834. 

  4834. ! convert (tah or tgb = tsk) temperature to potential temperature.                                                                    
    4835. 

  4835.    TGDSA = TSK                                                                                                            
    4836. 

  4836.    THGB  = TSK*(P1000mb/PSFCPA)**RCP                                                                                      
    4837. 

  4837.                                                                                                                           
    4838. 

  4838. ! store virtual, virtual potential and potential temperature
    4839. 

  4839.    PL    = P1D/1000.                                                                                                      
    4840. 

  4840.    THX   = T1D*(P1000mb*0.001/PL)**RCP                                                                                        
    4841. 

  4841.    THVX  = THX*(1.+EP_1*QX)                                                                                                   
    4842. 

  4842.    TVIR  = T1D*(1.+EP_1*QX)
    4843. 

  4843. 

  4844. ! for land points QSFC can come from previous time step                                                                   
    4845. 

  4845.    !QSFC=EP_2*E1/(PSFC-E1)                                                                                
    4846. 

  4846.    IF (QSFC.LE.0.0) THEN
    4847. 

  4847.       !testing this
    4848. 

  4848.       E1=SVP1*EXP(SVP2*(TGDSA-SVPT0)/(TGDSA-SVP3))                                                                           
    4849. 

  4849.       QSFC=EP_2*E1/(PSFC-E1)                                                                                
    4850. 

  4850.       write(*,*) "JREF: IN SFCDIF4, QSFC WAS NEG. NOW = ",QSFC
    4851. 

  4851.    ENDIF
    4852. 

  4852. 

  4853. ! qgh changed to use lowest-level air temp consistent with myjsfc change                                                  
    4854. 

  4854. ! q2sat = qgh in lsm                                                                                                      
    4855. 

  4855. !jref: canres and esat is calculated in the loop so should that be changed??
    4856. 

  4856. !   QGH=EP_2*E1/(PL-E1)                                                                                                    
    4857. 

  4857.    CPM=CP*(1.+0.8*QX)                                                                                                     
    4858. 

  4858.                                                                                                                           
    4859. 

  4859. ! compute the height of half-sigma levels above ground level                                                         
    4860. 

  4860.    !ZA=0.5*DZ8W                                                                                                   
    4861. 

  4861.    ZA = ZLVL
    4862. 

  4862.                                                                                                                           
    4863. 

  4863. ! compute density and part of monin-obukhov length L                                                                      
    4864. 

  4864.    RHOX=PSFC*1000./(R_D*TVIR)                                                                                             
    4865. 

  4865.    GOVRTH=G/THX                                                                                                           
    4866. 

  4866.                                                                                                                           
    4867. 

  4867. ! calculate bulk richardson no. of surface layer,                                                                         
    4868. 

  4868. ! according to akb(1976), eq(12).                                                                                         
    4869. 

  4869.    GZ1OZ0=ALOG(ZA/ZNT)                                                                                                    
    4870. 

  4870.    GZ2OZ0=ALOG(2./ZNT)                                                                                                    
    4871. 

  4871.    GZ10OZ0=ALOG(10./ZNT)                                                                                                  
    4872. 

  4872.    WSPD=SQRT(UX*UX+VX*VX)                                                                                                 
    4873. 

  4873.                                                                                                                           
    4874. 

  4874. ! virtual pot. temperature difference between input layer and lowest model layer                                              
    4875. 

  4875.    TSKV=THGB*(1.+EP_1*QSFC)                                                                                               
    4876. 

  4876.    DTHVDZ=(THVX-TSKV)                                                                                                     
    4877. 

  4877.                                                                                                                           
    4878. 

  4878. ! convective velocity scale Vc and subgrid-scale velocity Vsg                                                             
    4879. 

  4879. ! following Beljaars (1995, QJRMS) and Mahrt and Sun (1995, MWR)                                                          
    4880. 

  4880. !                                ... HONG Aug. 2001                                                                       
    4881. 

  4881. !                                                                                                                         
    4882. 

  4882. ! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm)                                                                                 
    4883. 

  4883. ! use Beljaars over land, old MM5 (Wyngaard) formula over water                                                           
    4884. 

  4884.                                                                                                                           
    4885. 

  4885. !jref:start commented out to see if stability is affected.                                                                                                                          
    4886. 

  4886.   FLUXC = MAX(HFX/RHOX/CP + EP_1*TSKV*QFX/RHOX,0.)                                                                                          
    4887. 

  4887.   VCONV = VCONVC*(G/TGDSA*PBLH*FLUXC)**.33                                                                                
    4888. 

  4888. !  VCONV = 0
    4889. 

  4889. !jref:end
    4890. 

  4890.                                                                                                                           
    4891. 

  4891. ! Mahrt and Sun low-res correction                                                                                        
    4892. 

  4892.    VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33                                                                               
    4893. 

  4893.    WSPD=SQRT(WSPD*WSPD+VCONV*VCONV+VSGD*VSGD)                                                                             
    4894. 

  4894.    WSPD=AMAX1(WSPD,0.1)                                                                                                   
    4895. 

  4895.    BR=GOVRTH*ZA*DTHVDZ/(WSPD*WSPD)                                                                                        
    4896. 

  4896. !  if previously unstable, do not let into regimes 1 and 2                                                                
    4897. 

  4897.    IF(MOL.LT.0.) BR=AMIN1(BR,0.0)                                                                                         
    4898. 

  4898.    RMOL=-GOVRTH*DTHVDZ*ZA*KARMAN                                                                                          
    4899. 

  4899.                                                                                                                           
    4900. 

  4900. !-----------------------------------------------------------------------                                                  
    4901. 

  4901. !     diagnose basic parameters for the appropriated stability class:                                                     
    4902. 

  4902. !                                                                                                                         
    4903. 

  4903. !     the stability classes are determined by br (bulk richardson no.)                                                    
    4904. 

  4904. !     and hol (height of pbl/monin-obukhov length).                                                                       
    4905. 

  4905. !                                                                                                                         
    4906. 

  4906. !     criteria for the classes are as follows:                                                                            
    4907. 

  4907. !                                                                                                                         
    4908. 

  4908. !        1. br .ge. 0.2;                                                                                                  
    4909. 

  4909. !               represents nighttime stable conditions (regime=1),                                                        
    4910. 

  4910. !                                                                                                                         
    4911. 

  4911. !        2. br .lt. 0.2 .and. br .gt. 0.0;                                                                                
    4912. 

  4912. !               represents damped mechanical turbulent conditions                                                         
    4913. 

  4913. !               (regime=2),                                                                                               
    4914. 

  4914. !                                                                                                                         
    4915. 

  4915. !        3. br .eq. 0.0                                                                                                   
    4916. 

  4916. !               represents forced convection conditions (regime=3),                                                       
    4917. 

  4917. !                                                                                                                         
    4918. 

  4918. !        4. br .lt. 0.0                                                                                                   
    4919. 

  4919. !               represents free convection conditions (regime=4).                                                         
    4920. 

  4920. !                                                                                                                         
    4921. 

  4921. !-----------------------------------------------------------------------                                                  
    4922. 

  4922.                                                                                                                           
    4923. 

  4923.    IF (BR.GE.0.2) REGIME=1                                                                                                
    4924. 

  4924.    IF (BR.LT.0.2 .AND. BR.GT.0.0) REGIME=2                                                                                
    4925. 

  4925.    IF (BR.EQ.0.0) REGIME=3                                                                                                
    4926. 

  4926.    IF (BR.LT.0.0) REGIME=4                                                                                                
    4927. 

  4927.                                                                                                                           
    4928. 

  4928.    SELECT CASE(REGIME)                                                                                                    
    4929. 

  4929.      CASE(1) ! class 1; stable (nighttime) conditions:                                                                    
    4930. 

  4930.        PSIM=-10.*GZ1OZ0                                                                                                   
    4931. 

  4931. ! lower limit on psi in stable conditions                                                                                 
    4932. 

  4932.        PSIM=AMAX1(PSIM,-10.)                                                                                              
    4933. 

  4933.        PSIH=PSIM                                                                                                          
    4934. 

  4934.        PSIM10=10./ZA*PSIM                                                                                                 
    4935. 

  4935.        PSIM10=AMAX1(PSIM10,-10.)                                                                                          
    4936. 

  4936.        PSIH10=PSIM10                                                                                                      
    4937. 

  4937.        PSIM2=2./ZA*PSIM                                                                                                   
    4938. 

  4938.        PSIM2=AMAX1(PSIM2,-10.)                                                                                            
    4939. 

  4939.        PSIH2=PSIM2                                                                                                        
    4940. 

  4940.                                                                                                                           
    4941. 

  4941. ! 1.0 over Monin-Obukhov length                                                                                           
    4942. 

  4942.        IF(UST.LT.0.01)THEN                                                                                                
    4943. 

  4943.           RMOL=BR*GZ1OZ0 !ZA/L                                                                                            
    4944. 

  4944.        ELSE                                                                                                               
    4945. 

  4945.           RMOL=KARMAN*GOVRTH*ZA*MOL/(UST*UST) !ZA/L                                                                       
    4946. 

  4946.        ENDIF                                                                                                              
    4947. 

  4947.        RMOL=AMIN1(RMOL,9.999) ! ZA/L                                                                                      
    4948. 

  4948.        RMOL = RMOL/ZA !1.0/L                                                                                              
    4949. 

  4949.                                                                                                                           
    4950. 

  4950.      CASE(2) ! class 2; damped mechanical turbulence:                                                                     
    4951. 

  4951.        PSIM=-5.0*BR*GZ1OZ0/(1.1-5.0*BR)                                                                                   
    4952. 

  4952. ! lower limit on psi in stable conditions                                                                                 
    4953. 

  4953.        PSIM=AMAX1(PSIM,-10.)                                                                                              
    4954. 

  4954. ! AKB(1976), EQ(16).                                                                                                      
    4955. 

  4955.        PSIH=PSIM                                                                                                          
    4956. 

  4956.        PSIM10=10./ZA*PSIM                                                                                                 
    4957. 

  4957.        PSIM10=AMAX1(PSIM10,-10.)                                                                                          
    4958. 

  4958.        PSIH10=PSIM10                                                                                                      
    4959. 

  4959.        PSIM2=2./ZA*PSIM                                                                                                   
    4960. 

  4960.        PSIM2=AMAX1(PSIM2,-10.)                                                                                            
    4961. 

  4961.        PSIH2=PSIM2                                                                                                        
    4962. 

  4962.                                                                                                                           
    4963. 

  4963.      ! Linear form: PSIM = -0.5*ZA/L; e.g, see eqn 16 of                                                                  
    4964. 

  4964.      ! Blackadar, Modeling the nocturnal boundary layer, Preprints,                                                       
    4965. 

  4965.      ! Third Symposium on Atmospheric Turbulence Diffusion and Air Quality,                                               
    4966. 

  4966.      ! Raleigh, NC, 1976                                                                                                  
    4967. 

  4967.        ZOL = BR*GZ1OZ0/(1.00001-5.0*BR)                                                                                   
    4968. 

  4968.                                                                                                                           
    4969. 

  4969.        IF ( ZOL .GT. 0.5 ) THEN ! linear form ok                                                                          
    4970. 

  4970.         ! Holtslag and de Bruin, J. App. Meteor 27, 689-704, 1988;                                                        
    4971. 

  4971.         ! see also, Launiainen, Boundary-Layer Meteor 76,165-179, 1995                                                    
    4972. 

  4972.         ! Eqn (8) of Launiainen, 1995                                                                                     
    4973. 

  4973.           ZOL = ( 1.89*GZ1OZ0 + 44.2 ) * BR*BR    &                                                                       
    4974. 

  4974.                + ( 1.18*GZ1OZ0 - 1.37 ) * BR                                                                              
    4975. 

  4975.           ZOL=AMIN1(ZOL,9.999)                                                                                            
    4976. 

  4976.        END IF                                                                                                             
    4977. 

  4977.                                                                                                                           
    4978. 

  4978. ! 1.0 over Monin-Obukhov length                                                                                           
    4979. 

  4979.        RMOL= ZOL/ZA                                                                                                       
    4980. 

  4980.                                                                                                                           
    4981. 

  4981.      CASE(3)  ! class 3; forced convection:                                                                               
    4982. 

  4982.        PSIM=0.0                                                                                                           
    4983. 

  4983.        PSIH=PSIM                                                                                                          
    4984. 

  4984.        PSIM10=0.                                                                                                          
    4985. 

  4985.        PSIH10=PSIM10                                                                                                      
    4986. 

  4986.        PSIM2=0.                                                                                                           
    4987. 

  4987.        PSIH2=PSIM2                                                                                                        
    4988. 

  4988.        IF(UST.LT.0.01)THEN                                                                                                
    4989. 

  4989.          ZOL=BR*GZ1OZ0                                                                                                    
    4990. 

  4990.        ELSE                                                                                                               
    4991. 

  4991.          ZOL=KARMAN*GOVRTH*ZA*MOL/(UST*UST)                                                                               
    4992. 

  4992.        ENDIF                                                                                                              
    4993. 

  4993.                                                                                                                           
    4994. 

  4994.        RMOL = ZOL/ZA                                                                                                      
    4995. 

  4995.                                                                                                                           
    4996. 

  4996.      CASE(4) ! class 4; free convection:                                                                                  
    4997. 

  4997.        IF(UST.LT.0.01)THEN                                                                                                
    4998. 

  4998.          ZOL=BR*GZ1OZ0                                                                                                    
    4999. 

  4999.        ELSE                                                                                                               
    5000. 

  5000.          ZOL=KARMAN*GOVRTH*ZA*MOL/(UST*UST)                                                                               
    5001. 

  5001.        ENDIF                                                                                                              
    5002. 

  5002.        ZOL10=10./ZA*ZOL                                                                                                   
    5003. 

  5003.        ZOL2=2./ZA*ZOL                                                                                                     
    5004. 

  5004.        ZOL=AMIN1(ZOL,0.)                                                                                                  
    5005. 

  5005.        ZOL=AMAX1(ZOL,-9.9999)                                                                                             
    5006. 

  5006.        ZOL10=AMIN1(ZOL10,0.)                                                                                              
    5007. 

  5007.        ZOL10=AMAX1(ZOL10,-9.9999)                                                                                         
    5008. 

  5008.        ZOL2=AMIN1(ZOL2,0.)                                                                                                
    5009. 

  5009.        ZOL2=AMAX1(ZOL2,-9.9999)                                                                                           
    5010. 

  5010.        NZOL=INT(-ZOL*100.)                                                                                                
    5011. 

  5011.        RZOL=-ZOL*100.-NZOL                                                                                                
    5012. 

  5012.        NZOL10=INT(-ZOL10*100.)                                                                                            
    5013. 

  5013.        RZOL10=-ZOL10*100.-NZOL10                                                                                          
    5014. 

  5014.        NZOL2=INT(-ZOL2*100.)                                                                                              
    5015. 

  5015.        RZOL2=-ZOL2*100.-NZOL2                                                                                             
    5016. 

  5016.        PSIM=PSIMTB(NZOL)+RZOL*(PSIMTB(NZOL+1)-PSIMTB(NZOL))                                                               
    5017. 

  5017.        PSIH=PSIHTB(NZOL)+RZOL*(PSIHTB(NZOL+1)-PSIHTB(NZOL))                                                               
    5018. 

  5018.        PSIM10=PSIMTB(NZOL10)+RZOL10*(PSIMTB(NZOL10+1)-PSIMTB(NZOL10))                                                     
    5019. 

  5019.        PSIH10=PSIHTB(NZOL10)+RZOL10*(PSIHTB(NZOL10+1)-PSIHTB(NZOL10))                                                     
    5020. 

  5020.        PSIM2=PSIMTB(NZOL2)+RZOL2*(PSIMTB(NZOL2+1)-PSIMTB(NZOL2))                                                          
    5021. 

  5021.        PSIH2=PSIHTB(NZOL2)+RZOL2*(PSIHTB(NZOL2+1)-PSIHTB(NZOL2))                                                          
    5022. 

  5022.                                                                                                                           
    5023. 

  5023. ! limit psih and psim in the case of thin layers and high roughness                                                       
    5024. 

  5024. ! this prevents denominator in fluxes from getting too small                                                              
    5025. 

  5025. !       PSIH=AMIN1(PSIH,0.9*GZ1OZ0)                                                                                       
    5026. 

  5026. !       PSIM=AMIN1(PSIM,0.9*GZ1OZ0)                                                                                       
    5027. 

  5027.        PSIH=AMIN1(PSIH,0.9*GZ1OZ0)                                                                                        
    5028. 

  5028.        PSIM=AMIN1(PSIM,0.9*GZ1OZ0)                                                                                        
    5029. 

  5029.        PSIH2=AMIN1(PSIH2,0.9*GZ2OZ0)                                                                                      
    5030. 

  5030.        PSIM10=AMIN1(PSIM10,0.9*GZ10OZ0)                                                                                   
    5031. 

  5031. ! AHW: mods to compute ck, cd                                                                                             
    5032. 

  5032.        PSIH10=AMIN1(PSIH10,0.9*GZ10OZ0)                                                                                   
    5033. 

  5033.                                                                                                                           
    5034. 

  5034.        RMOL = ZOL/ZA                                                                                                      
    5035. 

  5035.                                                                                                                           
    5036. 

  5036.    END SELECT ! stability regime done                                                                                     
    5037. 

  5037.                                                                                                                           
    5038. 

  5038. ! compute the frictional velocity: ZA(1982) EQS(2.60),(2.61).                                                             
    5039. 

  5039.    DTG=THX-THGB                                                                                                           
    5040. 

  5040.    PSIX=GZ1OZ0-PSIM                                                                                                       
    5041. 

  5041.    PSIX10=GZ10OZ0-PSIM10                                                                                                  
    5042. 

  5042.                                                                                                                           
    5043. 

  5043. ! lower limit added to prevent large flhc in soil model                                                                   
    5044. 

  5044. ! activates in unstable conditions with thin layers or high z0                                                            
    5045. 

  5045.    PSIT=AMAX1(GZ1OZ0-PSIH,2.) !does this still apply???? jref                                                             
    5046. 

  5046.    PSIQ=ALOG(KARMAN*UST*ZA/XKA+ZA/ZL)-PSIH                                                                                
    5047. 

  5047.    PSIT2=GZ2OZ0-PSIH2                                                                                                     
    5048. 

  5048.    PSIQ2=ALOG(KARMAN*UST*2./XKA+2./ZL)-PSIH2                                                                              
    5049. 

  5049. ! AHW: mods to compute ck, cd                                                                                             
    5050. 

  5050.    PSIQ10=ALOG(KARMAN*UST*10./XKA+10./ZL)-PSIH10                                                                          
    5051. 

  5051. 

  5052. !jref:start - commented out since these values can be produced by sfclay routine   
    5053. 

  5053. !   IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN                                           
    5054. 

  5054. !      Ck=(karman/psix10)*(karman/psiq10)                                                                                  
    5055. 

  5055. !      Cd=(karman/psix10)*(karman/psix10)                                                                                  
    5056. 

  5056. !      Cka=(karman/psix)*(karman/psiq)                                                                                     
    5057. 

  5057. !      Cda=(karman/psix)*(karman/psix)                                                                                     
    5058. 

  5058. !   ENDIF                                                                                                                  
    5059. 

  5059. 

  5060. !   WRITE(*,*) "KARMAN=",KARMAN
    5061. 

  5061. !   WRITE(*,*) "UST=",UST
    5062. 

  5062. !   WRITE(*,*) "XKA=",XKA
    5063. 

  5063. !   WRITE(*,*) "ZA =",ZA
    5064. 

  5064. !   WRITE(*,*) "ZL =",ZL
    5065. 

  5065. !   WRITE(*,*) "PSIH=",PSIH
    5066. 

  5066. !   WRITE(*,*) "PSIQ=",PSIQ,"PSIT=",PSIT
    5067. 

  5067. 

  5068.    IF ( PRESENT(IZ0TLND) ) THEN                                                                                           
    5069. 

  5069.       IF ( IZ0TLND.EQ.1 ) THEN                                                                                            
    5070. 

  5070.          ZL=ZNT                                                                                                           
    5071. 

  5071. !       czil related changes for land                                                                                     
    5072. 

  5072.          VISC=(1.32+0.009*(T1D-273.15))*1.E-5                                                                            
    5073. 

  5073.          RESTAR=UST*ZL/VISC                                                                                               
    5074. 

  5074. !       modify CZIL according to Chen & Zhang, 2009                                                                       
    5075. 

  5075.                                                                                                                           
    5076. 

  5076.          CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) )                                                                         
    5077. 

  5077.                                                                                                                           
    5078. 

  5078.          PSIT=GZ1OZ0-PSIH+CZIL*KARMAN*SQRT(RESTAR)                                                                        
    5079. 

  5079.          PSIQ=GZ1OZ0-PSIH+CZIL*KARMAN*SQRT(RESTAR)                                                                        
    5080. 

  5080.          PSIT2=GZ2OZ0-PSIH2+CZIL*KARMAN*SQRT(RESTAR)                                                                      
    5081. 

  5081.          PSIQ2=GZ2OZ0-PSIH2+CZIL*KARMAN*SQRT(RESTAR)                                                                      
    5082. 

  5082.       ENDIF                                                                                                               
    5083. 

  5083.    ENDIF                                                                                                                  
    5084. 

  5084.                                                                                                                           
    5085. 

  5085. 

  5086. ! to prevent oscillations average with old value                                                                          
    5087. 

  5087.    UST=0.5*UST+0.5*KARMAN*WSPD/PSIX                                                                                       
    5088. 

  5088.    UST=AMAX1(UST,0.1)                                                                                                     
    5089. 

  5089. !jref: should this be converted to RMOL???
    5090. 

  5090.    MOL=KARMAN*DTG/PSIT/PRT                                                                                                
    5091. 

  5091.    DENOMQ=PSIQ                                                                                                            
    5092. 

  5092.    DENOMQ2=PSIQ2                                                                                                          
    5093. 

  5093.    DENOMT2=PSIT2                                                                                                          
    5094. 

  5094. !   WRITE(*,*) "ILOC,JLOC=",ILOC,JLOC,"DENOMQ=",DENOMQ
    5095. 

  5095. !   WRITE(*,*) "UST=",UST,"PSIT=",PSIT
    5096. 

  5096. !   call wrf_error_fatal("stop in sfcdif4")
    5097. 

  5097.                                                                                                                           
    5098. 

  5098. ! calculate exchange coefficients                                                                                         
    5099. 

  5099. !jref: start exchange coefficient for momentum
    5100. 

  5100.    CM =KARMAN*KARMAN/(PSIX*PSIX)
    5101. 

  5101. !jref:end
    5102. 

  5102.    CHS=UST*KARMAN/DENOMQ                                                                                                  
    5103. 

  5103. !        GZ2OZ0=ALOG(2./ZNT)                                                                                              
    5104. 

  5104. !        PSIM2=-10.*GZ2OZ0                                                                                                
    5105. 

  5105. !        PSIM2=AMAX1(PSIM2,-10.)                                                                                          
    5106. 

  5106. !        PSIH2=PSIM2                                                                                                      
    5107. 

  5107.    CQS2=UST*KARMAN/DENOMQ2                                                                                                
    5108. 

  5108.    CHS2=UST*KARMAN/DENOMT2                                                                                                
    5109. 

  5109. ! jref: in last iteration calculate diagnostics                                                                           
    5110. 

  5110.                                                                                                                          
    5111. 

  5111.    U10=UX*PSIX10/PSIX                                                                                                     
    5112. 

  5112.    V10=VX*PSIX10/PSIX                                                                                                     
    5113. 

  5113.                                                                                                                           
    5114. 

  5114. ! jref: check the following for correct calculation                                                                       
    5115. 

  5115. !   TH2=THGB+DTG*PSIT2/PSIT                                                                                               
    5116. 

  5116. !   Q2=QSFC+(QX-QSFC)*PSIQ2/PSIQ                                                                                          
    5117. 

  5117. !   T2 = TH2*(PSFCPA/P1000mb)**RCP                                                                                        
    5118. 

  5118.                                                                                                                           
    5119. 

  5119.    END SUBROUTINE SFCDIF4                                                                                                 
    5120. 

  5120. !jref:end
    5121. 

  5121. !  ==================================================================================================
    5122. 

  5122.   SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI)
    5123. 

  5123. !---------------------------------------------------------------------------------------------------
    5124. 

  5124. ! use polynomials to calculate saturation vapor pressure and derivative with
    5125. 

  5125. ! respect to temperature: over water when t > 0 c and over ice when t <= 0 c
    5126. 

  5126.   IMPLICIT NONE
    5127. 

  5127. !---------------------------------------------------------------------------------------------------
    5128. 

  5128. ! in
    5129. 

  5129. 

  5130.   REAL, intent(in)  :: T              !temperature
    5131. 

  5131. 

  5132. !out
    5133. 

  5133. 

  5134.   REAL, intent(out) :: ESW            !saturation vapor pressure over water (pa)
    5135. 

  5135.   REAL, intent(out) :: ESI            !saturation vapor pressure over ice (pa)
    5136. 

  5136.   REAL, intent(out) :: DESW           !d(esat)/dt over water (pa/K)
    5137. 

  5137.   REAL, intent(out) :: DESI           !d(esat)/dt over ice (pa/K)
    5138. 

  5138. 

  5139. ! local
    5140. 

  5140. 

  5141.   REAL :: A0,A1,A2,A3,A4,A5,A6  !coefficients for esat over water
    5142. 

  5142.   REAL :: B0,B1,B2,B3,B4,B5,B6  !coefficients for esat over ice
    5143. 

  5143.   REAL :: C0,C1,C2,C3,C4,C5,C6  !coefficients for dsat over water
    5144. 

  5144.   REAL :: D0,D1,D2,D3,D4,D5,D6  !coefficients for dsat over ice
    5145. 

  5145. 

  5146.   PARAMETER (A0=6.107799961    , A1=4.436518521E-01,  &
    5147. 

  5147.              A2=1.428945805E-02, A3=2.650648471E-04,  &
    5148. 

  5148.              A4=3.031240396E-06, A5=2.034080948E-08,  &
    5149. 

  5149.              A6=6.136820929E-11)
    5150. 

  5150. 

  5151.   PARAMETER (B0=6.109177956    , B1=5.034698970E-01,  &
    5152. 

  5152.              B2=1.886013408E-02, B3=4.176223716E-04,  &
    5153. 

  5153.              B4=5.824720280E-06, B5=4.838803174E-08,  &
    5154. 

  5154.              B6=1.838826904E-10)
    5155. 

  5155. 

  5156.   PARAMETER (C0= 4.438099984E-01, C1=2.857002636E-02,  &
    5157. 

  5157.              C2= 7.938054040E-04, C3=1.215215065E-05,  &
    5158. 

  5158.              C4= 1.036561403E-07, C5=3.532421810e-10,  &
    5159. 

  5159.              C6=-7.090244804E-13)
    5160. 

  5160. 

  5161.   PARAMETER (D0=5.030305237E-01, D1=3.773255020E-02,  &
    5162. 

  5162.              D2=1.267995369E-03, D3=2.477563108E-05,  &
    5163. 

  5163.              D4=3.005693132E-07, D5=2.158542548E-09,  &
    5164. 

  5164.              D6=7.131097725E-12)
    5165. 

  5165. 

  5166.   ESW  = 100.*(A0+T*(A1+T*(A2+T*(A3+T*(A4+T*(A5+T*A6))))))
    5167. 

  5167.   ESI  = 100.*(B0+T*(B1+T*(B2+T*(B3+T*(B4+T*(B5+T*B6))))))
    5168. 

  5168.   DESW = 100.*(C0+T*(C1+T*(C2+T*(C3+T*(C4+T*(C5+T*C6))))))
    5169. 

  5169.   DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6))))))
    5170. 

  5170. 

  5171.   END SUBROUTINE ESAT
    5172. 

  5172. ! ==================================================================================================
    5173. 

  5173. ! ----------------------------------------------------------------------
    5174. 

  5174.   SUBROUTINE STOMATA (VEGTYP  ,MPE     ,APAR    ,FOLN    ,ILOC    , JLOC, & !in
    5175. 

  5175.                       TV      ,EI      ,EA      ,SFCTMP  ,SFCPRS  , & !in
    5176. 

  5176.                       O2      ,CO2     ,IGS     ,BTRAN   ,RB      , & !in
    5177. 

  5177.                       RS      ,PSN     )                              !out
    5178. 

  5178. ! --------------------------------------------------------------------------------------------------
    5179. 

  5179.   USE NOAHMP_VEG_PARAMETERS
    5180. 

  5180. ! --------------------------------------------------------------------------------------------------
    5181. 

  5181.   IMPLICIT NONE
    5182. 

  5182. ! --------------------------------------------------------------------------------------------------
    5183. 

  5183. ! input
    5184. 

  5184.       INTEGER,INTENT(IN)  :: ILOC   !grid index
    5185. 

  5185.       INTEGER,INTENT(IN)  :: JLOC   !grid index
    5186. 

  5186.       INTEGER,INTENT(IN)  :: VEGTYP !vegetation physiology type
    5187. 

  5187. 

  5188.       REAL, INTENT(IN)    :: IGS    !growing season index (0=off, 1=on)
    5189. 

  5189.       REAL, INTENT(IN)    :: MPE    !prevents division by zero errors
    5190. 

  5190. 

  5191.       REAL, INTENT(IN)    :: TV     !foliage temperature (k)
    5192. 

  5192.       REAL, INTENT(IN)    :: EI     !vapor pressure inside leaf (sat vapor press at tv) (pa)
    5193. 

  5193.       REAL, INTENT(IN)    :: EA     !vapor pressure of canopy air (pa)
    5194. 

  5194.       REAL, INTENT(IN)    :: APAR   !par absorbed per unit lai (w/m2)
    5195. 

  5195.       REAL, INTENT(IN)    :: O2     !atmospheric o2 concentration (pa)
    5196. 

  5196.       REAL, INTENT(IN)    :: CO2    !atmospheric co2 concentration (pa)
    5197. 

  5197.       REAL, INTENT(IN)    :: SFCPRS !air pressure at reference height (pa)
    5198. 

  5198.       REAL, INTENT(IN)    :: SFCTMP !air temperature at reference height (k)
    5199. 

  5199.       REAL, INTENT(IN)    :: BTRAN  !soil water transpiration factor (0 to 1)
    5200. 

  5200.       REAL, INTENT(IN)    :: FOLN   !foliage nitrogen concentration (%)
    5201. 

  5201.       REAL, INTENT(IN)    :: RB     !boundary layer resistance (s/m)
    5202. 

  5202. 

  5203. ! output
    5204. 

  5204.       REAL, INTENT(OUT)   :: RS     !leaf stomatal resistance (s/m)
    5205. 

  5205.       REAL, INTENT(OUT)   :: PSN    !foliage photosynthesis (umol co2 /m2/ s) [always +]
    5206. 

  5206. 

  5207. ! in&out
    5208. 

  5208.       REAL                :: RLB    !boundary layer resistance (s m2 / umol)
    5209. 

  5209. ! ---------------------------------------------------------------------------------------------
    5210. 

  5210. 

  5211. ! ------------------------ local variables ----------------------------------------------------
    5212. 

  5212.       INTEGER :: ITER     !iteration index
    5213. 

  5213.       INTEGER :: NITER    !number of iterations
    5214. 

  5214. 

  5215.       DATA NITER /3/
    5216. 

  5216.       SAVE NITER
    5217. 

  5217. 

  5218.       REAL :: AB          !used in statement functions
    5219. 

  5219.       REAL :: BC          !used in statement functions
    5220. 

  5220.       REAL :: F1          !generic temperature response (statement function)
    5221. 

  5221.       REAL :: F2          !generic temperature inhibition (statement function)
    5222. 

  5222.       REAL :: TC          !foliage temperature (degree Celsius)
    5223. 

  5223.       REAL :: CS          !co2 concentration at leaf surface (pa)
    5224. 

  5224.       REAL :: KC          !co2 Michaelis-Menten constant (pa)
    5225. 

  5225.       REAL :: KO          !o2 Michaelis-Menten constant (pa)
    5226. 

  5226.       REAL :: A,B,C,Q     !intermediate calculations for RS
    5227. 

  5227.       REAL :: R1,R2       !roots for RS
    5228. 

  5228.       REAL :: FNF         !foliage nitrogen adjustment factor (0 to 1)
    5229. 

  5229.       REAL :: PPF         !absorb photosynthetic photon flux (umol photons/m2/s)
    5230. 

  5230.       REAL :: WC          !Rubisco limited photosynthesis (umol co2/m2/s)
    5231. 

  5231.       REAL :: WJ          !light limited photosynthesis (umol co2/m2/s)
    5232. 

  5232.       REAL :: WE          !export limited photosynthesis (umol co2/m2/s)
    5233. 

  5233.       REAL :: CP          !co2 compensation point (pa)
    5234. 

  5234.       REAL :: CI          !internal co2 (pa)
    5235. 

  5235.       REAL :: AWC         !intermediate calculation for wc
    5236. 

  5236.       REAL :: VCMX        !maximum rate of carbonylation (umol co2/m2/s)
    5237. 

  5237.       REAL :: J           !electron transport (umol co2/m2/s)
    5238. 

  5238.       REAL :: CEA         !constrain ea or else model blows up
    5239. 

  5239.       REAL :: CF          !s m2/umol -> s/m
    5240. 

  5240. 

  5241.       F1(AB,BC) = AB**((BC-25.)/10.)
    5242. 

  5242.       F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16)))
    5243. 

  5243.       REAL :: T
    5244. 

  5244. ! ---------------------------------------------------------------------------------------------
    5245. 

  5245. 

  5246. ! initialize RS=RSMAX and PSN=0 because will only do calculations
    5247. 

  5247. ! for APAR > 0, in which case RS <= RSMAX and PSN >= 0
    5248. 

  5248. 

  5249.          CF = SFCPRS/(8.314*SFCTMP)*1.e06
    5250. 

  5250.          RS = 1./BP(VEGTYP) * CF
    5251. 

  5251.          PSN = 0.
    5252. 

  5252. 

  5253.          IF (APAR .LE. 0.) RETURN
    5254. 

  5254. 

  5255.          FNF = MIN( FOLN/MAX(MPE,FOLNMX(VEGTYP)), 1.0 )
    5256. 

  5256.          TC  = TV-TFRZ
    5257. 

  5257.          PPF = 4.6*APAR
    5258. 

  5258.          J   = PPF*QE25(VEGTYP)
    5259. 

  5259.          KC  = KC25(VEGTYP) * F1(AKC(VEGTYP),TC)
    5260. 

  5260.          KO  = KO25(VEGTYP) * F1(AKO(VEGTYP),TC)
    5261. 

  5261.          AWC = KC * (1.+O2/KO)
    5262. 

  5262.          CP  = 0.5*KC/KO*O2*0.21
    5263. 

  5263.          VCMX = VCMX25(VEGTYP) / F2(TC) * FNF * BTRAN * F1(AVCMX(VEGTYP),TC)
    5264. 

  5264. 

  5265. ! first guess ci
    5266. 

  5266. 

  5267.          CI = 0.7*CO2*C3PSN(VEGTYP) + 0.4*CO2*(1.-C3PSN(VEGTYP))
    5268. 

  5268. 

  5269. ! rb: s/m -> s m**2 / umol
    5270. 

  5270. 

  5271.          RLB = RB/CF
    5272. 

  5272. 

  5273. ! constrain ea
    5274. 

  5274. 

  5275.          CEA = MAX(0.25*EI*C3PSN(VEGTYP)+0.40*EI*(1.-C3PSN(VEGTYP)), MIN(EA,EI) )
    5276. 

  5276. 

  5277. ! ci iteration
    5278. 

  5278. !jref: C3PSN is equal to 1 for all veg types.
    5279. 

  5279.        DO ITER = 1, NITER
    5280. 

  5280.             WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*C3PSN(VEGTYP)  + J*(1.-C3PSN(VEGTYP))
    5281. 

  5281.             WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*C3PSN(VEGTYP) + VCMX*(1.-C3PSN(VEGTYP))
    5282. 

  5282.             WE = 0.5*VCMX*C3PSN(VEGTYP) + 4000.*VCMX*CI/SFCPRS*(1.-C3PSN(VEGTYP))
    5283. 

  5283.             PSN = MIN(WJ,WC,WE) * IGS
    5284. 

  5284. 

  5285.             CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE )
    5286. 

  5286.             A = MP(VEGTYP)*PSN*SFCPRS*CEA / (CS*EI) + BP(VEGTYP)
    5287. 

  5287.             B = ( MP(VEGTYP)*PSN*SFCPRS/CS + BP(VEGTYP) ) * RLB - 1.
    5288. 

  5288.             C = -RLB
    5289. 

  5289.             IF (B .GE. 0.) THEN
    5290. 

  5290.                Q = -0.5*( B + SQRT(B*B-4.*A*C) )
    5291. 

  5291.             ELSE
    5292. 

  5292.                Q = -0.5*( B - SQRT(B*B-4.*A*C) )
    5293. 

  5293.             END IF
    5294. 

  5294.             R1 = Q/A
    5295. 

  5295.             R2 = C/Q
    5296. 

  5296.             RS = MAX(R1,R2)
    5297. 

  5297.             CI = MAX( CS-PSN*SFCPRS*1.65*RS, 0. )
    5298. 

  5298.        END DO 
    5299. 

  5299. 

  5300. ! rs, rb:  s m**2 / umol -> s/m
    5301. 

  5301. 

  5302.          RS = RS*CF
    5303. 

  5303. 

  5304.   END SUBROUTINE STOMATA
    5305. 

  5305. ! ==================================================================================================
    5306. 

  5306.   SUBROUTINE CANRES (PAR   ,SFCTMP,RCSOIL ,EAH   ,SFCPRS , & !in
    5307. 

  5307.                      RC    ,PSN   ,ILOC   ,JLOC  )           !out
    5308. 

  5308. 

  5309. ! --------------------------------------------------------------------------------------------------
    5310. 

  5310. ! calculate canopy resistance which depends on incoming solar radiation,
    5311. 

  5311. ! air temperature, atmospheric water vapor pressure deficit at the
    5312. 

  5312. ! lowest model level, and soil moisture (preferably unfrozen soil
    5313. 

  5313. ! moisture rather than total)
    5314. 

  5314. ! --------------------------------------------------------------------------------------------------
    5315. 

  5315. ! source:  Jarvis (1976), Noilhan and Planton (1989, MWR), Jacquemin and
    5316. 

  5316. ! Noilhan (1990, BLM). Chen et al (1996, JGR, Vol 101(D3), 7251-7268), 
    5317. 

  5317. ! eqns 12-14 and table 2 of sec. 3.1.2
    5318. 

  5318. ! --------------------------------------------------------------------------------------------------
    5319. 

  5319. !niu    USE module_Noahlsm_utility
    5320. 

  5320. ! --------------------------------------------------------------------------------------------------
    5321. 

  5321.     IMPLICIT NONE
    5322. 

  5322. ! --------------------------------------------------------------------------------------------------
    5323. 

  5323. ! inputs
    5324. 

  5324. 

  5325.     INTEGER,                  INTENT(IN)  :: ILOC   !grid index
    5326. 

  5326.     INTEGER,                  INTENT(IN)  :: JLOC   !grid index
    5327. 

  5327.     REAL,                     INTENT(IN)  :: PAR    !par absorbed per unit sunlit lai (w/m2)
    5328. 

  5328.     REAL,                     INTENT(IN)  :: SFCTMP !canopy air temperature
    5329. 

  5329.     REAL,                     INTENT(IN)  :: SFCPRS !surface pressure (pa)
    5330. 

  5330.     REAL,                     INTENT(IN)  :: EAH    !water vapor pressure (pa)
    5331. 

  5331.     REAL,                     INTENT(IN)  :: RCSOIL !soil moisture stress factor
    5332. 

  5332. 

  5333. !outputs
    5334. 

  5334. 

  5335.     REAL,                     INTENT(OUT) :: RC     !canopy resistance per unit LAI
    5336. 

  5336.     REAL,                     INTENT(OUT) :: PSN    !foliage photosynthesis (umolco2/m2/s)
    5337. 

  5337. 

  5338. !local
    5339. 

  5339. 

  5340.     REAL                                  :: RCQ
    5341. 

  5341.     REAL                                  :: RCS
    5342. 

  5342.     REAL                                  :: RCT
    5343. 

  5343.     REAL                                  :: FF
    5344. 

  5344.     REAL                                  :: Q2     !water vapor mixing ratio (kg/kg)
    5345. 

  5345.     REAL                                  :: Q2SAT  !saturation Q2
    5346. 

  5346.     REAL                                  :: DQSDT2 !d(Q2SAT)/d(T)
    5347. 

  5347. 

  5348. ! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM
    5349. 

  5349. ! ----------------------------------------------------------------------
    5350. 

  5350. ! initialize canopy resistance multiplier terms.
    5351. 

  5351. ! ----------------------------------------------------------------------
    5352. 

  5352.     RC     = 0.0
    5353. 

  5353.     RCS    = 0.0
    5354. 

  5354.     RCT    = 0.0
    5355. 

  5355.     RCQ    = 0.0
    5356. 

  5356. 

  5357. !  compute Q2 and Q2SAT
    5358. 

  5358. 

  5359.     Q2 = 0.622 *  EAH  / (SFCPRS - 0.378 * EAH) !specific humidity [kg/kg]
    5360. 

  5360.     Q2 = Q2 / (1.0 + Q2)                        !mixing ratio [kg/kg]
    5361. 

  5361. 

  5362.     CALL CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2)
    5363. 

  5363. 

  5364. ! contribution due to incoming solar radiation
    5365. 

  5365. 

  5366.     FF  = 2.0 * PAR / RGL                
    5367. 

  5367.     RCS = (FF + RSMIN / RSMAX) / (1.0+ FF)
    5368. 

  5368.     RCS = MAX (RCS,0.0001)
    5369. 

  5369. 

  5370. ! contribution due to air temperature
    5371. 

  5371. 

  5372.     RCT = 1.0- 0.0016* ( (TOPT - SFCTMP)**2.0)
    5373. 

  5373.     RCT = MAX (RCT,0.0001)
    5374. 

  5374. 

  5375. ! contribution due to vapor pressure deficit
    5376. 

  5376. 

  5377.     RCQ = 1.0/ (1.0+ HS * MAX(0.,Q2SAT-Q2))
    5378. 

  5378.     RCQ = MAX (RCQ,0.01)
    5379. 

  5379. 

  5380. ! determine canopy resistance due to all factors
    5381. 

  5381. 

  5382.     RC  = RSMIN / (RCS * RCT * RCQ * RCSOIL)
    5383. 

  5383.     PSN = -999.99       ! PSN not applied for dynamic carbon
    5384. 

  5384. 

  5385.   END SUBROUTINE CANRES
    5386. 

  5386. ! ==================================================================================================
    5387. 

  5387.         SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2)
    5388. 

  5388. 

  5389.         IMPLICIT NONE
    5390. 

  5390. 

  5391.         REAL, INTENT(IN)       :: SFCTMP, SFCPRS
    5392. 

  5392.         REAL, INTENT(OUT)      :: Q2SAT, DQSDT2
    5393. 

  5393.         REAL, PARAMETER        :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6,         &
    5394. 

  5394.                                   A23M4=A2*(A3-A4), E0=0.611, RV=461.0,             &
    5395. 

  5395.                                   EPSILON=0.622
    5396. 

  5396.         REAL                   :: ES, SFCPRSX
    5397. 

  5397. 

  5398. ! Q2SAT: saturated mixing ratio
    5399. 

  5399.         ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) )
    5400. 

  5400. ! convert SFCPRS from Pa to KPa
    5401. 

  5401.         SFCPRSX = SFCPRS*1.E-3
    5402. 

  5402.         Q2SAT = EPSILON * ES / (SFCPRSX-ES)
    5403. 

  5403. ! convert from  g/g to g/kg
    5404. 

  5404.         Q2SAT = Q2SAT * 1.E3
    5405. 

  5405. ! Q2SAT is currently a 'mixing ratio'
    5406. 

  5406. 

  5407. ! DQSDT2 is calculated assuming Q2SAT is a specific humidity
    5408. 

  5408.         DQSDT2=(Q2SAT/(1+Q2SAT))*A23M4/(SFCTMP-A4)**2
    5409. 

  5409. 

  5410. ! DG Q2SAT needs to be in g/g when returned for SFLX
    5411. 

  5411.         Q2SAT = Q2SAT / 1.E3
    5412. 

  5412. 

  5413.         END SUBROUTINE CALHUM
    5414. 

  5414. ! ==================================================================================================
    5415. 

  5415.   SUBROUTINE TSNOSOI (ICE     ,NSOIL   ,NSNOW   ,ISNOW   ,IST     , & !in
    5416. 

  5416.                       TBOT    ,ZSNSO   ,SSOIL   ,DF      ,HCPCT   , & !in
    5417. 

  5417.                       ZBOT    ,SAG     ,DT      ,SNOWH   ,DZSNSO  , & !in
    5418. 

  5418.                       TG      ,ILOC    ,JLOC    ,                   & !in
    5419. 

  5419.                       STC     )                                       !inout
    5420. 

  5420. ! --------------------------------------------------------------------------------------------------
    5421. 

  5421. ! Compute snow (up to 3L) and soil (4L) temperature. Note that snow temperatures
    5422. 

  5422. ! during melting season may exceed melting point (TFRZ) but later in PHASECHANGE
    5423. 

  5423. ! subroutine the snow temperatures are reset to TFRZ for melting snow.
    5424. 

  5424. ! --------------------------------------------------------------------------------------------------
    5425. 

  5425.   IMPLICIT NONE
    5426. 

  5426. ! --------------------------------------------------------------------------------------------------
    5427. 

  5427. !input
    5428. 

  5428. 

  5429.     INTEGER,                         INTENT(IN)  :: ILOC
    5430. 

  5430.     INTEGER,                         INTENT(IN)  :: JLOC
    5431. 

  5431.     INTEGER,                         INTENT(IN)  :: ICE    !
    5432. 

  5432.     INTEGER,                         INTENT(IN)  :: NSOIL  !no of soil layers (4)
    5433. 

  5433.     INTEGER,                         INTENT(IN)  :: NSNOW  !maximum no of snow layers (3)
    5434. 

  5434.     INTEGER,                         INTENT(IN)  :: ISNOW  !actual no of snow layers
    5435. 

  5435.     INTEGER,                         INTENT(IN)  :: IST    !surface type
    5436. 

  5436. 

  5437.     REAL,                            INTENT(IN)  :: DT     !time step (s)
    5438. 

  5438.     REAL,                            INTENT(IN)  :: TBOT   !
    5439. 

  5439.     REAL,                            INTENT(IN)  :: SSOIL  !ground heat flux (w/m2)
    5440. 

  5440.     REAL,                            INTENT(IN)  :: SAG    !solar rad. absorbed by ground (w/m2)
    5441. 

  5441.     REAL,                            INTENT(IN)  :: SNOWH  !snow depth (m)
    5442. 

  5442.     REAL,                            INTENT(IN)  :: ZBOT   !from soil surface (m)
    5443. 

  5443.     REAL,                            INTENT(IN)  :: TG     !ground temperature (k)
    5444. 

  5444.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: ZSNSO  !layer-bot. depth from snow surf.(m)
    5445. 

  5445.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: DZSNSO !snow/soil layer thickness (m)
    5446. 

  5446.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: DF     !thermal conductivity
    5447. 

  5447.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: HCPCT  !heat capacity (J/m3/k)
    5448. 

  5448. 

  5449. !input and output
    5450. 

  5450. 

  5451.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
    5452. 

  5452. 

  5453. !local
    5454. 

  5454. 

  5455.     INTEGER                                      :: IZ
    5456. 

  5456.     REAL                                         :: ZBOTSNO   !ZBOT from snow surface
    5457. 

  5457.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: AI, BI, CI, RHSTS
    5458. 

  5458.     REAL                                         :: EFLXB !energy influx from soil bottom (w/m2)
    5459. 

  5459.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: PHI   !light through water (w/m2)
    5460. 

  5460. 

  5461.     REAL, DIMENSION(-NSNOW+1:NSOIL) :: TBEG
    5462. 

  5462.     REAL                            :: ERR_EST !heat storage error  (w/m2)
    5463. 

  5463.     REAL                            :: SSOIL2  !ground heat flux (w/m2) (for energy check)
    5464. 

  5464.     REAL                            :: EFLXB2  !heat flux from the bottom (w/m2) (for energy check)
    5465. 

  5465.     character(len=256)              :: message
    5466. 

  5466. ! ----------------------------------------------------------------------
    5467. 

  5467. ! compute solar penetration through water, needs more work
    5468. 

  5468. 

  5469.     PHI(ISNOW+1:NSOIL) = 0.
    5470. 

  5470. 

  5471. ! adjust ZBOT from soil surface to ZBOTSNO from snow surface
    5472. 

  5472. 

  5473.     ZBOTSNO = ZBOT - SNOWH    !from snow surface
    5474. 

  5474. 

  5475. ! snow/soil heat storage for energy balance check
    5476. 

  5476. 

  5477.     DO IZ = ISNOW+1, NSOIL
    5478. 

  5478.        TBEG(IZ) = STC(IZ)
    5479. 

  5479.     ENDDO
    5480. 

  5480. 

  5481. ! compute soil temperatures
    5482. 

  5482. 

  5483.       CALL HRT   (NSNOW     ,NSOIL     ,ISNOW     ,ZSNSO     , &
    5484. 

  5484.                   STC       ,TBOT      ,ZBOTSNO   ,DT        , &
    5485. 

  5485.                   DF        ,HCPCT     ,SSOIL     ,PHI       , &
    5486. 

  5486.                   AI        ,BI        ,CI        ,RHSTS     , &
    5487. 

  5487.                   EFLXB     )
    5488. 

  5488. 

  5489.       CALL HSTEP (NSNOW     ,NSOIL     ,ISNOW     ,DT        , &
    5490. 

  5490.                   AI        ,BI        ,CI        ,RHSTS     , &
    5491. 

  5491.                   STC       ) 
    5492. 

  5492. 

  5493. ! update ground heat flux just for energy check, but not for final output
    5494. 

  5494. ! otherwise, it would break the surface energy balance
    5495. 

  5495. 

  5496.     IF(OPT_TBOT == 1) THEN
    5497. 

  5497.        EFLXB2  = 0.
    5498. 

  5498.     ELSE IF(OPT_TBOT == 2) THEN
    5499. 

  5499.        EFLXB2  = DF(NSOIL)*(TBOT-STC(NSOIL)) / &
    5500. 

  5500.             (0.5*(ZSNSO(NSOIL-1)+ZSNSO(NSOIL)) - ZBOTSNO)
    5501. 

  5501.     END IF
    5502. 

  5502. 

  5503.     ! Skip the energy balance check for now, until we can make it work
    5504. 

  5504.     ! right for small time steps.
    5505. 

  5505.     return
    5506. 

  5506. 

  5507. ! energy balance check
    5508. 

  5508. 

  5509.     ERR_EST = 0.0
    5510. 

  5510.     DO IZ = ISNOW+1, NSOIL
    5511. 

  5511.        ERR_EST = ERR_EST + (STC(IZ)-TBEG(IZ)) * DZSNSO(IZ) * HCPCT(IZ) / DT
    5512. 

  5512.     ENDDO
    5513. 

  5513. 

  5514.     if (OPT_STC == 1) THEN   ! semi-implicit
    5515. 

  5515.        ERR_EST = ERR_EST - (SSOIL +EFLXB)
    5516. 

  5516.     ELSE                     ! full-implicit
    5517. 

  5517.        SSOIL2 = DF(ISNOW+1)*(TG-STC(ISNOW+1))/(0.5*DZSNSO(ISNOW+1))   !M. Barlage
    5518. 

  5518.        ERR_EST = ERR_EST - (SSOIL2+EFLXB2)
    5519. 

  5519.     ENDIF
    5520. 

  5520. 

  5521.     IF (ABS(ERR_EST) > 1.) THEN    ! W/m2
    5522. 

  5522.        WRITE(message,*) 'TSNOSOI is losing(-)/gaining(+) false energy',ERR_EST,' W/m2'
    5523. 

  5523.        call wrf_message(trim(message))
    5524. 

  5524.        WRITE(message,'(i6,1x,i6,1x,i3,F18.13,5F20.12)') &
    5525. 

  5525.             ILOC, JLOC, IST,ERR_EST,SSOIL,SNOWH,TG,STC(ISNOW+1),EFLXB
    5526. 

  5526.        call wrf_message(trim(message))
    5527. 

  5527.        !niu      STOP
    5528. 

  5528.     END IF
    5529. 

  5529. 

  5530.   END SUBROUTINE TSNOSOI
    5531. 

  5531. ! ==================================================================================================
    5532. 

  5532. ! ----------------------------------------------------------------------
    5533. 

  5533.   SUBROUTINE HRT (NSNOW     ,NSOIL     ,ISNOW     ,ZSNSO     , &
    5534. 

  5534.                   STC       ,TBOT      ,ZBOT      ,DT        , &
    5535. 

  5535.                   DF        ,HCPCT     ,SSOIL     ,PHI       , &
    5536. 

  5536.                   AI        ,BI        ,CI        ,RHSTS     , &
    5537. 

  5537.                   BOTFLX    )
    5538. 

  5538. ! ----------------------------------------------------------------------
    5539. 

  5539. ! ----------------------------------------------------------------------
    5540. 

  5540. ! calculate the right hand side of the time tendency term of the soil
    5541. 

  5541. ! thermal diffusion equation.  also to compute ( prepare ) the matrix
    5542. 

  5542. ! coefficients for the tri-diagonal matrix of the implicit time scheme.
    5543. 

  5543. ! ----------------------------------------------------------------------
    5544. 

  5544.     IMPLICIT NONE
    5545. 

  5545. ! ----------------------------------------------------------------------
    5546. 

  5546. ! input
    5547. 

  5547. 

  5548.     INTEGER,                         INTENT(IN)  :: NSOIL  !no of soil layers (4)
    5549. 

  5549.     INTEGER,                         INTENT(IN)  :: NSNOW  !maximum no of snow layers (3)
    5550. 

  5550.     INTEGER,                         INTENT(IN)  :: ISNOW  !actual no of snow layers
    5551. 

  5551.     REAL,                            INTENT(IN)  :: TBOT   !bottom soil temp. at ZBOT (k)
    5552. 

  5552.     REAL,                            INTENT(IN)  :: ZBOT   !depth of lower boundary condition (m)
    5553. 

  5553.                                                            !from soil surface not snow surface
    5554. 

  5554.     REAL,                            INTENT(IN)  :: DT     !time step (s)
    5555. 

  5555.     REAL,                            INTENT(IN)  :: SSOIL  !ground heat flux (w/m2)
    5556. 

  5556.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: ZSNSO  !depth of layer-bottom of snow/soil (m)
    5557. 

  5557.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: STC    !snow/soil temperature (k)
    5558. 

  5558.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: DF     !thermal conductivity [w/m/k]
    5559. 

  5559.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: HCPCT  !heat capacity [j/m3/k]
    5560. 

  5560.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)  :: PHI    !light through water (w/m2)
    5561. 

  5561. 

  5562. ! output
    5563. 

  5563. 

  5564.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: RHSTS  !right-hand side of the matrix
    5565. 

  5565.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: AI     !left-hand side coefficient
    5566. 

  5566.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: BI     !left-hand side coefficient
    5567. 

  5567.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: CI     !left-hand side coefficient
    5568. 

  5568.     REAL,                            INTENT(OUT) :: BOTFLX !energy influx from soil bottom (w/m2)
    5569. 

  5569. 

  5570. ! local
    5571. 

  5571. 

  5572.     INTEGER                                      :: K
    5573. 

  5573.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: DDZ
    5574. 

  5574.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: DZ
    5575. 

  5575.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: DENOM
    5576. 

  5576.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: DTSDZ
    5577. 

  5577.     REAL, DIMENSION(-NSNOW+1:NSOIL)              :: EFLUX
    5578. 

  5578.     REAL                                         :: TEMP1
    5579. 

  5579. ! ----------------------------------------------------------------------
    5580. 

  5580. 

  5581.     DO K = ISNOW+1, NSOIL
    5582. 

  5582.         IF (K == ISNOW+1) THEN
    5583. 

  5583.            DENOM(K)  = - ZSNSO(K) * HCPCT(K)
    5584. 

  5584.            TEMP1     = - ZSNSO(K+1)
    5585. 

  5585.            DDZ(K)    = 2.0 / TEMP1
    5586. 

  5586.            DTSDZ(K)  = 2.0 * (STC(K) - STC(K+1)) / TEMP1
    5587. 

  5587.            EFLUX(K)  = DF(K) * DTSDZ(K) - SSOIL - PHI(K)
    5588. 

  5588.         ELSE IF (K < NSOIL) THEN
    5589. 

  5589.            DENOM(K)  = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K)
    5590. 

  5590.            TEMP1     = ZSNSO(K-1) - ZSNSO(K+1)
    5591. 

  5591.            DDZ(K)    = 2.0 / TEMP1
    5592. 

  5592.            DTSDZ(K)  = 2.0 * (STC(K) - STC(K+1)) / TEMP1
    5593. 

  5593.            EFLUX(K)  = (DF(K)*DTSDZ(K) - DF(K-1)*DTSDZ(K-1)) - PHI(K)
    5594. 

  5594.         ELSE IF (K == NSOIL) THEN
    5595. 

  5595.            DENOM(K)  = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K)
    5596. 

  5596.            TEMP1     =  ZSNSO(K-1) - ZSNSO(K)
    5597. 

  5597.            IF(OPT_TBOT == 1) THEN
    5598. 

  5598.                BOTFLX     = 0. 
    5599. 

  5599.            END IF
    5600. 

  5600.            IF(OPT_TBOT == 2) THEN
    5601. 

  5601.                DTSDZ(K)  = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT)
    5602. 

  5602.                BOTFLX    = -DF(K) * DTSDZ(K)
    5603. 

  5603.            END IF
    5604. 

  5604.            EFLUX(K)  = (-BOTFLX - DF(K-1)*DTSDZ(K-1) ) - PHI(K)
    5605. 

  5605.         END IF
    5606. 

  5606.     END DO
    5607. 

  5607. 

  5608.     DO K = ISNOW+1, NSOIL
    5609. 

  5609.         IF (K == ISNOW+1) THEN
    5610. 

  5610.            AI(K)    =   0.0
    5611. 

  5611.            CI(K)    = - DF(K)   * DDZ(K) / DENOM(K)
    5612. 

  5612.            IF (OPT_STC == 1) THEN
    5613. 

  5613.               BI(K) = - CI(K)
    5614. 

  5614.            END IF                                        
    5615. 

  5615.            IF (OPT_STC == 2) THEN
    5616. 

  5616.               BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K))
    5617. 

  5617.            END IF
    5618. 

  5618.         ELSE IF (K < NSOIL) THEN
    5619. 

  5619.            AI(K)    = - DF(K-1) * DDZ(K-1) / DENOM(K) 
    5620. 

  5620.            CI(K)    = - DF(K  ) * DDZ(K  ) / DENOM(K) 
    5621. 

  5621.            BI(K)    = - (AI(K) + CI (K))
    5622. 

  5622.         ELSE IF (K == NSOIL) THEN
    5623. 

  5623.            AI(K)    = - DF(K-1) * DDZ(K-1) / DENOM(K) 
    5624. 

  5624.            CI(K)    = 0.0
    5625. 

  5625.            BI(K)    = - (AI(K) + CI(K))
    5626. 

  5626.         END IF
    5627. 

  5627.            RHSTS(K)  = EFLUX(K)/ (-DENOM(K))
    5628. 

  5628.     END DO
    5629. 

  5629. 

  5630.   END SUBROUTINE HRT
    5631. 

  5631. ! ==================================================================================================
    5632. 

  5632. ! ----------------------------------------------------------------------
    5633. 

  5633.   SUBROUTINE HSTEP (NSNOW     ,NSOIL     ,ISNOW     ,DT        ,  &
    5634. 

  5634.                     AI        ,BI        ,CI        ,RHSTS     ,  &
    5635. 

  5635.                     STC       )  
    5636. 

  5636. ! ----------------------------------------------------------------------
    5637. 

  5637. ! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD.
    5638. 

  5638. ! ----------------------------------------------------------------------
    5639. 

  5639.     implicit none
    5640. 

  5640. ! ----------------------------------------------------------------------
    5641. 

  5641. ! input
    5642. 

  5642. 

  5643.     INTEGER,                         INTENT(IN)    :: NSOIL
    5644. 

  5644.     INTEGER,                         INTENT(IN)    :: NSNOW
    5645. 

  5645.     INTEGER,                         INTENT(IN)    :: ISNOW
    5646. 

  5646.     REAL,                            INTENT(IN)    :: DT
    5647. 

  5647. 

  5648. ! output & input
    5649. 

  5649.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: RHSTS
    5650. 

  5650.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: AI
    5651. 

  5651.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: BI
    5652. 

  5652.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: CI
    5653. 

  5653.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
    5654. 

  5654. 

  5655. ! local
    5656. 

  5656.     INTEGER                                        :: K
    5657. 

  5657.     REAL, DIMENSION(-NSNOW+1:NSOIL)                :: RHSTSIN
    5658. 

  5658.     REAL, DIMENSION(-NSNOW+1:NSOIL)                :: CIIN
    5659. 

  5659. ! ----------------------------------------------------------------------
    5660. 

  5660. 

  5661.     DO K = ISNOW+1,NSOIL
    5662. 

  5662.        RHSTS(K) =   RHSTS(K) * DT
    5663. 

  5663.        AI(K)    =      AI(K) * DT
    5664. 

  5664.        BI(K)    = 1. + BI(K) * DT
    5665. 

  5665.        CI(K)    =      CI(K) * DT
    5666. 

  5666.     END DO
    5667. 

  5667. 

  5668. ! copy values for input variables before call to rosr12
    5669. 

  5669. 

  5670.     DO K = ISNOW+1,NSOIL
    5671. 

  5671.        RHSTSIN(K) = RHSTS(K)
    5672. 

  5672.        CIIN(K)    = CI(K)
    5673. 

  5673.     END DO
    5674. 

  5674. 

  5675. ! solve the tri-diagonal matrix equation
    5676. 

  5676. 

  5677.     CALL ROSR12 (CI,AI,BI,CIIN,RHSTSIN,RHSTS,ISNOW+1,NSOIL,NSNOW)
    5678. 

  5678. 

  5679. ! update snow & soil temperature
    5680. 

  5680. 

  5681.     DO K = ISNOW+1,NSOIL
    5682. 

  5682.        STC (K) = STC (K) + CI (K)
    5683. 

  5683.     END DO
    5684. 

  5684. 

  5685.   END SUBROUTINE HSTEP
    5686. 

  5686. ! ==================================================================================================
    5687. 

  5687.   SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW)
    5688. 

  5688. ! ----------------------------------------------------------------------
    5689. 

  5689. ! SUBROUTINE ROSR12
    5690. 

  5690. ! ----------------------------------------------------------------------
    5691. 

  5691. ! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW:
    5692. 

  5692. ! ###                                            ### ###  ###   ###  ###
    5693. 

  5693. ! #B(1), C(1),  0  ,  0  ,  0  ,   . . .  ,    0   # #      #   #      #
    5694. 

  5694. ! #A(2), B(2), C(2),  0  ,  0  ,   . . .  ,    0   # #      #   #      #
    5695. 

  5695. ! # 0  , A(3), B(3), C(3),  0  ,   . . .  ,    0   # #      #   # D(3) #
    5696. 

  5696. ! # 0  ,  0  , A(4), B(4), C(4),   . . .  ,    0   # # P(4) #   # D(4) #
    5697. 

  5697. ! # 0  ,  0  ,  0  , A(5), B(5),   . . .  ,    0   # # P(5) #   # D(5) #
    5698. 

  5698. ! # .                                          .   # #  .   # = #   .  #
    5699. 

  5699. ! # .                                          .   # #  .   #   #   .  #
    5700. 

  5700. ! # .                                          .   # #  .   #   #   .  #
    5701. 

  5701. ! # 0  , . . . , 0 , A(M-2), B(M-2), C(M-2),   0   # #P(M-2)#   #D(M-2)#
    5702. 

  5702. ! # 0  , . . . , 0 ,   0   , A(M-1), B(M-1), C(M-1)# #P(M-1)#   #D(M-1)#
    5703. 

  5703. ! # 0  , . . . , 0 ,   0   ,   0   ,  A(M) ,  B(M) # # P(M) #   # D(M) #
    5704. 

  5704. ! ###                                            ### ###  ###   ###  ###
    5705. 

  5705. ! ----------------------------------------------------------------------
    5706. 

  5706.     IMPLICIT NONE
    5707. 

  5707. 

  5708.     INTEGER, INTENT(IN)   :: NTOP           
    5709. 

  5709.     INTEGER, INTENT(IN)   :: NSOIL,NSNOW
    5710. 

  5710.     INTEGER               :: K, KK
    5711. 

  5711. 

  5712.     REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(IN):: A, B, D
    5713. 

  5713.     REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(INOUT):: C,P,DELTA
    5714. 

  5714. 

  5715. ! ----------------------------------------------------------------------
    5716. 

  5716. ! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER
    5717. 

  5717. ! ----------------------------------------------------------------------
    5718. 

  5718.     C (NSOIL) = 0.0
    5719. 

  5719.     P (NTOP) = - C (NTOP) / B (NTOP)
    5720. 

  5720. ! ----------------------------------------------------------------------
    5721. 

  5721. ! SOLVE THE COEFS FOR THE 1ST SOIL LAYER
    5722. 

  5722. ! ----------------------------------------------------------------------
    5723. 

  5723.     DELTA (NTOP) = D (NTOP) / B (NTOP)
    5724. 

  5724. ! ----------------------------------------------------------------------
    5725. 

  5725. ! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL
    5726. 

  5726. ! ----------------------------------------------------------------------
    5727. 

  5727.     DO K = NTOP+1,NSOIL
    5728. 

  5728.        P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) )
    5729. 

  5729.        DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)&
    5730. 

  5730.             * P (K -1)))
    5731. 

  5731.     END DO
    5732. 

  5732. ! ----------------------------------------------------------------------
    5733. 

  5733. ! SET P TO DELTA FOR LOWEST SOIL LAYER
    5734. 

  5734. ! ----------------------------------------------------------------------
    5735. 

  5735.     P (NSOIL) = DELTA (NSOIL)
    5736. 

  5736. ! ----------------------------------------------------------------------
    5737. 

  5737. ! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL
    5738. 

  5738. ! ----------------------------------------------------------------------
    5739. 

  5739.     DO K = NTOP+1,NSOIL
    5740. 

  5740.        KK = NSOIL - K + (NTOP-1) + 1
    5741. 

  5741.        P (KK) = P (KK) * P (KK +1) + DELTA (KK)
    5742. 

  5742.     END DO
    5743. 

  5743. ! ----------------------------------------------------------------------
    5744. 

  5744.   END SUBROUTINE ROSR12
    5745. 

  5745. ! ----------------------------------------------------------------------
    5746. 

  5746. ! ==================================================================================================
    5747. 

  5747.   SUBROUTINE PHASECHANGE (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , & !in
    5748. 

  5748.                           DZSNSO  ,HCPCT   ,IST     ,ILOC    ,JLOC    , & !in
    5749. 

  5749.                           STC     ,SNICE   ,SNLIQ   ,SNEQV   ,SNOWH   , & !inout
    5750. 

  5750.                           SMC     ,SH2O    ,                            & !inout
    5751. 

  5751.                           QMELT   ,IMELT   ,PONDING )                     !out
    5752. 

  5752. ! ----------------------------------------------------------------------
    5753. 

  5753. ! melting/freezing of snow water and soil water
    5754. 

  5754. ! ----------------------------------------------------------------------
    5755. 

  5755.   IMPLICIT NONE
    5756. 

  5756. ! ----------------------------------------------------------------------
    5757. 

  5757. ! inputs
    5758. 

  5758. 

  5759.   INTEGER, INTENT(IN)                             :: ILOC   !grid index
    5760. 

  5760.   INTEGER, INTENT(IN)                             :: JLOC   !grid index
    5761. 

  5761.   INTEGER, INTENT(IN)                             :: NSNOW  !maximum no. of snow layers [=3]
    5762. 

  5762.   INTEGER, INTENT(IN)                             :: NSOIL  !No. of soil layers [=4]
    5763. 

  5763.   INTEGER, INTENT(IN)                             :: ISNOW  !actual no. of snow layers [<=3]
    5764. 

  5764.   INTEGER, INTENT(IN)                             :: IST    !surface type: 1->soil; 2->lake
    5765. 

  5765.   REAL, INTENT(IN)                                :: DT     !land model time step (sec)
    5766. 

  5766.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)     :: FACT   !temporary
    5767. 

  5767.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)     :: DZSNSO !snow/soil layer thickness [m]
    5768. 

  5768.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)     :: HCPCT  !heat capacity (J/m3/k)
    5769. 

  5769. 

  5770. ! outputs
    5771. 

  5771.   INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT  !phase change index
    5772. 

  5772.   REAL,                               INTENT(OUT) :: QMELT  !snowmelt rate [mm/s]
    5773. 

  5773.   REAL,                               INTENT(OUT) :: PONDING!snowmelt when snow has no layer [mm]
    5774. 

  5774. 

  5775. ! inputs and outputs
    5776. 

  5776. 

  5777.   REAL, INTENT(INOUT) :: SNEQV
    5778. 

  5778.   REAL, INTENT(INOUT) :: SNOWH
    5779. 

  5779.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT)  :: STC    !snow/soil layer temperature [k]
    5780. 

  5780.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT)  :: SH2O   !soil liquid water [m3/m3]
    5781. 

  5781.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT)  :: SMC    !total soil water [m3/m3]
    5782. 

  5782.   REAL, DIMENSION(-NSNOW+1:0)    , INTENT(INOUT)  :: SNICE  !snow layer ice [mm]
    5783. 

  5783.   REAL, DIMENSION(-NSNOW+1:0)    , INTENT(INOUT)  :: SNLIQ  !snow layer liquid water [mm]
    5784. 

  5784. 

  5785. ! local
    5786. 

  5786. 

  5787.   INTEGER                         :: J         !do loop index
    5788. 

  5788.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM        !energy residual [w/m2]
    5789. 

  5789.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM        !melting or freezing water [kg/m2]
    5790. 

  5790.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0
    5791. 

  5791.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 
    5792. 

  5792.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 
    5793. 

  5793.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE      !soil/snow ice mass [mm]
    5794. 

  5794.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ      !soil/snow liquid water mass [mm]
    5795. 

  5795.   REAL, DIMENSION(-NSNOW+1:NSOIL) :: SUPERCOOL !supercooled water in soil (kg/m2)
    5796. 

  5796.   REAL                            :: HEATR     !energy residual or loss after melting/freezing
    5797. 

  5797.   REAL                            :: TEMP1     !temporary variables [kg/m2]
    5798. 

  5798.   REAL                            :: PROPOR
    5799. 

  5799.   REAL                            :: SMP       !frozen water potential (mm)
    5800. 

  5800.   REAL                            :: XMF       !total latent heat of phase change
    5801. 

  5801. 

  5802. ! ----------------------------------------------------------------------
    5803. 

  5803. ! Initialization
    5804. 

  5804. 

  5805.     QMELT   = 0.
    5806. 

  5806.     PONDING = 0.
    5807. 

  5807.     XMF     = 0.
    5808. 

  5808. 

  5809.     DO J = -NSNOW+1, NSOIL
    5810. 

  5810.          SUPERCOOL(J) = 0.0
    5811. 

  5811.     END DO
    5812. 

  5812. 

  5813.     DO J = ISNOW+1,0       ! all layers
    5814. 

  5814.          MICE(J) = SNICE(J)
    5815. 

  5815.          MLIQ(J) = SNLIQ(J)
    5816. 

  5816.     END DO
    5817. 

  5817. 

  5818.     DO J = 1, NSOIL               ! soil
    5819. 

  5819.          MLIQ(J) =  SH2O(J)            * DZSNSO(J) * 1000.
    5820. 

  5820.          MICE(J) = (SMC(J) - SH2O(J))  * DZSNSO(J) * 1000.
    5821. 

  5821.     END DO
    5822. 

  5822. 

  5823.     DO J = ISNOW+1,NSOIL       ! all layers
    5824. 

  5824.          IMELT(J)    = 0
    5825. 

  5825.          HM(J)       = 0.
    5826. 

  5826.          XM(J)       = 0.
    5827. 

  5827.          WICE0(J)    = MICE(J)
    5828. 

  5828.          WLIQ0(J)    = MLIQ(J)
    5829. 

  5829.          WMASS0(J)   = MICE(J) + MLIQ(J)
    5830. 

  5830.     ENDDO
    5831. 

  5831. 

  5832.     if(ist == 1) then
    5833. 

  5833.       DO J = 1,NSOIL
    5834. 

  5834.          IF (OPT_FRZ == 1) THEN
    5835. 

  5835.             IF(STC(J) < TFRZ) THEN
    5836. 

  5836.                SMP = HFUS*(TFRZ-STC(J))/(GRAV*STC(J))             !(m)
    5837. 

  5837.                SUPERCOOL(J) = SMCMAX*(SMP/PSISAT)**(-1./BEXP)
    5838. 

  5838.                SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000.        !(mm)
    5839. 

  5839.             END IF
    5840. 

  5840.          END IF
    5841. 

  5841.          IF (OPT_FRZ == 2) THEN
    5842. 

  5842.                CALL FRH2O (SUPERCOOL(J),STC(J),SMC(J),SH2O(J))
    5843. 

  5843.                SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000.        !(mm)
    5844. 

  5844.          END IF
    5845. 

  5845.       ENDDO
    5846. 

  5846.     end if
    5847. 

  5847. 

  5848.     DO J = ISNOW+1,NSOIL
    5849. 

  5849.          IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN  !melting 
    5850. 

  5850.              IMELT(J) = 1
    5851. 

  5851.          ENDIF
    5852. 

  5852.          IF (MLIQ(J) > SUPERCOOL(J) .AND. STC(J) < TFRZ) THEN
    5853. 

  5853.              IMELT(J) = 2
    5854. 

  5854.          ENDIF
    5855. 

  5855. 

  5856.          ! If snow exists, but its thickness is not enough to create a layer
    5857. 

  5857.          IF (ISNOW == 0 .AND. SNEQV > 0. .AND. J == 1) THEN
    5858. 

  5858.              IF (STC(J) >= TFRZ) THEN
    5859. 

  5859.                 IMELT(J) = 1
    5860. 

  5860.              ENDIF
    5861. 

  5861.          ENDIF
    5862. 

  5862.     ENDDO
    5863. 

  5863. 

  5864. ! Calculate the energy surplus and loss for melting and freezing
    5865. 

  5865. 

  5866.     DO J = ISNOW+1,NSOIL
    5867. 

  5867.          IF (IMELT(J) > 0) THEN
    5868. 

  5868.              HM(J) = (STC(J)-TFRZ)/FACT(J)
    5869. 

  5869.              STC(J) = TFRZ
    5870. 

  5870.          ENDIF
    5871. 

  5871. 

  5872.          IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN
    5873. 

  5873.             HM(J) = 0.
    5874. 

  5874.             IMELT(J) = 0
    5875. 

  5875.          ENDIF
    5876. 

  5876.          IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN
    5877. 

  5877.             HM(J) = 0.
    5878. 

  5878.             IMELT(J) = 0
    5879. 

  5879.          ENDIF
    5880. 

  5880.          XM(J) = HM(J)*DT/HFUS                           
    5881. 

  5881.     ENDDO
    5882. 

  5882. 

  5883. ! The rate of melting and freezing for snow without a layer, needs more work.
    5884. 

  5884. 

  5885.     IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN  
    5886. 

  5886.         TEMP1  = SNEQV
    5887. 

  5887.         SNEQV  = MAX(0.,TEMP1-XM(1))  
    5888. 

  5888.         PROPOR = SNEQV/TEMP1
    5889. 

  5889.         SNOWH  = MAX(0.,PROPOR * SNOWH)
    5890. 

  5890.         HEATR  = HM(1) - HFUS*(TEMP1-SNEQV)/DT  
    5891. 

  5891.         IF (HEATR > 0.) THEN
    5892. 

  5892.               XM(1) = HEATR*DT/HFUS             
    5893. 

  5893.               HM(1) = HEATR                    
    5894. 

  5894.         ELSE
    5895. 

  5895.               XM(1) = 0.
    5896. 

  5896.               HM(1) = 0.
    5897. 

  5897.         ENDIF
    5898. 

  5898.         QMELT   = MAX(0.,(TEMP1-SNEQV))/DT
    5899. 

  5899.         XMF     = HFUS*QMELT
    5900. 

  5900.         PONDING = TEMP1-SNEQV
    5901. 

  5901.     ENDIF
    5902. 

  5902. 

  5903. ! The rate of melting and freezing for snow and soil
    5904. 

  5904. 

  5905.     DO J = ISNOW+1,NSOIL
    5906. 

  5906.       IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN
    5907. 

  5907. 

  5908.          HEATR = 0.
    5909. 

  5909.          IF (XM(J) > 0.) THEN                            
    5910. 

  5910.             MICE(J) = MAX(0., WICE0(J)-XM(J))
    5911. 

  5911.             HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
    5912. 

  5912.          ELSE IF (XM(J) < 0.) THEN                      
    5913. 

  5913.             IF (J <= 0) THEN                             ! snow
    5914. 

  5914.                MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J))  
    5915. 

  5915.             ELSE                                         ! soil
    5916. 

  5916.                IF (WMASS0(J) < SUPERCOOL(J)) THEN
    5917. 

  5917.                   MICE(J) = 0.
    5918. 

  5918.                ELSE
    5919. 

  5919.                   MICE(J) = MIN(WMASS0(J) - SUPERCOOL(J),WICE0(J)-XM(J))
    5920. 

  5920.                   MICE(J) = MAX(MICE(J),0.0)
    5921. 

  5921.                ENDIF
    5922. 

  5922.             ENDIF
    5923. 

  5923.             HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
    5924. 

  5924.          ENDIF
    5925. 

  5925. 

  5926.          MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J))
    5927. 

  5927. 

  5928.          IF (ABS(HEATR) > 0.) THEN
    5929. 

  5929.             STC(J) = STC(J) + FACT(J)*HEATR
    5930. 

  5930.             IF (J <= 0) THEN                             ! snow
    5931. 

  5931.                IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ
    5932. 

  5932.             END IF
    5933. 

  5933.          ENDIF
    5934. 

  5934. 

  5935.          XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT
    5936. 

  5936. 

  5937.          IF (J < 1) THEN
    5938. 

  5938.             QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT
    5939. 

  5939.          ENDIF
    5940. 

  5940.       ENDIF
    5941. 

  5941.     ENDDO
    5942. 

  5942. 

  5943.     DO J = ISNOW+1,0             ! snow
    5944. 

  5944.        SNLIQ(J) = MLIQ(J)
    5945. 

  5945.        SNICE(J) = MICE(J)
    5946. 

  5946.     END DO
    5947. 

  5947. 

  5948.     DO J = 1, NSOIL              ! soil
    5949. 

  5949.        SH2O(J) =  MLIQ(J)            / (1000. * DZSNSO(J))
    5950. 

  5950.        SMC(J)  = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J))
    5951. 

  5951.     END DO
    5952. 

  5952.    
    5953. 

  5953.   END SUBROUTINE PHASECHANGE
    5954. 

  5954. ! ==================================================================================================
    5955. 

  5955.   SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O)
    5956. 

  5956. 

  5957. ! ----------------------------------------------------------------------
    5958. 

  5958. ! SUBROUTINE FRH2O
    5959. 

  5959. ! ----------------------------------------------------------------------
    5960. 

  5960. ! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF
    5961. 

  5961. ! TEMPERATURE IS BELOW 273.15K (TFRZ).  REQUIRES NEWTON-TYPE ITERATION
    5962. 

  5962. ! TO SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL
    5963. 

  5963. ! (1999, JGR, VOL 104(D16), 19569-19585).
    5964. 

  5964. ! ----------------------------------------------------------------------
    5965. 

  5965. ! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON
    5966. 

  5966. ! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN
    5967. 

  5967. ! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE.  ALSO, EXPLICIT
    5968. 

  5968. ! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH
    5969. 

  5969. ! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM,
    5970. 

  5970. ! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE
    5971. 

  5971. ! LIMIT OF FREEZING POINT TEMPERATURE TFRZ.
    5972. 

  5972. ! ----------------------------------------------------------------------
    5973. 

  5973. ! INPUT:
    5974. 

  5974. 

  5975. !   TKELV.........TEMPERATURE (Kelvin)
    5976. 

  5976. !   SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC)
    5977. 

  5977. !   SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC)
    5978. 

  5978. !   B.............SOIL TYPE "B" PARAMETER (FROM REDPRM)
    5979. 

  5979. !   PSISAT........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM)
    5980. 

  5980. 

  5981. ! OUTPUT:
    5982. 

  5982. !   FREE..........SUPERCOOLED LIQUID WATER CONTENT [m3/m3]
    5983. 

  5983. ! ----------------------------------------------------------------------
    5984. 

  5984.     IMPLICIT NONE
    5985. 

  5985.     REAL, INTENT(IN)     :: SH2O,SMC,TKELV
    5986. 

  5986.     REAL, INTENT(OUT)    :: FREE
    5987. 

  5987.     REAL                 :: BX,DENOM,DF,DSWL,FK,SWL,SWLK
    5988. 

  5988.     INTEGER              :: NLOG,KCOUNT
    5989. 

  5989. !      PARAMETER(CK = 0.0)
    5990. 

  5990.     REAL, PARAMETER      :: CK = 8.0, BLIM = 5.5, ERROR = 0.005,       &
    5991. 

  5991.          DICE = 920.0
    5992. 

  5992.     CHARACTER(LEN=80)    :: message
    5993. 

  5993. 

  5994. ! ----------------------------------------------------------------------
    5995. 

  5995. ! LIMITS ON PARAMETER B: B < 5.5  (use parameter BLIM)
    5996. 

  5996. ! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS
    5997. 

  5997. ! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES.
    5998. 

  5998. ! ----------------------------------------------------------------------
    5999. 

  5999.     BX = BEXP
    6000. 

  6000. ! ----------------------------------------------------------------------
    6001. 

  6001. ! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG.
    6002. 

  6002. ! ----------------------------------------------------------------------
    6003. 

  6003. 

  6004.     IF (BEXP >  BLIM) BX = BLIM
    6005. 

  6005.     NLOG = 0
    6006. 

  6006. 

  6007. ! ----------------------------------------------------------------------
    6008. 

  6008. !  IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (TFRZ), SH2O = SMC
    6009. 

  6009. ! ----------------------------------------------------------------------
    6010. 

  6010.     KCOUNT = 0
    6011. 

  6011.     IF (TKELV > (TFRZ- 1.E-3)) THEN
    6012. 

  6012.        FREE = SMC
    6013. 

  6013.     ELSE
    6014. 

  6014. 

  6015. ! ----------------------------------------------------------------------
    6016. 

  6016. ! OPTION 1: ITERATED SOLUTION IN KOREN ET AL, JGR, 1999, EQN 17
    6017. 

  6017. ! ----------------------------------------------------------------------
    6018. 

  6018. ! INITIAL GUESS FOR SWL (frozen content)
    6019. 

  6019. ! ----------------------------------------------------------------------
    6020. 

  6020.        IF (CK /= 0.0) THEN
    6021. 

  6021.           SWL = SMC - SH2O
    6022. 

  6022. ! ----------------------------------------------------------------------
    6023. 

  6023. ! KEEP WITHIN BOUNDS.
    6024. 

  6024. ! ----------------------------------------------------------------------
    6025. 

  6025.           IF (SWL > (SMC -0.02)) SWL = SMC -0.02
    6026. 

  6026. ! ----------------------------------------------------------------------
    6027. 

  6027. !  START OF ITERATIONS
    6028. 

  6028. ! ----------------------------------------------------------------------
    6029. 

  6029.           IF (SWL < 0.) SWL = 0.
    6030. 

  6030. 1001      Continue
    6031. 

  6031.           IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0)))   goto 1002
    6032. 

  6032.           NLOG = NLOG +1
    6033. 

  6033.           DF = ALOG ( ( PSISAT * GRAV / hfus ) * ( ( 1. + CK * SWL )**2.) * &
    6034. 

  6034.                ( SMCMAX / (SMC - SWL) )** BX) - ALOG ( - (               &
    6035. 

  6035.                TKELV - TFRZ)/ TKELV)
    6036. 

  6036.           DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL )
    6037. 

  6037.           SWLK = SWL - DF / DENOM
    6038. 

  6038. ! ----------------------------------------------------------------------
    6039. 

  6039. ! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION.
    6040. 

  6040. ! ----------------------------------------------------------------------
    6041. 

  6041.           IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02
    6042. 

  6042.           IF (SWLK < 0.) SWLK = 0.
    6043. 

  6043. 

  6044. ! ----------------------------------------------------------------------
    6045. 

  6045. ! MATHEMATICAL SOLUTION BOUNDS APPLIED.
    6046. 

  6046. ! ----------------------------------------------------------------------
    6047. 

  6047.           DSWL = ABS (SWLK - SWL)
    6048. 

  6048. ! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.)
    6049. 

  6049. ! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED.
    6050. 

  6050. ! ----------------------------------------------------------------------
    6051. 

  6051.           SWL = SWLK
    6052. 

  6052.           IF ( DSWL <= ERROR ) THEN
    6053. 

  6053.              KCOUNT = KCOUNT +1
    6054. 

  6054.           END IF
    6055. 

  6055. ! ----------------------------------------------------------------------
    6056. 

  6056. !  END OF ITERATIONS
    6057. 

  6057. ! ----------------------------------------------------------------------
    6058. 

  6058. ! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION.
    6059. 

  6059. ! ----------------------------------------------------------------------
    6060. 

  6060.           goto 1001
    6061. 

  6061. 1002      continue
    6062. 

  6062.           FREE = SMC - SWL
    6063. 

  6063.        END IF
    6064. 

  6064. ! ----------------------------------------------------------------------
    6065. 

  6065. ! END OPTION 1
    6066. 

  6066. ! ----------------------------------------------------------------------
    6067. 

  6067. ! ----------------------------------------------------------------------
    6068. 

  6068. ! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0
    6069. 

  6069. ! IN KOREN ET AL., JGR, 1999, EQN 17
    6070. 

  6070. ! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION
    6071. 

  6071. ! ----------------------------------------------------------------------
    6072. 

  6072.        IF (KCOUNT == 0) THEN
    6073. 

  6073.           write(message, '("Flerchinger used in NEW version. Iterations=", I6)') NLOG
    6074. 

  6074.           call wrf_message(trim(message))
    6075. 

  6075.           FK = ( ( (hfus / (GRAV * ( - PSISAT)))*                    &
    6076. 

  6076.                ( (TKELV - TFRZ)/ TKELV))** ( -1/ BX))* SMCMAX
    6077. 

  6077.           IF (FK < 0.02) FK = 0.02
    6078. 

  6078.           FREE = MIN (FK, SMC)
    6079. 

  6079. ! ----------------------------------------------------------------------
    6080. 

  6080. ! END OPTION 2
    6081. 

  6081. ! ----------------------------------------------------------------------
    6082. 

  6082.        END IF
    6083. 

  6083.     END IF
    6084. 

  6084. ! ----------------------------------------------------------------------
    6085. 

  6085.   END SUBROUTINE FRH2O
    6086. 

  6086. ! ----------------------------------------------------------------------
    6087. 

  6087. ! ==================================================================================================
    6088. 

  6088. ! **********************End of energy subroutines***********************
    6089. 

  6089. ! ==================================================================================================
    6090. 

  6090.   SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
    6091. 

  6091.                     VV     ,FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
    6092. 

  6092.                     ESAI   ,SFCTMP ,QVAP   ,QDEW   ,ZSOIL  ,BTRANI , & !in
    6093. 

  6093.                     FICEOLD,PONDING,TG     ,IST    ,FVEG   ,ILOC   ,JLOC , & !in
    6094. 

  6094.                     ISNOW  ,CANLIQ ,CANICE ,TV     ,SNOWH  ,SNEQV  , & !inout
    6095. 

  6095.                     SNICE  ,SNLIQ  ,STC    ,ZSNSO  ,SH2O   ,SMC    , & !inout
    6096. 

  6096.                     SICE   ,ZWT    ,WA     ,WT     ,DZSNSO ,WSLAKE , & !inout
    6097. 

  6097.                     CMC    ,ECAN   ,ETRAN  ,FWET   ,RUNSRF ,RUNSUB , & !out
    6098. 

  6098.                     QIN    ,QDIS   ,QSNOW  ,PONDING1       ,PONDING2,&
    6099. 

  6099.                     ISURBAN)  !out
    6100. 

  6100. ! ----------------------------------------------------------------------  
    6101. 

  6101. ! Code history:
    6102. 

  6102. ! Initial code: Guo-Yue Niu, Oct. 2007
    6103. 

  6103. ! ----------------------------------------------------------------------
    6104. 

  6104.   implicit none
    6105. 

  6105. ! ----------------------------------------------------------------------
    6106. 

  6106. ! input
    6107. 

  6107.   INTEGER,                         INTENT(IN)    :: ILOC    !grid index
    6108. 

  6108.   INTEGER,                         INTENT(IN)    :: JLOC    !grid index
    6109. 

  6109.   INTEGER,                         INTENT(IN)    :: VEGTYP  !vegetation type
    6110. 

  6110.   INTEGER,                         INTENT(IN)    :: NSNOW   !maximum no. of snow layers
    6111. 

  6111.   INTEGER                        , INTENT(IN)    :: IST     !surface type 1-soil; 2-lake
    6112. 

  6112.   INTEGER,                         INTENT(IN)    :: NSOIL   !no. of soil layers
    6113. 

  6113.   INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN)    :: IMELT   !melting state index [1-melt; 2-freeze]
    6114. 

  6114.   REAL,                            INTENT(IN)    :: DT      !main time step (s)
    6115. 

  6115.   REAL,                            INTENT(IN)    :: UU      !u-direction wind speed [m/s]
    6116. 

  6116.   REAL,                            INTENT(IN)    :: VV      !v-direction wind speed [m/s]
    6117. 

  6117.   REAL,                            INTENT(IN)    :: FCEV    !canopy evaporation (w/m2) [+ to atm ]
    6118. 

  6118.   REAL,                            INTENT(IN)    :: FCTR    !transpiration (w/m2) [+ to atm]
    6119. 

  6119.   REAL,                            INTENT(IN)    :: QPRECC  !convective precipitation (mm/s)
    6120. 

  6120.   REAL,                            INTENT(IN)    :: QPRECL  !large-scale precipitation (mm/s)
    6121. 

  6121.   REAL,                            INTENT(IN)    :: ELAI    !leaf area index, after burying by snow
    6122. 

  6122.   REAL,                            INTENT(IN)    :: ESAI    !stem area index, after burying by snow
    6123. 

  6123.   REAL,                            INTENT(IN)    :: SFCTMP  !surface air temperature [k]
    6124. 

  6124.   REAL,                            INTENT(IN)    :: QVAP    !soil surface evaporation rate[mm/s]
    6125. 

  6125.   REAL,                            INTENT(IN)    :: QDEW    !soil surface dew rate[mm/s]
    6126. 

  6126.   REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: ZSOIL   !depth of layer-bottom from soil surface
    6127. 

  6127.   REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: BTRANI  !soil water stress factor (0 to 1)
    6128. 

  6128.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)    :: FICEOLD !ice fraction at last timestep
    6129. 

  6129. !  REAL                           , INTENT(IN)    :: PONDING ![mm]
    6130. 

  6130.   REAL                           , INTENT(IN)    :: TG      !ground temperature (k)
    6131. 

  6131.   REAL                           , INTENT(IN)    :: FVEG    !greeness vegetation fraction (-)
    6132. 

  6132. 

  6133. ! input/output
    6134. 

  6134.   INTEGER,                         INTENT(INOUT) :: ISNOW   !actual no. of snow layers
    6135. 

  6135.   REAL,                            INTENT(INOUT) :: CANLIQ  !intercepted liquid water (mm)
    6136. 

  6136.   REAL,                            INTENT(INOUT) :: CANICE  !intercepted ice mass (mm)
    6137. 

  6137.   REAL,                            INTENT(INOUT) :: TV      !vegetation temperature (k)
    6138. 

  6138.   REAL,                            INTENT(INOUT) :: SNOWH   !snow height [m]
    6139. 

  6139.   REAL,                            INTENT(INOUT) :: SNEQV   !snow water eqv. [mm]
    6140. 

  6140.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE   !snow layer ice [mm]
    6141. 

  6141.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ   !snow layer liquid water [mm]
    6142. 

  6142.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC     !snow/soil layer temperature [k]
    6143. 

  6143.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO   !depth of snow/soil layer-bottom
    6144. 

  6144.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO  !snow/soil layer thickness [m]
    6145. 

  6145.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O    !soil liquid water content [m3/m3]
    6146. 

  6146.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SICE    !soil ice content [m3/m3]
    6147. 

  6147.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SMC     !total soil water content [m3/m3]
    6148. 

  6148.   REAL,                            INTENT(INOUT) :: ZWT     !the depth to water table [m]
    6149. 

  6149.   REAL,                            INTENT(INOUT) :: WA      !water storage in aquifer [mm]
    6150. 

  6150.   REAL,                            INTENT(INOUT) :: WT      !water storage in aquifer 
    6151. 

  6151.                                                             !+ stuarated soil [mm]
    6152. 

  6152.   REAL,                            INTENT(INOUT) :: WSLAKE  !water storage in lake (can be -) (mm)
    6153. 

  6153.   REAL                           , INTENT(INOUT) :: PONDING ![mm]
    6154. 

  6154. 

  6155. ! output
    6156. 

  6156.   REAL,                            INTENT(OUT)   :: CMC     !intercepted water per ground area (mm)
    6157. 

  6157.   REAL,                            INTENT(OUT)   :: ECAN    !evap of intercepted water (mm/s) [+]
    6158. 

  6158.   REAL,                            INTENT(OUT)   :: ETRAN   !transpiration rate (mm/s) [+]
    6159. 

  6159.   REAL,                            INTENT(OUT)   :: FWET    !wetted/snowed fraction of canopy (-)
    6160. 

  6160.   REAL,                            INTENT(OUT)   :: RUNSRF  !surface runoff [mm/s] 
    6161. 

  6161.   REAL,                            INTENT(OUT)   :: RUNSUB  !baseflow (sturation excess) [mm/s]
    6162. 

  6162.   REAL,                            INTENT(OUT)   :: QIN     !groundwater recharge [mm/s]
    6163. 

  6163.   REAL,                            INTENT(OUT)   :: QDIS    !groundwater discharge [mm/s]
    6164. 

  6164.   REAL,                            INTENT(OUT)   :: QSNOW   !snow at ground srf (mm/s) [+]
    6165. 

  6165.   REAL,                            INTENT(OUT)   :: PONDING1
    6166. 

  6166.   REAL,                            INTENT(OUT)   :: PONDING2
    6167. 

  6167. 

  6168.   INTEGER,                         INTENT(IN)    :: ISURBAN
    6169. 

  6169. 

  6170. ! local
    6171. 

  6171.   INTEGER                                        :: IZ
    6172. 

  6172.   REAL                                           :: QINSUR  !water input on soil surface [m/s]
    6173. 

  6173.   REAL                                           :: QRAIN   !rain at ground srf (mm) [+]
    6174. 

  6174.   REAL                                           :: QSNBOT  !melting water out of snow bottom [mm/s]
    6175. 

  6175.   REAL                                           :: QSEVA   !soil surface evap rate [mm/s]
    6176. 

  6176.   REAL                                           :: QSDEW   !soil surface dew rate [mm/s]
    6177. 

  6177.   REAL                                           :: QSNFRO  !snow surface frost rate[mm/s]
    6178. 

  6178.   REAL                                           :: QSNSUB  !snow surface sublimation rate [mm/s]
    6179. 

  6179.   REAL                                           :: SNOWHIN !snow depth increasing rate (m/s)
    6180. 

  6180.   REAL, DIMENSION(       1:NSOIL)                :: ETRANI  !transpiration rate (mm/s) [+]
    6181. 

  6181.   REAL, DIMENSION(       1:NSOIL)                :: WCND   !hydraulic conductivity (m/s)
    6182. 

  6182.   REAL                                           :: QDRAIN  !soil-bottom free drainage [mm/s] 
    6183. 

  6183.   REAL                                           :: SNOFLOW !glacier flow [mm/s]
    6184. 

  6184.   REAL                                           :: FCRMAX !maximum of FCR (-)
    6185. 

  6185. 

  6186.   REAL, PARAMETER ::  WSLMAX = 5000.      !maximum lake water storage (mm)
    6187. 

  6187. ! ----------------------------------------------------------------------
    6188. 

  6188. ! initialize
    6189. 

  6189. 

  6190.    ETRANI(1:NSOIL) = 0.
    6191. 

  6191.    SNOFLOW         = 0.
    6192. 

  6192.    RUNSUB          = 0.
    6193. 

  6193.    QINSUR          = 0.
    6194. 

  6194. 

  6195. ! canopy-intercepted snowfall/rainfall, drips, and throughfall
    6196. 

  6196. 

  6197.    CALL CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
    6198. 

  6198.                   FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
    6199. 

  6199.                   ESAI   ,IST    ,TG     ,FVEG   ,ILOC   , JLOC, & !in
    6200. 

  6200.                   CANLIQ ,CANICE ,TV     ,                 & !inout
    6201. 

  6201.                   CMC    ,ECAN   ,ETRAN  ,QRAIN  ,QSNOW  , & !out
    6202. 

  6202.                   SNOWHIN,FWET   )                           !out
    6203. 

  6203. 

  6204. ! sublimation, frost, evaporation, and dew
    6205. 

  6205. 

  6206.      QSNSUB = 0.
    6207. 

  6207.      IF (SNEQV > 0.) THEN
    6208. 

  6208.        QSNSUB = MIN(QVAP, SNEQV/DT)
    6209. 

  6209.      ENDIF
    6210. 

  6210.      QSEVA = QVAP-QSNSUB
    6211. 

  6211. 

  6212.      QSNFRO = 0.
    6213. 

  6213.      IF (SNEQV > 0.) THEN
    6214. 

  6214.         QSNFRO = QDEW
    6215. 

  6215.      ENDIF
    6216. 

  6216.      QSDEW = QDEW - QSNFRO
    6217. 

  6217. 

  6218.      CALL SNOWWATER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,ZSOIL  , & !in
    6219. 

  6219.           &          SFCTMP ,SNOWHIN,QSNOW  ,QSNFRO ,QSNSUB , & !in
    6220. 

  6220.           &          QRAIN  ,FICEOLD,ILOC   ,JLOC   ,         & !in
    6221. 

  6221.           &          ISNOW  ,SNOWH  ,SNEQV  ,SNICE  ,SNLIQ  , & !inout
    6222. 

  6222.           &          SH2O   ,SICE   ,STC    ,ZSNSO  ,DZSNSO , & !inout
    6223. 

  6223.           &          QSNBOT ,SNOFLOW,PONDING1       ,PONDING2)  !out
    6224. 

  6224. 

  6225. ! convert units (mm/s -> m/s)
    6226. 

  6226. 

  6227.     !PONDING: melting water from snow when there is no layer
    6228. 

  6228.     QINSUR = (PONDING+PONDING1+PONDING2)/DT * 0.001
    6229. 

  6229. !    QINSUR = PONDING/DT * 0.001
    6230. 

  6230. 

  6231.     IF(ISNOW == 0) THEN
    6232. 

  6232.        QINSUR = QINSUR+(QSNBOT + QSDEW + QRAIN) * 0.001
    6233. 

  6233.     ELSE
    6234. 

  6234.        QINSUR = QINSUR+(QSNBOT + QSDEW) * 0.001
    6235. 

  6235.     ENDIF
    6236. 

  6236. 

  6237.     QSEVA  = QSEVA * 0.001 
    6238. 

  6238. 

  6239.     DO IZ = 1, NROOT
    6240. 

  6240.        ETRANI(IZ) = ETRAN * BTRANI(IZ) * 0.001
    6241. 

  6241.     ENDDO
    6242. 

  6242. 

  6243. ! lake/soil water balances
    6244. 

  6244. 

  6245.     IF (IST == 2) THEN                                        ! lake
    6246. 

  6246.        RUNSRF = 0.
    6247. 

  6247.        IF(WSLAKE >= WSLMAX) RUNSRF = QINSUR*1000.             !mm/s
    6248. 

  6248.        WSLAKE = WSLAKE + (QINSUR-QSEVA)*1000.*DT -RUNSRF*DT   !mm
    6249. 

  6249.     ELSE                                                      ! soil
    6250. 

  6250.        CALL      SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
    6251. 

  6251.                             QINSUR ,QSEVA  ,ETRANI ,SICE   ,ILOC   , JLOC , & !in
    6252. 

  6252.                             SH2O   ,SMC    ,ZWT    ,VEGTYP ,ISURBAN, & !inout
    6253. 

  6253.                             RUNSRF ,QDRAIN ,RUNSUB ,WCND   ,FCRMAX )   !out
    6254. 

  6254.  
    6255. 

  6255.        IF(OPT_RUN == 1) THEN 
    6256. 

  6256.           CALL GROUNDWATER (NSNOW  ,NSOIL  ,DT     ,SICE   ,ZSOIL  , & !in
    6257. 

  6257.                             STC    ,WCND   ,FCRMAX ,ILOC   ,JLOC   , & !in
    6258. 

  6258.                             SH2O   ,ZWT    ,WA     ,WT     ,         & !inout
    6259. 

  6259.                             QIN    ,QDIS   )                           !out
    6260. 

  6260.           RUNSUB       = QDIS          !mm/s
    6261. 

  6261.        END IF
    6262. 

  6262. 

  6263.        IF(OPT_RUN == 3 .or. OPT_RUN == 4) THEN 
    6264. 

  6264.           RUNSUB       = RUNSUB + QDRAIN        !mm/s
    6265. 

  6265.        END IF
    6266. 

  6266. 

  6267.        DO IZ = 1,NSOIL
    6268. 

  6268.            SMC(IZ) = SH2O(IZ) + SICE(IZ)
    6269. 

  6269.        ENDDO
    6270. 

  6270.     ENDIF
    6271. 

  6271. 

  6272.     RUNSUB       = RUNSUB + SNOFLOW         !mm/s
    6273. 

  6273. 

  6274.   END SUBROUTINE WATER
    6275. 

  6275. ! ==================================================================================================
    6276. 

  6276.   SUBROUTINE CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
    6277. 

  6277.                        FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
    6278. 

  6278.                        ESAI   ,IST    ,TG     ,FVEG   ,ILOC   , JLOC , & !in
    6279. 

  6279.                        CANLIQ ,CANICE ,TV     ,                 & !inout
    6280. 

  6280.                        CMC    ,ECAN   ,ETRAN  ,QRAIN  ,QSNOW  , & !out
    6281. 

  6281.                        SNOWHIN,FWET   )                           !out
    6282. 

  6282. 

  6283. ! ------------------------ code history ------------------------------
    6284. 

  6284. ! canopy hydrology
    6285. 

  6285. ! --------------------------------------------------------------------
    6286. 

  6286.   USE NOAHMP_VEG_PARAMETERS
    6287. 

  6287. ! --------------------------------------------------------------------
    6288. 

  6288.   IMPLICIT NONE
    6289. 

  6289. ! ------------------------ input/output variables --------------------
    6290. 

  6290. ! input
    6291. 

  6291.   INTEGER,INTENT(IN)  :: ILOC    !grid index
    6292. 

  6292.   INTEGER,INTENT(IN)  :: JLOC    !grid index
    6293. 

  6293.   INTEGER,INTENT(IN)  :: VEGTYP  !vegetation type
    6294. 

  6294.   REAL,   INTENT(IN)  :: DT      !main time step (s)
    6295. 

  6295.   REAL,   INTENT(IN)  :: SFCTMP  !air temperature (k)
    6296. 

  6296.   REAL,   INTENT(IN)  :: UU      !u-direction wind speed [m/s]
    6297. 

  6297.   REAL,   INTENT(IN)  :: VV      !v-direction wind speed [m/s]
    6298. 

  6298.   REAL,   INTENT(IN)  :: FCEV    !canopy evaporation (w/m2) [+ = to atm]
    6299. 

  6299.   REAL,   INTENT(IN)  :: FCTR    !transpiration (w/m2) [+ = to atm]
    6300. 

  6300.   REAL,   INTENT(IN)  :: QPRECC  !convective precipitation (mm/s)
    6301. 

  6301.   REAL,   INTENT(IN)  :: QPRECL  !large-scale precipitation (mm/s)
    6302. 

  6302.   REAL,   INTENT(IN)  :: ELAI    !leaf area index, after burying by snow
    6303. 

  6303.   REAL,   INTENT(IN)  :: ESAI    !stem area index, after burying by snow
    6304. 

  6304.   INTEGER,INTENT(IN)  :: IST     !surface type 1-soil; 2-lake
    6305. 

  6305.   REAL,   INTENT(IN)  :: TG      !ground temperature (k)
    6306. 

  6306.   REAL,   INTENT(IN)  :: FVEG    !greeness vegetation fraction (-)
    6307. 

  6307. 

  6308. ! input & output
    6309. 

  6309.   REAL, INTENT(INOUT) :: CANLIQ  !intercepted liquid water (mm)
    6310. 

  6310.   REAL, INTENT(INOUT) :: CANICE  !intercepted ice mass (mm)
    6311. 

  6311.   REAL, INTENT(INOUT) :: TV      !vegetation temperature (k)
    6312. 

  6312. 

  6313. ! output
    6314. 

  6314.   REAL, INTENT(OUT)   :: CMC     !intercepted water (mm)
    6315. 

  6315.   REAL, INTENT(OUT)   :: ECAN    !evaporation of intercepted water (mm/s) [+]
    6316. 

  6316.   REAL, INTENT(OUT)   :: ETRAN   !transpiration rate (mm/s) [+]
    6317. 

  6317.   REAL, INTENT(OUT)   :: QRAIN   !rain at ground srf (mm/s) [+]
    6318. 

  6318.   REAL, INTENT(OUT)   :: QSNOW   !snow at ground srf (mm/s) [+]
    6319. 

  6319.   REAL, INTENT(OUT)   :: SNOWHIN !snow depth increasing rate (m/s)
    6320. 

  6320.   REAL, INTENT(OUT)   :: FWET    !wetted or snowed fraction of the canopy (-)
    6321. 

  6321. ! --------------------------------------------------------------------
    6322. 

  6322. 

  6323. ! ------------------------ local variables ---------------------------
    6324. 

  6324.   REAL                :: MAXSNO  !canopy capacity for snow interception (mm)
    6325. 

  6325.   REAL                :: MAXLIQ  !canopy capacity for rain interception (mm)
    6326. 

  6326.   REAL                :: FP      !fraction of the gridcell that receives precipitation
    6327. 

  6327.   REAL                :: FPICE   !snow fraction in precipitation
    6328. 

  6328.   REAL                :: BDFALL  !bulk density of snowfall (kg/m3)
    6329. 

  6329.   REAL                :: QINTR   !interception rate for rain (mm/s)
    6330. 

  6330.   REAL                :: QDRIPR  !drip rate for rain (mm/s)
    6331. 

  6331.   REAL                :: QTHROR  !throughfall for rain (mm/s)
    6332. 

  6332.   REAL                :: QINTS   !interception (loading) rate for snowfall (mm/s)
    6333. 

  6333.   REAL                :: QDRIPS  !drip (unloading) rate for intercepted snow (mm/s)
    6334. 

  6334.   REAL                :: QTHROS  !throughfall of snowfall (mm/s)
    6335. 

  6335.   REAL                :: QEVAC   !evaporation rate (mm/s)
    6336. 

  6336.   REAL                :: QDEWC   !dew rate (mm/s)
    6337. 

  6337.   REAL                :: QFROC   !frost rate (mm/s)
    6338. 

  6338.   REAL                :: QSUBC   !sublimation rate (mm/s)
    6339. 

  6339.   REAL                :: FT      !temperature factor for unloading rate
    6340. 

  6340.   REAL                :: FV      !wind factor for unloading rate
    6341. 

  6341.   REAL                :: QMELTC  !melting rate of canopy snow (mm/s)
    6342. 

  6342.   REAL                :: QFRZC   !refreezing rate of canopy liquid water (mm/s)
    6343. 

  6343.   REAL                :: RAIN    !rainfall (mm/s)
    6344. 

  6344.   REAL                :: SNOW    !snowfall (mm/s)
    6345. 

  6345.   REAL                :: CANMAS  !total canopy mass (kg/m2)
    6346. 

  6346. ! --------------------------------------------------------------------
    6347. 

  6347. ! initialization
    6348. 

  6348. 

  6349.       FP      = 0.0
    6350. 

  6350.       RAIN    = 0.0
    6351. 

  6351.       SNOW    = 0.0 
    6352. 

  6352.       QINTR   = 0.
    6353. 

  6353.       QDRIPR  = 0.
    6354. 

  6354.       QTHROR  = 0.
    6355. 

  6355.       QINTR   = 0.
    6356. 

  6356.       QINTS   = 0.
    6357. 

  6357.       QDRIPS  = 0.0
    6358. 

  6358.       QTHROS  = 0.
    6359. 

  6359.       QRAIN   = 0.0
    6360. 

  6360.       QSNOW   = 0.0
    6361. 

  6361.       SNOWHIN = 0.0
    6362. 

  6362.       ECAN    = 0.0
    6363. 

  6363. ! --------------------------------------------------------------------
    6364. 

  6364. ! partition precipitation into rain and snow.
    6365. 

  6365. 

  6366. ! Jordan (1991)
    6367. 

  6367. 

  6368.      IF(OPT_SNF == 1) THEN
    6369. 

  6369.        IF(SFCTMP > TFRZ+2.5)THEN
    6370. 

  6370.            FPICE = 0.
    6371. 

  6371.        ELSE
    6372. 

  6372.          IF(SFCTMP <= TFRZ+0.5)THEN
    6373. 

  6373.            FPICE = 1.0
    6374. 

  6374.          ELSE IF(SFCTMP <= TFRZ+2.)THEN
    6375. 

  6375.            FPICE = 1.-(-54.632 + 0.2*SFCTMP)
    6376. 

  6376.          ELSE
    6377. 

  6377.            FPICE = 0.6
    6378. 

  6378.          ENDIF
    6379. 

  6379.        ENDIF
    6380. 

  6380.      ENDIF
    6381. 

  6381. 

  6382.      IF(OPT_SNF == 2) THEN
    6383. 

  6383.        IF(SFCTMP >= TFRZ+2.2) THEN
    6384. 

  6384.            FPICE = 0.
    6385. 

  6385.        ELSE
    6386. 

  6386.            FPICE = 1.0
    6387. 

  6387.        ENDIF
    6388. 

  6388.      ENDIF
    6389. 

  6389. 

  6390.      IF(OPT_SNF == 3) THEN
    6391. 

  6391.        IF(SFCTMP >= TFRZ) THEN
    6392. 

  6392.            FPICE = 0.
    6393. 

  6393.        ELSE
    6394. 

  6394.            FPICE = 1.0
    6395. 

  6395.        ENDIF
    6396. 

  6396.      ENDIF
    6397. 

  6397. 

  6398. ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625
    6399. 

  6399. ! fresh snow density
    6400. 

  6400. 

  6401.      BDFALL = MAX(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59))
    6402. 

  6402. 

  6403.      RAIN   = (QPRECC + QPRECL) * (1.-FPICE)
    6404. 

  6404.      SNOW   = (QPRECC + QPRECL) * FPICE
    6405. 

  6405. 

  6406. ! fractional area that receives precipitation (see, Niu et al. 2005)
    6407. 

  6407.    
    6408. 

  6408.     IF(QPRECC + QPRECL > 0.) & 
    6409. 

  6409.        FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL)
    6410. 

  6410. 

  6411. ! --------------------------- liquid water ------------------------------
    6412. 

  6412. ! maximum canopy water
    6413. 

  6413. 

  6414.       MAXLIQ =  CH2OP(VEGTYP) * (ELAI+ ESAI)
    6415. 

  6415. 

  6416. ! average interception and throughfall
    6417. 

  6417. 

  6418.       IF((ELAI+ ESAI).GT.0.) THEN
    6419. 

  6419.          QINTR  = FVEG * RAIN * FP  ! interception capability
    6420. 

  6420.          QINTR  = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) )
    6421. 

  6421.          QINTR  = MAX(QINTR, 0.)
    6422. 

  6422.          QDRIPR = FVEG * RAIN - QINTR
    6423. 

  6423.          QTHROR = (1.-FVEG) * RAIN
    6424. 

  6424.       ELSE
    6425. 

  6425.          QINTR  = 0.
    6426. 

  6426.          QDRIPR = 0.
    6427. 

  6427.          QTHROR = RAIN
    6428. 

  6428.       END IF
    6429. 

  6429. 

  6430. ! evaporation, transpiration, and dew
    6431. 

  6431. 

  6432.       IF (TV .GT. TFRZ) THEN
    6433. 

  6433.         ETRAN = MAX( FCTR/HVAP, 0. )
    6434. 

  6434.         QEVAC = MAX( FCEV/HVAP, 0. )
    6435. 

  6435.         QDEWC = ABS( MIN( FCEV/HVAP, 0. ) )
    6436. 

  6436.         QSUBC = 0.
    6437. 

  6437.         QFROC = 0.
    6438. 

  6438.       ELSE
    6439. 

  6439.         ETRAN = MAX( FCTR/HSUB, 0. )
    6440. 

  6440.         QEVAC = 0.
    6441. 

  6441.         QDEWC = 0.
    6442. 

  6442.         QSUBC = MAX( FCEV/HSUB, 0. )
    6443. 

  6443.         QFROC = ABS( MIN( FCEV/HSUB, 0. ) )
    6444. 

  6444.       ENDIF
    6445. 

  6445. 

  6446. ! canopy water balance. for convenience allow dew to bring CANLIQ above
    6447. 

  6447. ! maxh2o or else would have to re-adjust drip
    6448. 

  6448. 

  6449.        QEVAC = MIN(CANLIQ/DT,QEVAC)
    6450. 

  6450.        CANLIQ=MAX(0.,CANLIQ+(QINTR+QDEWC-QEVAC)*DT)
    6451. 

  6451.        IF(CANLIQ <= 1.E-06) CANLIQ = 0.0
    6452. 

  6452. 

  6453. ! --------------------------- canopy ice ------------------------------
    6454. 

  6454. ! for canopy ice
    6455. 

  6455. 

  6456.       MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI)
    6457. 

  6457. 

  6458.       IF((ELAI+ ESAI).GT.0.) THEN
    6459. 

  6459.          QINTS = FVEG * SNOW * FP
    6460. 

  6460.          QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) )
    6461. 

  6461.          QINTS = MAX(QINTS, 0.)
    6462. 

  6462.          FT = MAX(0.0,(TV - 270.15) / 1.87E5)
    6463. 

  6463.          FV = SQRT(UU*UU + VV*VV) / 1.56E5
    6464. 

  6464.          QDRIPS = MAX(0.,CANICE/DT) * (FV+FT)
    6465. 

  6465.          QTHROS = (1.0-FVEG) * SNOW + (FVEG * SNOW - QINTS)
    6466. 

  6466.       ELSE
    6467. 

  6467.          QINTS  = 0.
    6468. 

  6468.          QDRIPS = 0.
    6469. 

  6469.          QTHROS = SNOW
    6470. 

  6470.       ENDIF
    6471. 

  6471. 

  6472.       QSUBC = MIN(CANICE/DT,QSUBC) 
    6473. 

  6473.       CANICE= MAX(0.,CANICE+(QINTS-QDRIPS)*DT + (QFROC-QSUBC)*DT)
    6474. 

  6474.       IF(CANICE.LE.1.E-6) CANICE = 0.
    6475. 

  6475.      
    6476. 

  6476. ! wetted fraction of canopy
    6477. 

  6477. 

  6478.       IF(CANICE.GT.0.) THEN
    6479. 

  6479.            FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06)
    6480. 

  6480.       ELSE
    6481. 

  6481.            FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06)
    6482. 

  6482.       ENDIF
    6483. 

  6483.       FWET = MIN(FWET, 1.) ** 0.667
    6484. 

  6484. 

  6485. ! phase change
    6486. 

  6486. 

  6487.       QMELTC = 0.
    6488. 

  6488.       QFRZC = 0.
    6489. 

  6489. 

  6490.       IF(CANICE.GT.1.E-6.AND.TV.GT.TFRZ) THEN
    6491. 

  6491.          QMELTC = MIN(CANICE/DT,(TV-TFRZ)*CICE*CANICE/DENICE/(DT*HFUS))
    6492. 

  6492.          CANICE = MAX(0.,CANICE - QMELTC*DT)
    6493. 

  6493.          CANLIQ = MAX(0.,CANLIQ + QMELTC*DT)
    6494. 

  6494.          TV     = FWET*TFRZ + (1.-FWET)*TV
    6495. 

  6495.       ENDIF
    6496. 

  6496. 

  6497.       IF(CANLIQ.GT.1.E-6.AND.TV.LT.TFRZ) THEN
    6498. 

  6498.          QFRZC  = MIN(CANLIQ/DT,(TFRZ-TV)*CWAT*CANLIQ/DENH2O/(DT*HFUS))
    6499. 

  6499.          CANLIQ = MAX(0.,CANLIQ - QFRZC*DT)
    6500. 

  6500.          CANICE = MAX(0.,CANICE + QFRZC*DT)
    6501. 

  6501.          TV     = FWET*TFRZ + (1.-FWET)*TV
    6502. 

  6502.       ENDIF
    6503. 

  6503. 

  6504. ! total canopy water
    6505. 

  6505. 

  6506.       CMC = CANLIQ + CANICE
    6507. 

  6507. 

  6508. ! total canopy evaporation
    6509. 

  6509. 

  6510.       ECAN = QEVAC + QSUBC - QDEWC - QFROC
    6511. 

  6511. 

  6512. ! rain or snow on the ground
    6513. 

  6513. 

  6514.       QRAIN   = QDRIPR + QTHROR
    6515. 

  6515.       QSNOW   = QDRIPS + QTHROS
    6516. 

  6516.       SNOWHIN = QSNOW/BDFALL
    6517. 

  6517. 

  6518. 

  6519.       IF (IST == 2 .AND. TG > TFRZ) THEN
    6520. 

  6520.          QSNOW   = 0.
    6521. 

  6521.          SNOWHIN = 0.
    6522. 

  6522.       END IF
    6523. 

  6523. 

  6524.   END SUBROUTINE CANWATER
    6525. 

  6525. ! ==================================================================================================
    6526. 

  6526. ! ----------------------------------------------------------------------
    6527. 

  6527.   SUBROUTINE SNOWWATER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,ZSOIL  , & !in
    6528. 

  6528.                         SFCTMP ,SNOWHIN,QSNOW  ,QSNFRO ,QSNSUB , & !in
    6529. 

  6529.                         QRAIN  ,FICEOLD,ILOC   ,JLOC   ,         & !in
    6530. 

  6530.                         ISNOW  ,SNOWH  ,SNEQV  ,SNICE  ,SNLIQ  , & !inout
    6531. 

  6531.                         SH2O   ,SICE   ,STC    ,ZSNSO  ,DZSNSO , & !inout
    6532. 

  6532.                         QSNBOT ,SNOFLOW,PONDING1       ,PONDING2)  !out
    6533. 

  6533. ! ----------------------------------------------------------------------
    6534. 

  6534.   IMPLICIT NONE
    6535. 

  6535. ! ----------------------------------------------------------------------
    6536. 

  6536. ! input
    6537. 

  6537.   INTEGER,                         INTENT(IN)    :: ILOC   !grid index
    6538. 

  6538.   INTEGER,                         INTENT(IN)    :: JLOC   !grid index
    6539. 

  6539.   INTEGER,                         INTENT(IN)    :: NSNOW  !maximum no. of snow layers
    6540. 

  6540.   INTEGER,                         INTENT(IN)    :: NSOIL  !no. of soil layers
    6541. 

  6541.   INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN)    :: IMELT  !melting state index [0-no melt;1-melt]
    6542. 

  6542.   REAL,                            INTENT(IN)    :: DT     !time step (s)
    6543. 

  6543.   REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: ZSOIL  !depth of layer-bottom from soil surface
    6544. 

  6544.   REAL,                            INTENT(IN)    :: SFCTMP !surface air temperature [k]
    6545. 

  6545.   REAL,                            INTENT(IN)    :: SNOWHIN!snow depth increasing rate (m/s)
    6546. 

  6546.   REAL,                            INTENT(IN)    :: QSNOW  !snow at ground srf (mm/s) [+]
    6547. 

  6547.   REAL,                            INTENT(IN)    :: QSNFRO !snow surface frost rate[mm/s]
    6548. 

  6548.   REAL,                            INTENT(IN)    :: QSNSUB !snow surface sublimation rate[mm/s]
    6549. 

  6549.   REAL,                            INTENT(IN)    :: QRAIN  !snow surface rain rate[mm/s]
    6550. 

  6550.   REAL, DIMENSION(-NSNOW+1:0)    , INTENT(IN)    :: FICEOLD!ice fraction at last timestep
    6551. 

  6551. 

  6552. ! input & output
    6553. 

  6553.   INTEGER,                         INTENT(INOUT) :: ISNOW  !actual no. of snow layers
    6554. 

  6554.   REAL,                            INTENT(INOUT) :: SNOWH  !snow height [m]
    6555. 

  6555.   REAL,                            INTENT(INOUT) :: SNEQV  !snow water eqv. [mm]
    6556. 

  6556.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE  !snow layer ice [mm]
    6557. 

  6557.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ  !snow layer liquid water [mm]
    6558. 

  6558.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O   !soil liquid moisture (m3/m3)
    6559. 

  6559.   REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SICE   !soil ice moisture (m3/m3)
    6560. 

  6560.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC    !snow layer temperature [k]
    6561. 

  6561.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO  !depth of snow/soil layer-bottom
    6562. 

  6562.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m]
    6563. 

  6563. 

  6564. ! output
    6565. 

  6565.   REAL,                              INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s]
    6566. 

  6566.   REAL,                              INTENT(OUT) :: SNOFLOW!glacier flow [mm]
    6567. 

  6567.   REAL,                              INTENT(OUT) :: PONDING1
    6568. 

  6568.   REAL,                              INTENT(OUT) :: PONDING2
    6569. 

  6569. 

  6570. ! local
    6571. 

  6571.   INTEGER :: IZ,i
    6572. 

  6572.   REAL    :: BDSNOW  !bulk density of snow (kg/m3)
    6573. 

  6573. ! ----------------------------------------------------------------------
    6574. 

  6574.    SNOFLOW = 0.0
    6575. 

  6575.    PONDING1 = 0.0
    6576. 

  6576.    PONDING2 = 0.0
    6577. 

  6577. 

  6578.    CALL SNOWFALL (NSOIL  ,NSNOW  ,DT     ,QSNOW  ,SNOWHIN, & !in
    6579. 

  6579.                   SFCTMP ,ILOC   ,JLOC   ,                 & !in
    6580. 

  6580.                   ISNOW  ,SNOWH  ,DZSNSO ,STC    ,SNICE  , & !inout
    6581. 

  6581.                   SNLIQ  ,SNEQV  )                           !inout
    6582. 

  6582. 

  6583.    if(isnow < 0) then        !when more than one layer
    6584. 

  6584.    CALL  COMPACT (NSNOW  ,NSOIL  ,DT     ,STC    ,SNICE  , & !in
    6585. 

  6585.                   SNLIQ  ,ZSOIL  ,IMELT  ,FICEOLD,ILOC   , JLOC ,& !in
    6586. 

  6586.                   ISNOW  ,DZSNSO ,ZSNSO  )                   !inout
    6587. 

  6587. 

  6588.    CALL  COMBINE (NSNOW  ,NSOIL  ,ILOC   ,JLOC   ,         & !in
    6589. 

  6589.                   ISNOW  ,SH2O   ,STC    ,SNICE  ,SNLIQ  , & !inout
    6590. 

  6590.                   DZSNSO ,SICE   ,SNOWH  ,SNEQV  ,         & !inout
    6591. 

  6591.                   PONDING1       ,PONDING2)                  !out
    6592. 

  6592. 

  6593.    CALL   DIVIDE (NSNOW  ,NSOIL  ,                         & !in
    6594. 

  6594.                   ISNOW  ,STC    ,SNICE  ,SNLIQ  ,DZSNSO )   !inout
    6595. 

  6595.    end if
    6596. 

  6596. 

  6597. !set empty snow layers to zero
    6598. 

  6598. 

  6599.    do iz = -nsnow+1, isnow
    6600. 

  6600.         snice(iz) = 0.
    6601. 

  6601.         snliq(iz) = 0.
    6602. 

  6602.         stc(iz)   = 0.
    6603. 

  6603.         dzsnso(iz)= 0.
    6604. 

  6604.         zsnso(iz) = 0.
    6605. 

  6605.    enddo
    6606. 

  6606. 

  6607.    CALL  SNOWH2O (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in 
    6608. 

  6608.                   QRAIN  ,ILOC   ,JLOC   ,                 & !in
    6609. 

  6609.                   ISNOW  ,DZSNSO ,SNOWH  ,SNEQV  ,SNICE  , & !inout
    6610. 

  6610.                   SNLIQ  ,SH2O   ,SICE   ,STC    ,         & !inout
    6611. 

  6611.                   QSNBOT ,PONDING1       ,PONDING2)           !out
    6612. 

  6612. 

  6613. !to obtain equilibrium state of snow in glacier region
    6614. 

  6614.        
    6615. 

  6615.    IF(SNEQV > 2000.) THEN   ! 2000 mm -> maximum water depth
    6616. 

  6616.       BDSNOW      = SNICE(0) / DZSNSO(0)
    6617. 

  6617.       SNOFLOW     = (SNEQV - 2000.)
    6618. 

  6618.       SNICE(0)    = SNICE(0)  - SNOFLOW 
    6619. 

  6619.       DZSNSO(0)   = DZSNSO(0) - SNOFLOW/BDSNOW
    6620. 

  6620.       SNOFLOW     = SNOFLOW / DT
    6621. 

  6621.    END IF
    6622. 

  6622. 

  6623. ! sum up snow mass for layered snow
    6624. 

  6624. 

  6625.    IF(ISNOW /= 0) THEN
    6626. 

  6626.        SNEQV = 0.
    6627. 

  6627.        DO IZ = ISNOW+1,0
    6628. 

  6628.              SNEQV = SNEQV + SNICE(IZ) + SNLIQ(IZ)
    6629. 

  6629.        ENDDO
    6630. 

  6630.    END IF
    6631. 

  6631. 

  6632. ! Reset ZSNSO and layer thinkness DZSNSO
    6633. 

  6633. 

  6634.    DO IZ = ISNOW+1, 0
    6635. 

  6635.         DZSNSO(IZ) = -DZSNSO(IZ)
    6636. 

  6636.    END DO
    6637. 

  6637. 

  6638.    DZSNSO(1) = ZSOIL(1)
    6639. 

  6639.    DO IZ = 2,NSOIL
    6640. 

  6640.         DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1))
    6641. 

  6641.    END DO
    6642. 

  6642. 

  6643.    ZSNSO(ISNOW+1) = DZSNSO(ISNOW+1)
    6644. 

  6644.    DO IZ = ISNOW+2 ,NSOIL
    6645. 

  6645.        ZSNSO(IZ) = ZSNSO(IZ-1) + DZSNSO(IZ)
    6646. 

  6646.    ENDDO
    6647. 

  6647. 

  6648.    DO IZ = ISNOW+1 ,NSOIL
    6649. 

  6649.        DZSNSO(IZ) = -DZSNSO(IZ)
    6650. 

  6650.    END DO
    6651. 

  6651. 

  6652.   END SUBROUTINE SNOWWATER
    6653. 

  6653. ! ==================================================================================================
    6654. 

  6654.   SUBROUTINE SNOWFALL (NSOIL  ,NSNOW  ,DT     ,QSNOW  ,SNOWHIN , & !in
    6655. 

  6655.                        SFCTMP ,ILOC   ,JLOC   ,                  & !in
    6656. 

  6656.                        ISNOW  ,SNOWH  ,DZSNSO ,STC    ,SNICE   , & !inout
    6657. 

  6657.                        SNLIQ  ,SNEQV  )                            !inout
    6658. 

  6658. ! ----------------------------------------------------------------------
    6659. 

  6659. ! snow depth and density to account for the new snowfall.
    6660. 

  6660. ! new values of snow depth & density returned.
    6661. 

  6661. ! ----------------------------------------------------------------------
    6662. 

  6662.     IMPLICIT NONE
    6663. 

  6663. ! ----------------------------------------------------------------------
    6664. 

  6664. ! input
    6665. 

  6665. 

  6666.   INTEGER,                            INTENT(IN) :: ILOC   !grid index
    6667. 

  6667.   INTEGER,                            INTENT(IN) :: JLOC   !grid index
    6668. 

  6668.   INTEGER,                            INTENT(IN) :: NSOIL  !no. of soil layers
    6669. 

  6669.   INTEGER,                            INTENT(IN) :: NSNOW  !maximum no. of snow layers
    6670. 

  6670.   REAL,                               INTENT(IN) :: DT     !main time step (s)
    6671. 

  6671.   REAL,                               INTENT(IN) :: QSNOW  !snow at ground srf (mm/s) [+]
    6672. 

  6672.   REAL,                               INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s)
    6673. 

  6673.   REAL,                               INTENT(IN) :: SFCTMP !surface air temperature [k]
    6674. 

  6674. 

  6675. ! input and output
    6676. 

  6676. 

  6677.   INTEGER,                         INTENT(INOUT) :: ISNOW  !actual no. of snow layers
    6678. 

  6678.   REAL,                            INTENT(INOUT) :: SNOWH  !snow depth [m]
    6679. 

  6679.   REAL,                            INTENT(INOUT) :: SNEQV  !swow water equivalent [m]
    6680. 

  6680.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !thickness of snow/soil layers (m)
    6681. 

  6681.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC    !snow layer temperature [k]
    6682. 

  6682.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE  !snow layer ice [mm]
    6683. 

  6683.   REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ  !snow layer liquid water [mm]
    6684. 

  6684. 

  6685. ! local
    6686. 

  6686. 

  6687.   INTEGER :: NEWNODE            ! 0-no new layers, 1-creating new layers
    6688. 

  6688. ! ----------------------------------------------------------------------
    6689. 

  6689.     NEWNODE  = 0
    6690. 

  6690. 

  6691. ! shallow snow / no layer
    6692. 

  6692. 

  6693.     IF(ISNOW == 0 .and. QSNOW > 0.)  THEN
    6694. 

  6694.       SNOWH = SNOWH + SNOWHIN * DT
    6695. 

  6695.       SNEQV = SNEQV + QSNOW * DT
    6696. 

  6696.     END IF
    6697. 

  6697. 

  6698. ! creating a new layer
    6699. 

  6699.  
    6700. 

  6700.     IF(ISNOW == 0  .AND. QSNOW>0. .AND. SNOWH >= 0.05) THEN
    6701. 

  6701.       ISNOW    = -1
    6702. 

  6702.       NEWNODE  =  1
    6703. 

  6703.       DZSNSO(0)= SNOWH
    6704. 

  6704.       SNOWH    = 0.
    6705. 

  6705.       STC(0)   = MIN(273.16, SFCTMP)   ! temporary setup
    6706. 

  6706.       SNICE(0) = SNEQV
    6707. 

  6707.       SNLIQ(0) = 0.
    6708. 

  6708.     END IF
    6709. 

  6709. 

  6710. ! snow with layers
    6711. 

  6711. 

  6712.     IF(ISNOW <  0 .AND. NEWNODE == 0 .AND. QSNOW > 0.) then
    6713. 

  6713.          SNICE(ISNOW+1)  = SNICE(ISNOW+1)   + QSNOW   * DT
    6714. 

  6714.          DZSNSO(ISNOW+1) = DZSNSO(ISNOW+1)  + SNOWHIN * DT
    6715. 

  6715.     ENDIF
    6716. 

  6716. 

  6717. ! ----------------------------------------------------------------------
    6718. 

  6718.   END SUBROUTINE SNOWFALL
    6719. 

  6719. ! ==================================================================================================
    6720. 

  6720.   SUBROUTINE COMBINE (NSNOW  ,NSOIL  ,ILOC   ,JLOC   ,         & !in
    6721. 

  6721.                       ISNOW  ,SH2O   ,STC    ,SNICE  ,SNLIQ  , & !inout
    6722. 

  6722.                       DZSNSO ,SICE   ,SNOWH  ,SNEQV  ,         & !inout
    6723. 

  6723.                       PONDING1       ,PONDING2)                  !out
    6724. 

  6724. ! ----------------------------------------------------------------------
    6725. 

  6725.     IMPLICIT NONE
    6726. 

  6726. ! ----------------------------------------------------------------------
    6727. 

  6727. ! input
    6728. 

  6728. 

  6729.     INTEGER, INTENT(IN)     :: ILOC
    6730. 

  6730.     INTEGER, INTENT(IN)     :: JLOC
    6731. 

  6731.     INTEGER, INTENT(IN)     :: NSNOW                        !maximum no. of snow layers
    6732. 

  6732.     INTEGER, INTENT(IN)     :: NSOIL                        !no. of soil layers
    6733. 

  6733. 

  6734. ! input and output
    6735. 

  6735. 

  6736.     INTEGER,                         INTENT(INOUT) :: ISNOW !actual no. of snow layers
    6737. 

  6737.     REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O  !soil liquid moisture (m3/m3)
    6738. 

  6738.     REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SICE  !soil ice moisture (m3/m3)
    6739. 

  6739.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC   !snow layer temperature [k]
    6740. 

  6740.     REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE !snow layer ice [mm]
    6741. 

  6741.     REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm]
    6742. 

  6742.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m]
    6743. 

  6743.     REAL,                            INTENT(INOUT) :: sneqv !snow water equivalent [m]
    6744. 

  6744.     REAL,                            INTENT(INOUT) :: snowh !snow depth [m]
    6745. 

  6745.     REAL,                            INTENT(OUT) :: PONDING1
    6746. 

  6746.     REAL,                            INTENT(OUT) :: PONDING2
    6747. 

  6747. 

  6748. ! local variables:
    6749. 

  6749. 

  6750.     INTEGER :: I,J,K,L               ! node indices
    6751. 

  6751.     INTEGER :: ISNOW_OLD             ! number of top snow layer
    6752. 

  6752.     INTEGER :: MSSI                  ! node index
    6753. 

  6753.     INTEGER :: NEIBOR                ! adjacent node selected for combination
    6754. 

  6754.     REAL    :: ZWICE                 ! total ice mass in snow
    6755. 

  6755.     REAL    :: ZWLIQ                 ! total liquid water in snow
    6756. 

  6756. 

  6757.     REAL    :: DZMIN(3)              ! minimum of top snow layer
    6758. 

  6758.     DATA DZMIN /0.045, 0.05, 0.2/
    6759. 

  6759. !-----------------------------------------------------------------------
    6760. 

  6760. 

  6761.        ISNOW_OLD = ISNOW
    6762. 

  6762. 

  6763.        DO J = ISNOW_OLD+1,0
    6764. 

  6764.           IF (SNICE(J) <= .1) THEN
    6765. 

  6765.              IF(J /= 0) THEN
    6766. 

  6766.                 SNLIQ(J+1) = SNLIQ(J+1) + SNLIQ(J)
    6767. 

  6767.                 SNICE(J+1) = SNICE(J+1) + SNICE(J)
    6768. 

  6768.              ELSE
    6769. 

  6769.                IF (ISNOW_OLD < -1) THEN
    6770. 

  6770.                 SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J)
    6771. 

  6771.                 SNICE(J-1) = SNICE(J-1) + SNICE(J)
    6772. 

  6772.                ELSE
    6773. 

  6773.                 PONDING1 = SNLIQ(J)       ! ISNOW WILL GET SET TO ZERO BELOW
    6774. 

  6774.                 SNEQV = SNICE(J)          ! PONDING WILL GET ADDED TO PONDING FROM
    6775. 

  6775.                 SNOWH = DZSNSO(J)         ! PHASECHANGE WHICH SHOULD BE ZERO HERE
    6776. 

  6776.                 SNLIQ(J) = 0.0            ! BECAUSE THERE IT WAS ONLY CALCULATED
    6777. 

  6777.                 SNICE(J) = 0.0            ! FOR THIN SNOW
    6778. 

  6778.                 DZSNSO(J) = 0.0
    6779. 

  6779.                ENDIF
    6780. 

  6780. !                SH2O(1) = SH2O(1)+SNLIQ(J)/(DZSNSO(1)*1000.)
    6781. 

  6781. !                SICE(1) = SICE(1)+SNICE(J)/(DZSNSO(1)*1000.)
    6782. 

  6782.              ENDIF
    6783. 

  6783. 

  6784.              ! shift all elements above this down by one.
    6785. 

  6785.              IF (J > ISNOW+1 .AND. ISNOW < -1) THEN
    6786. 

  6786.                 DO I = J, ISNOW+2, -1
    6787. 

  6787.                    STC(I)   = STC(I-1)
    6788. 

  6788.                    SNLIQ(I) = SNLIQ(I-1)
    6789. 

  6789.                    SNICE(I) = SNICE(I-1)
    6790. 

  6790.                    DZSNSO(I)= DZSNSO(I-1)
    6791. 

  6791.                 END DO
    6792. 

  6792.              END IF
    6793. 

  6793.              ISNOW = ISNOW + 1
    6794. 

  6794.           END IF
    6795. 

  6795.        END DO
    6796. 

  6796. 

  6797. ! to conserve water in case of too large surface sublimation
    6798. 

  6798. 

  6799.        IF(SICE(1) < 0.) THEN
    6800. 

  6800.           SH2O(1) = SH2O(1) + SICE(1)
    6801. 

  6801.           SICE(1) = 0.
    6802. 

  6802.        END IF
    6803. 

  6803. 

  6804.        SNEQV  = 0.
    6805. 

  6805.        SNOWH  = 0.
    6806. 

  6806.        ZWICE  = 0.
    6807. 

  6807.        ZWLIQ  = 0.
    6808. 

  6808. 

  6809.        DO J = ISNOW+1,0
    6810. 

  6810.              SNEQV = SNEQV + SNICE(J) + SNLIQ(J)
    6811. 

  6811.              SNOWH = SNOWH + DZSNSO(J)
    6812. 

  6812.              ZWICE = ZWICE + SNICE(J)
    6813. 

  6813.              ZWLIQ = ZWLIQ + SNLIQ(J)
    6814. 

  6814.        END DO
    6815. 

  6815. 

  6816. ! check the snow depth - all snow gone
    6817. 

  6817. ! the liquid water assumes ponding on soil surface.
    6818. 

  6818. 

  6819.        IF (SNOWH < 0.05 .AND. ISNOW < 0 ) THEN
    6820. 

  6820.           ISNOW  = 0
    6821. 

  6821.           SNEQV = ZWICE
    6822. 

  6822.           PONDING2 = ZWLIQ           ! LIMIT OF ISNOW < 0 MEANS INPUT PONDING
    6823. 

  6823.           IF(SNEQV <= 0.) SNOWH = 0. ! SHOULD BE ZERO; SEE ABOVE
    6824. 

  6824.        END IF
    6825. 

  6825. 

  6826. !       IF (SNOWH < 0.05 ) THEN
    6827. 

  6827. !          ISNOW  = 0
    6828. 

  6828. !          SNEQV = ZWICE
    6829. 

  6829. !          SH2O(1) = SH2O(1) + ZWLIQ / (DZSNSO(1) * 1000.)
    6830. 

  6830. !          IF(SNEQV <= 0.) SNOWH = 0.
    6831. 

  6831. !       END IF
    6832. 

  6832. 

  6833. ! check the snow depth - snow layers combined
    6834. 

  6834. 

  6835.        IF (ISNOW < -1) THEN
    6836. 

  6836. 

  6837.           ISNOW_OLD = ISNOW
    6838. 

  6838.           MSSI     = 1
    6839. 

  6839. 

  6840.           DO I = ISNOW_OLD+1,0
    6841. 

  6841.              IF (DZSNSO(I) < DZMIN(MSSI)) THEN
    6842. 

  6842. 

  6843.                 IF (I == ISNOW+1) THEN
    6844. 

  6844.                    NEIBOR = I + 1
    6845. 

  6845.                 ELSE IF (I == 0) THEN
    6846. 

  6846.                    NEIBOR = I - 1
    6847. 

  6847.                 ELSE
    6848. 

  6848.                    NEIBOR = I + 1
    6849. 

  6849.                    IF ((DZSNSO(I-1)+DZSNSO(I)) < (DZSNSO(I+1)+DZSNSO(I))) NEIBOR = I-1
    6850. 

  6850.                 END IF
    6851. 

  6851. 

  6852.                 ! Node l and j are combined and stored as node j.
    6853. 

  6853.                 IF (NEIBOR > I) THEN
    6854. 

  6854.                    J = NEIBOR
    6855. 

  6855.                    L = I
    6856. 

  6856.                 ELSE
    6857. 

  6857.                    J = I
    6858. 

  6858.                    L = NEIBOR
    6859. 

  6859.                 END IF
    6860. 

  6860. 

  6861.                 CALL COMBO (DZSNSO(J), SNLIQ(J), SNICE(J), &
    6862. 

  6862.                    STC(J), DZSNSO(L), SNLIQ(L), SNICE(L), STC(L) )
    6863. 

  6863. 

  6864.                 ! Now shift all elements above this down one.
    6865. 

  6865.                 IF (J-1 > ISNOW+1) THEN
    6866. 

  6866.                    DO K = J-1, ISNOW+2, -1
    6867. 

  6867.                       STC(K)   = STC(K-1)
    6868. 

  6868.                       SNICE(K) = SNICE(K-1)
    6869. 

  6869.                       SNLIQ(K) = SNLIQ(K-1)
    6870. 

  6870.                       DZSNSO(K) = DZSNSO(K-1)
    6871. 

  6871.                    END DO
    6872. 

  6872.                 END IF
    6873. 

  6873. 

  6874.                 ! Decrease the number of snow layers
    6875. 

  6875.                 ISNOW = ISNOW + 1
    6876. 

  6876.                 IF (ISNOW >= -1) EXIT
    6877. 

  6877.              ELSE
    6878. 

  6878. 

  6879.                 ! The layer thickness is greater than the prescribed minimum value
    6880. 

  6880.                 MSSI = MSSI + 1
    6881. 

  6881. 

  6882.              END IF
    6883. 

  6883.           END DO
    6884. 

  6884. 

  6885.        END IF
    6886. 

  6886. 

  6887.   END SUBROUTINE COMBINE
    6888. 

  6888. ! ==================================================================================================
    6889. 

  6889.   SUBROUTINE DIVIDE (NSNOW  ,NSOIL  ,                         & !in
    6890. 

  6890.                      ISNOW  ,STC    ,SNICE  ,SNLIQ  ,DZSNSO  )  !inout
    6891. 

  6891. ! ----------------------------------------------------------------------
    6892. 

  6892.     IMPLICIT NONE
    6893. 

  6893. ! ----------------------------------------------------------------------
    6894. 

  6894. ! input
    6895. 

  6895. 

  6896.     INTEGER, INTENT(IN)                            :: NSNOW !maximum no. of snow layers [ =3]
    6897. 

  6897.     INTEGER, INTENT(IN)                            :: NSOIL !no. of soil layers [ =4]
    6898. 

  6898. 

  6899. ! input and output
    6900. 

  6900. 

  6901.     INTEGER                        , INTENT(INOUT) :: ISNOW !actual no. of snow layers 
    6902. 

  6902.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC   !snow layer temperature [k]
    6903. 

  6903.     REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNICE !snow layer ice [mm]
    6904. 

  6904.     REAL, DIMENSION(-NSNOW+1:    0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm]
    6905. 

  6905.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m]
    6906. 

  6906. 

  6907. ! local variables:
    6908. 

  6908. 

  6909.     INTEGER                                        :: J     !indices
    6910. 

  6910.     INTEGER                                        :: MSNO  !number of layer (top) to MSNO (bot)
    6911. 

  6911.     REAL                                           :: DRR   !thickness of the combined [m]
    6912. 

  6912.     REAL, DIMENSION(       1:NSNOW)                :: DZ    !snow layer thickness [m]
    6913. 

  6913.     REAL, DIMENSION(       1:NSNOW)                :: SWICE !partial volume of ice [m3/m3]
    6914. 

  6914.     REAL, DIMENSION(       1:NSNOW)                :: SWLIQ !partial volume of liquid water [m3/m3]
    6915. 

  6915.     REAL, DIMENSION(       1:NSNOW)                :: TSNO  !node temperature [k]
    6916. 

  6916.     REAL                                           :: ZWICE !temporary
    6917. 

  6917.     REAL                                           :: ZWLIQ !temporary
    6918. 

  6918.     REAL                                           :: PROPOR!temporary
    6919. 

  6919.     REAL                                           :: DTDZ  !temporary
    6920. 

  6920. ! ----------------------------------------------------------------------
    6921. 

  6921. 

  6922.     DO J = 1,NSNOW
    6923. 

  6923.           IF (J <= ABS(ISNOW)) THEN
    6924. 

  6924.              DZ(J)    = DZSNSO(J+ISNOW)
    6925. 

  6925.              SWICE(J) = SNICE(J+ISNOW)
    6926. 

  6926.              SWLIQ(J) = SNLIQ(J+ISNOW)
    6927. 

  6927.              TSNO(J)  = STC(J+ISNOW)
    6928. 

  6928.           END IF
    6929. 

  6929.     END DO
    6930. 

  6930. 

  6931.        MSNO = ABS(ISNOW)
    6932. 

  6932. 

  6933.        IF (MSNO == 1) THEN
    6934. 

  6934.           ! Specify a new snow layer
    6935. 

  6935.           IF (DZ(1) > 0.05) THEN
    6936. 

  6936.              MSNO = 2
    6937. 

  6937.              DZ(1)    = DZ(1)/2.
    6938. 

  6938.              SWICE(1) = SWICE(1)/2.
    6939. 

  6939.              SWLIQ(1) = SWLIQ(1)/2.
    6940. 

  6940.              DZ(2)    = DZ(1)
    6941. 

  6941.              SWICE(2) = SWICE(1)
    6942. 

  6942.              SWLIQ(2) = SWLIQ(1)
    6943. 

  6943.              TSNO(2)  = TSNO(1)
    6944. 

  6944.           END IF
    6945. 

  6945.        END IF
    6946. 

  6946. 

  6947.        IF (MSNO > 1) THEN
    6948. 

  6948.           IF (DZ(1) > 0.05) THEN
    6949. 

  6949.              DRR      = DZ(1) - 0.05
    6950. 

  6950.              PROPOR   = DRR/DZ(1)
    6951. 

  6951.              ZWICE    = PROPOR*SWICE(1)
    6952. 

  6952.              ZWLIQ    = PROPOR*SWLIQ(1)
    6953. 

  6953.              PROPOR   = 0.05/DZ(1)
    6954. 

  6954.              SWICE(1) = PROPOR*SWICE(1)
    6955. 

  6955.              SWLIQ(1) = PROPOR*SWLIQ(1)
    6956. 

  6956.              DZ(1)    = 0.05
    6957. 

  6957. 

  6958.              CALL COMBO (DZ(2), SWLIQ(2), SWICE(2), TSNO(2), DRR, &
    6959. 

  6959.                   ZWLIQ, ZWICE, TSNO(1))
    6960. 

  6960. 

  6961.              ! subdivide a new layer
    6962. 

  6962.              IF (MSNO <= 2 .AND. DZ(2) > 0.10) THEN
    6963. 

  6963.                 MSNO = 3
    6964. 

  6964.                 DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.)
    6965. 

  6965.                 DZ(2)    = DZ(2)/2.
    6966. 

  6966.                 SWICE(2) = SWICE(2)/2.
    6967. 

  6967.                 SWLIQ(2) = SWLIQ(2)/2.
    6968. 

  6968.                 DZ(3)    = DZ(2)
    6969. 

  6969.                 SWICE(3) = SWICE(2)
    6970. 

  6970.                 SWLIQ(3) = SWLIQ(2)
    6971. 

  6971.                 TSNO(3) = TSNO(2) - DTDZ*DZ(2)/2.
    6972. 

  6972.                 IF (TSNO(3) >= TFRZ) THEN
    6973. 

  6973.                    TSNO(3)  = TSNO(2)
    6974. 

  6974.                 ELSE
    6975. 

  6975.                    TSNO(2) = TSNO(2) + DTDZ*DZ(2)/2.
    6976. 

  6976.                 ENDIF
    6977. 

  6977. 

  6978.              END IF
    6979. 

  6979.           END IF
    6980. 

  6980.        END IF
    6981. 

  6981. 

  6982.        IF (MSNO > 2) THEN
    6983. 

  6983.           IF (DZ(2) > 0.2) THEN
    6984. 

  6984.              DRR = DZ(2) - 0.2
    6985. 

  6985.              PROPOR   = DRR/DZ(2)
    6986. 

  6986.              ZWICE    = PROPOR*SWICE(2)
    6987. 

  6987.              ZWLIQ    = PROPOR*SWLIQ(2)
    6988. 

  6988.              PROPOR   = 0.2/DZ(2)
    6989. 

  6989.              SWICE(2) = PROPOR*SWICE(2)
    6990. 

  6990.              SWLIQ(2) = PROPOR*SWLIQ(2)
    6991. 

  6991.              DZ(2)    = 0.2
    6992. 

  6992.              CALL COMBO (DZ(3), SWLIQ(3), SWICE(3), TSNO(3), DRR, &
    6993. 

  6993.                   ZWLIQ, ZWICE, TSNO(2))
    6994. 

  6994.           END IF
    6995. 

  6995.        END IF
    6996. 

  6996. 

  6997.        ISNOW = -MSNO
    6998. 

  6998. 

  6999.     DO J = ISNOW+1,0
    7000. 

  7000.              DZSNSO(J) = DZ(J-ISNOW)
    7001. 

  7001.              SNICE(J) = SWICE(J-ISNOW)
    7002. 

  7002.              SNLIQ(J) = SWLIQ(J-ISNOW)
    7003. 

  7003.              STC(J)   = TSNO(J-ISNOW)
    7004. 

  7004.     END DO
    7005. 

  7005. 

  7006. 

  7007. !    DO J = ISNOW+1,NSOIL
    7008. 

  7008. !    WRITE(*,'(I5,7F10.3)') J, DZSNSO(J), SNICE(J), SNLIQ(J),STC(J)
    7009. 

  7009. !    END DO
    7010. 

  7010. 

  7011.   END SUBROUTINE DIVIDE
    7012. 

  7012. ! ==================================================================================================
    7013. 

  7013. 

  7014. ! ----------------------------------------------------------------------
    7015. 

  7015.   SUBROUTINE COMBO(DZ,  WLIQ,  WICE, T, DZ2, WLIQ2, WICE2, T2)
    7016. 

  7016. ! ----------------------------------------------------------------------
    7017. 

  7017.     IMPLICIT NONE
    7018. 

  7018. ! ----------------------------------------------------------------------
    7019. 

  7019. 

  7020. ! ----------------------------------------------------------------------s
    7021. 

  7021. ! input
    7022. 

  7022. 

  7023.     REAL, INTENT(IN)    :: DZ2   !nodal thickness of 2 elements being combined [m]
    7024. 

  7024.     REAL, INTENT(IN)    :: WLIQ2 !liquid water of element 2 [kg/m2]
    7025. 

  7025.     REAL, INTENT(IN)    :: WICE2 !ice of element 2 [kg/m2]
    7026. 

  7026.     REAL, INTENT(IN)    :: T2    !nodal temperature of element 2 [k]
    7027. 

  7027.     REAL, INTENT(INOUT) :: DZ    !nodal thickness of 1 elements being combined [m]
    7028. 

  7028.     REAL, INTENT(INOUT) :: WLIQ  !liquid water of element 1
    7029. 

  7029.     REAL, INTENT(INOUT) :: WICE  !ice of element 1 [kg/m2]
    7030. 

  7030.     REAL, INTENT(INOUT) :: T     !node temperature of element 1 [k]
    7031. 

  7031. 

  7032. ! local 
    7033. 

  7033. 

  7034.     REAL                :: DZC   !total thickness of nodes 1 and 2 (DZC=DZ+DZ2).
    7035. 

  7035.     REAL                :: WLIQC !combined liquid water [kg/m2]
    7036. 

  7036.     REAL                :: WICEC !combined ice [kg/m2]
    7037. 

  7037.     REAL                :: TC    !combined node temperature [k]
    7038. 

  7038.     REAL                :: H     !enthalpy of element 1 [J/m2]
    7039. 

  7039.     REAL                :: H2    !enthalpy of element 2 [J/m2]
    7040. 

  7040.     REAL                :: HC    !temporary
    7041. 

  7041. 

  7042. !-----------------------------------------------------------------------
    7043. 

  7043. 

  7044.     DZC = DZ+DZ2
    7045. 

  7045.     WICEC = (WICE+WICE2)
    7046. 

  7046.     WLIQC = (WLIQ+WLIQ2)
    7047. 

  7047.     H = (CICE*WICE+CWAT*WLIQ) * (T-TFRZ)+HFUS*WLIQ
    7048. 

  7048.     H2= (CICE*WICE2+CWAT*WLIQ2) * (T2-TFRZ)+HFUS*WLIQ2
    7049. 

  7049. 

  7050.     HC = H + H2
    7051. 

  7051.     IF(HC < 0.)THEN
    7052. 

  7052.        TC = TFRZ + HC/(CICE*WICEC + CWAT*WLIQC)
    7053. 

  7053.     ELSE IF (HC.LE.HFUS*WLIQC) THEN
    7054. 

  7054.        TC = TFRZ
    7055. 

  7055.     ELSE
    7056. 

  7056.        TC = TFRZ + (HC - HFUS*WLIQC) / (CICE*WICEC + CWAT*WLIQC)
    7057. 

  7057.     END IF
    7058. 

  7058. 

  7059.     DZ = DZC
    7060. 

  7060.     WICE = WICEC
    7061. 

  7061.     WLIQ = WLIQC
    7062. 

  7062.     T = TC
    7063. 

  7063. 

  7064.   END SUBROUTINE COMBO
    7065. 

  7065. ! ==================================================================================================
    7066. 

  7066. ! ----------------------------------------------------------------------
    7067. 

  7067.   SUBROUTINE COMPACT (NSNOW  ,NSOIL  ,DT     ,STC    ,SNICE  , & !in
    7068. 

  7068.                       SNLIQ  ,ZSOIL  ,IMELT  ,FICEOLD,ILOC   , JLOC , & !in
    7069. 

  7069.                       ISNOW  ,DZSNSO ,ZSNSO )                    !inout
    7070. 

  7070. ! ----------------------------------------------------------------------
    7071. 

  7071. ! ----------------------------------------------------------------------
    7072. 

  7072.   IMPLICIT NONE
    7073. 

  7073. ! ----------------------------------------------------------------------
    7074. 

  7074. ! input
    7075. 

  7075.    INTEGER,                         INTENT(IN)    :: ILOC   !grid index
    7076. 

  7076.    INTEGER,                         INTENT(IN)    :: JLOC   !grid index
    7077. 

  7077.    INTEGER,                         INTENT(IN)    :: NSOIL  !no. of soil layers [ =4]
    7078. 

  7078.    INTEGER,                         INTENT(IN)    :: NSNOW  !maximum no. of snow layers [ =3]
    7079. 

  7079.    INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN)    :: IMELT  !melting state index [0-no melt;1-melt]
    7080. 

  7080.    REAL,                            INTENT(IN)    :: DT     !time step (sec)
    7081. 

  7081.    REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN)    :: STC    !snow layer temperature [k]
    7082. 

  7082.    REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)    :: SNICE  !snow layer ice [mm]
    7083. 

  7083.    REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)    :: SNLIQ  !snow layer liquid water [mm]
    7084. 

  7084.    REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: ZSOIL  !depth of layer-bottom from soil srf
    7085. 

  7085.    REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)    :: FICEOLD!ice fraction at last timestep
    7086. 

  7086. 

  7087. ! input and output
    7088. 

  7088.    INTEGER,                         INTENT(INOUT) :: ISNOW  ! actual no. of snow layers
    7089. 

  7089.    REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer thickness [m]
    7090. 

  7090.    REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO  ! depth of snow/soil layer-bottom
    7091. 

  7091. 

  7092. ! local
    7093. 

  7093.    REAL, PARAMETER     :: C2 = 21.e-3   ![m3/kg] ! default 21.e-3
    7094. 

  7094.    REAL, PARAMETER     :: C3 = 2.5e-6   ![1/s]  
    7095. 

  7095.    REAL, PARAMETER     :: C4 = 0.04     ![1/k]
    7096. 

  7096.    REAL, PARAMETER     :: C5 = 2.0      !
    7097. 

  7097.    REAL, PARAMETER     :: DM = 100.0    !upper Limit on destructive metamorphism compaction [kg/m3]
    7098. 

  7098.    REAL, PARAMETER     :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] 
    7099. 

  7099.                                         !according to Anderson, it is between 0.52e6~1.38e6
    7100. 

  7100.    REAL :: BURDEN !pressure of overlying snow [kg/m2]
    7101. 

  7101.    REAL :: DDZ1   !rate of settling of snow pack due to destructive metamorphism.
    7102. 

  7102.    REAL :: DDZ2   !rate of compaction of snow pack due to overburden.
    7103. 

  7103.    REAL :: DDZ3   !rate of compaction of snow pack due to melt [1/s]
    7104. 

  7104.    REAL :: DEXPF  !EXPF=exp(-c4*(273.15-STC)).
    7105. 

  7105.    REAL :: TD     !STC - TFRZ [K]
    7106. 

  7106.    REAL :: PDZDTC !nodal rate of change in fractional-thickness due to compaction [fraction/s]
    7107. 

  7107.    REAL :: VOID   !void (1 - SNICE - SNLIQ)
    7108. 

  7108.    REAL :: WX     !water mass (ice + liquid) [kg/m2]
    7109. 

  7109.    REAL :: BI     !partial density of ice [kg/m3]
    7110. 

  7110.    REAL, DIMENSION(-NSNOW+1:0) :: FICE   !fraction of ice at current time step
    7111. 

  7111. 

  7112.    INTEGER  :: J
    7113. 

  7113. 

  7114. ! ----------------------------------------------------------------------
    7115. 

  7115.     BURDEN = 0.0
    7116. 

  7116. 

  7117.     DO J = ISNOW+1, 0
    7118. 

  7118. 

  7119.         WX      = SNICE(J) + SNLIQ(J)
    7120. 

  7120.         FICE(J) = SNICE(J) / WX
    7121. 

  7121.         VOID    = 1. - (SNICE(J)/DENICE + SNLIQ(J)/DENH2O) / DZSNSO(J)
    7122. 

  7122. 

  7123.         ! Allow compaction only for non-saturated node and higher ice lens node.
    7124. 

  7124.         IF (VOID > 0.001 .AND. SNICE(J) > 0.1) THEN
    7125. 

  7125.            BI = SNICE(J) / DZSNSO(J)
    7126. 

  7126.            TD = MAX(0.,TFRZ-STC(J))
    7127. 

  7127.            DEXPF = EXP(-C4*TD)
    7128. 

  7128. 

  7129.            ! Settling as a result of destructive metamorphism
    7130. 

  7130. 

  7131.            DDZ1 = -C3*DEXPF
    7132. 

  7132. 

  7133.            IF (BI > DM) DDZ1 = DDZ1*EXP(-46.0E-3*(BI-DM))
    7134. 

  7134. 

  7135.            ! Liquid water term
    7136. 

  7136. 

  7137.            IF (SNLIQ(J) > 0.01*DZSNSO(J)) DDZ1=DDZ1*C5
    7138. 

  7138. 

  7139.            ! Compaction due to overburden
    7140. 

  7140. 

  7141.            DDZ2 = -(BURDEN+0.5*WX)*EXP(-0.08*TD-C2*BI)/ETA0 ! 0.5*WX -> self-burden
    7142. 

  7142. 

  7143.            ! Compaction occurring during melt
    7144. 

  7144. 

  7145.            IF (IMELT(J) == 1) THEN
    7146. 

  7146.               DDZ3 = MAX(0.,(FICEOLD(J) - FICE(J))/MAX(1.E-6,FICEOLD(J)))
    7147. 

  7147.               DDZ3 = - DDZ3/DT           ! sometimes too large
    7148. 

  7148.            ELSE
    7149. 

  7149.               DDZ3 = 0.
    7150. 

  7150.            END IF
    7151. 

  7151. 

  7152.            ! Time rate of fractional change in DZ (units of s-1)
    7153. 

  7153. 

  7154.            PDZDTC = (DDZ1 + DDZ2 + DDZ3)*DT
    7155. 

  7155.            PDZDTC = MAX(-0.5,PDZDTC)
    7156. 

  7156. 

  7157.            ! The change in DZ due to compaction
    7158. 

  7158. 

  7159.            DZSNSO(J) = DZSNSO(J)*(1.+PDZDTC)
    7160. 

  7160.         END IF
    7161. 

  7161. 

  7162.         ! Pressure of overlying snow
    7163. 

  7163. 

  7164.         BURDEN = BURDEN + WX
    7165. 

  7165. 

  7166.     END DO
    7167. 

  7167. 

  7168.   END SUBROUTINE COMPACT
    7169. 

  7169. ! ==================================================================================================
    7170. 

  7170.   SUBROUTINE SNOWH2O (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in 
    7171. 

  7171.                       QRAIN  ,ILOC   ,JLOC   ,                 & !in
    7172. 

  7172.                       ISNOW  ,DZSNSO ,SNOWH  ,SNEQV  ,SNICE  , & !inout
    7173. 

  7173.                       SNLIQ  ,SH2O   ,SICE   ,STC    ,         & !inout
    7174. 

  7174.                       QSNBOT ,PONDING1       ,PONDING2)          !out
    7175. 

  7175. ! ----------------------------------------------------------------------
    7176. 

  7176. ! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the
    7177. 

  7177. ! surface snow layer resulting from sublimation (frost) / evaporation (dew)
    7178. 

  7178. ! ----------------------------------------------------------------------
    7179. 

  7179.    IMPLICIT NONE
    7180. 

  7180. ! ----------------------------------------------------------------------
    7181. 

  7181. ! input
    7182. 

  7182. 

  7183.    INTEGER,                         INTENT(IN)    :: ILOC   !grid index
    7184. 

  7184.    INTEGER,                         INTENT(IN)    :: JLOC   !grid index
    7185. 

  7185.    INTEGER,                         INTENT(IN)    :: NSNOW  !maximum no. of snow layers[=3]
    7186. 

  7186.    INTEGER,                         INTENT(IN)    :: NSOIL  !No. of soil layers[=4]
    7187. 

  7187.    REAL,                            INTENT(IN)    :: DT     !time step
    7188. 

  7188.    REAL,                            INTENT(IN)    :: QSNFRO !snow surface frost rate[mm/s]
    7189. 

  7189.    REAL,                            INTENT(IN)    :: QSNSUB !snow surface sublimation rate[mm/s]
    7190. 

  7190.    REAL,                            INTENT(IN)    :: QRAIN  !snow surface rain rate[mm/s]
    7191. 

  7191. 

  7192. ! output
    7193. 

  7193. 

  7194.    REAL,                            INTENT(OUT)   :: QSNBOT !melting water out of snow bottom [mm/s]
    7195. 

  7195. 

  7196. ! input and output
    7197. 

  7197. 

  7198.    INTEGER,                         INTENT(INOUT) :: ISNOW  !actual no. of snow layers
    7199. 

  7199.    REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer depth [m]
    7200. 

  7200.    REAL,                            INTENT(INOUT) :: SNOWH  !snow height [m]
    7201. 

  7201.    REAL,                            INTENT(INOUT) :: SNEQV  !snow water eqv. [mm]
    7202. 

  7202.    REAL, DIMENSION(-NSNOW+1:0),     INTENT(INOUT) :: SNICE  !snow layer ice [mm]
    7203. 

  7203.    REAL, DIMENSION(-NSNOW+1:0),     INTENT(INOUT) :: SNLIQ  !snow layer liquid water [mm]
    7204. 

  7204.    REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O   !soil liquid moisture (m3/m3)
    7205. 

  7205.    REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SICE   !soil ice moisture (m3/m3)
    7206. 

  7206.    REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC    !snow layer temperature [k]
    7207. 

  7207. 

  7208. ! local variables:
    7209. 

  7209. 

  7210.    INTEGER                     :: J         !do loop/array indices
    7211. 

  7211.    REAL                        :: QIN       !water flow into the element (mm/s)
    7212. 

  7212.    REAL                        :: QOUT      !water flow out of the element (mm/s)
    7213. 

  7213.    REAL                        :: WGDIF     !ice mass after minus sublimation
    7214. 

  7214.    REAL, DIMENSION(-NSNOW+1:0) :: VOL_LIQ   !partial volume of liquid water in layer
    7215. 

  7215.    REAL, DIMENSION(-NSNOW+1:0) :: VOL_ICE   !partial volume of ice lens in layer
    7216. 

  7216.    REAL, DIMENSION(-NSNOW+1:0) :: EPORE     !effective porosity = porosity - VOL_ICE
    7217. 

  7217.    REAL :: PROPOR, TEMP
    7218. 

  7218.    REAL :: PONDING1, PONDING2
    7219. 

  7219. ! ----------------------------------------------------------------------
    7220. 

  7220. 

  7221. !for the case when SNEQV becomes '0' after 'COMBINE'
    7222. 

  7222. 

  7223.    IF(SNEQV == 0.) THEN
    7224. 

  7224.       SH2O(1) =  SH2O(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.)
    7225. 

  7225.    END IF
    7226. 

  7226. 

  7227. ! for shallow snow without a layer
    7228. 

  7228. ! snow surface sublimation may be larger than existing snow mass. To conserve water,
    7229. 

  7229. ! excessive sublimation is used to reduce soil water. Smaller time steps would tend 
    7230. 

  7230. ! to aviod this problem.
    7231. 

  7231. 

  7232.    IF(ISNOW == 0 .and. SNEQV > 0.) THEN
    7233. 

  7233.       TEMP   = SNEQV
    7234. 

  7234.       SNEQV  = SNEQV - QSNSUB*DT + QSNFRO*DT
    7235. 

  7235.       PROPOR = SNEQV/TEMP
    7236. 

  7236.       SNOWH  = MAX(0.,PROPOR * SNOWH)
    7237. 

  7237. 

  7238.       IF(SNEQV < 0.) THEN
    7239. 

  7239.          SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.)
    7240. 

  7240.          SNEQV   = 0.
    7241. 

  7241.       END IF
    7242. 

  7242.       IF(SICE(1) < 0.) THEN
    7243. 

  7243.          SH2O(1) = SH2O(1) + SICE(1)
    7244. 

  7244.          SICE(1) = 0.
    7245. 

  7245.       END IF
    7246. 

  7246.    END IF
    7247. 

  7247. 

  7248.    IF(SNOWH <= 1.E-8) SNOWH = 0.0
    7249. 

  7249.    IF(SNEQV <= 1.E-6) SNEQV = 0.0
    7250. 

  7250. 

  7251. ! for deep snow
    7252. 

  7252. 

  7253.    IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references
    7254. 

  7254. 

  7255.       WGDIF = SNICE(ISNOW+1) - QSNSUB*DT + QSNFRO*DT
    7256. 

  7256.       SNICE(ISNOW+1) = WGDIF
    7257. 

  7257.       IF (WGDIF < 1.e-6 .and. ISNOW <0) THEN
    7258. 

  7258.          CALL  COMBINE (NSNOW  ,NSOIL  ,ILOC, JLOC   , & !in
    7259. 

  7259.               ISNOW  ,SH2O   ,STC    ,SNICE  ,SNLIQ  , & !inout
    7260. 

  7260.               DZSNSO ,SICE   ,SNOWH  ,SNEQV  ,         & !inout
    7261. 

  7261.               PONDING1, PONDING2 )                       !out
    7262. 

  7262.       ENDIF
    7263. 

  7263.       !KWM:  Subroutine COMBINE can change ISNOW to make it 0 again?
    7264. 

  7264.       IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references
    7265. 

  7265.          SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT
    7266. 

  7266.          SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1))
    7267. 

  7267.       ENDIF
    7268. 

  7268.       
    7269. 

  7269.    ENDIF !KWM  -- Can the ENDIF be moved toward the end of the subroutine (Just set QSNBOT=0)?
    7270. 

  7270. 

  7271. ! Porosity and partial volume
    7272. 

  7272. 

  7273.    !KWM Looks to me like loop index / IF test can be simplified.
    7274. 

  7274. 

  7275.    DO J = -NSNOW+1, 0
    7276. 

  7276.       IF (J >= ISNOW+1) THEN
    7277. 

  7277.          VOL_ICE(J)      = MIN(1., SNICE(J)/(DZSNSO(J)*DENICE))
    7278. 

  7278.          EPORE(J)        = 1. - VOL_ICE(J)
    7279. 

  7279.          VOL_LIQ(J)      = MIN(EPORE(J),SNLIQ(J)/(DZSNSO(J)*DENH2O))
    7280. 

  7280.       END IF
    7281. 

  7281.    END DO
    7282. 

  7282. 

  7283.    QIN = 0.
    7284. 

  7284.    QOUT = 0.
    7285. 

  7285. 

  7286.    !KWM Looks to me like loop index / IF test can be simplified.
    7287. 

  7287. 

  7288.    DO J = -NSNOW+1, 0
    7289. 

  7289.       IF (J >= ISNOW+1) THEN
    7290. 

  7290.          SNLIQ(J) = SNLIQ(J) + QIN
    7291. 

  7291.          IF (J <= -1) THEN
    7292. 

  7292.             IF (EPORE(J) < 0.05 .OR. EPORE(J+1) < 0.05) THEN
    7293. 

  7293.                QOUT = 0.
    7294. 

  7294.             ELSE
    7295. 

  7295.                QOUT = MAX(0.,(VOL_LIQ(J)-SSI*EPORE(J))*DZSNSO(J))
    7296. 

  7296.                QOUT = MIN(QOUT,(1.-VOL_ICE(J+1)-VOL_LIQ(J+1))*DZSNSO(J+1))
    7297. 

  7297.             END IF
    7298. 

  7298.          ELSE
    7299. 

  7299.             QOUT = MAX(0.,(VOL_LIQ(J) - SSI*EPORE(J))*DZSNSO(J))
    7300. 

  7300.          END IF
    7301. 

  7301.          QOUT = QOUT*1000.
    7302. 

  7302.          SNLIQ(J) = SNLIQ(J) - QOUT
    7303. 

  7303.          QIN = QOUT
    7304. 

  7304.       END IF
    7305. 

  7305.    END DO
    7306. 

  7306. 

  7307. ! Liquid water from snow bottom to soil
    7308. 

  7308. 

  7309.    QSNBOT = QOUT / DT           ! mm/s
    7310. 

  7310. 

  7311.   END SUBROUTINE SNOWH2O
    7312. 

  7312. ! ==================================================================================================
    7313. 

  7313.   SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
    7314. 

  7314.                         QINSUR ,QSEVA  ,ETRANI ,SICE   ,ILOC   , JLOC, & !in
    7315. 

  7315.                         SH2O   ,SMC    ,ZWT    ,ISURBAN,VEGTYP ,& !inout
    7316. 

  7316.                         RUNSRF ,QDRAIN ,RUNSUB ,WCND   ,FCRMAX )   !out
    7317. 

  7317. 

  7318. ! ----------------------------------------------------------------------
    7319. 

  7319. ! calculate surface runoff and soil moisture.
    7320. 

  7320. ! ----------------------------------------------------------------------
    7321. 

  7321. ! ----------------------------------------------------------------------
    7322. 

  7322.   IMPLICIT NONE
    7323. 

  7323. ! ----------------------------------------------------------------------
    7324. 

  7324. ! input
    7325. 

  7325.   INTEGER,                     INTENT(IN) :: ILOC   !grid index
    7326. 

  7326.   INTEGER,                     INTENT(IN) :: JLOC   !grid index
    7327. 

  7327.   INTEGER,                     INTENT(IN) :: NSOIL  !no. of soil layers
    7328. 

  7328.   INTEGER,                     INTENT(IN) :: NSNOW  !maximum no. of snow layers
    7329. 

  7329.   REAL,                        INTENT(IN) :: DT     !time step (sec)
    7330. 

  7330.   REAL, INTENT(IN)                        :: QINSUR !water input on soil surface [mm/s]
    7331. 

  7331.   REAL, INTENT(IN)                        :: QSEVA  !evap from soil surface [mm/s]
    7332. 

  7332.   REAL, DIMENSION(1:NSOIL),    INTENT(IN) :: ZSOIL  !depth of soil layer-bottom [m]
    7333. 

  7333.   REAL, DIMENSION(1:NSOIL),    INTENT(IN) :: ETRANI !evapotranspiration from soil layers [mm/s]
    7334. 

  7334.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m]
    7335. 

  7335.   REAL, DIMENSION(1:NSOIL), INTENT(IN)   :: SICE   !soil ice content [m3/m3]
    7336. 

  7336. 

  7337.   INTEGER,                     INTENT(IN) :: VEGTYP
    7338. 

  7338.   INTEGER,                     INTENT(IN) :: ISURBAN
    7339. 

  7339. 

  7340. ! input & output
    7341. 

  7341.   REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O   !soil liquid water content [m3/m3]
    7342. 

  7342.   REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC    !total soil water content [m3/m3]
    7343. 

  7343.   REAL, INTENT(INOUT)                     :: ZWT    !water table depth [m]
    7344. 

  7344. 

  7345. ! output
    7346. 

  7346.   REAL, INTENT(OUT)                       :: QDRAIN !soil-bottom free drainage [mm/s] 
    7347. 

  7347.   REAL, INTENT(OUT)                       :: RUNSRF !surface runoff [mm/s] 
    7348. 

  7348.   REAL, INTENT(OUT)                       :: RUNSUB !subsurface runoff [mm/s] 
    7349. 

  7349.   REAL, INTENT(OUT)                       :: FCRMAX !maximum of FCR (-)
    7350. 

  7350.   REAL, DIMENSION(1:NSOIL), INTENT(OUT)   :: WCND   !hydraulic conductivity (m/s)
    7351. 

  7351. 

  7352. ! local
    7353. 

  7353.   INTEGER                                 :: K,IZ   !do-loop index
    7354. 

  7354.   INTEGER                                 :: ITER   !iteration index
    7355. 

  7355.   REAl                                    :: DTFINE !fine time step (s)
    7356. 

  7356.   REAL, DIMENSION(1:NSOIL)                :: RHSTT  !right-hand side term of the matrix
    7357. 

  7357.   REAL, DIMENSION(1:NSOIL)                :: AI     !left-hand side term
    7358. 

  7358.   REAL, DIMENSION(1:NSOIL)                :: BI     !left-hand side term
    7359. 

  7359.   REAL, DIMENSION(1:NSOIL)                :: CI     !left-hand side term
    7360. 

  7360. 

  7361.   REAL                                    :: FFF    !runoff decay factor (m-1)
    7362. 

  7362.   REAL                                    :: RSBMX  !baseflow coefficient [mm/s]
    7363. 

  7363.   REAL                                    :: PDDUM  !infiltration rate at surface (m/s)
    7364. 

  7364.   REAL                                    :: FICE   !ice fraction in frozen soil
    7365. 

  7365.   REAL                                    :: WPLUS  !saturation excess of the total soil [m]
    7366. 

  7366.   REAL                                    :: RSAT   !accumulation of WPLUS (saturation excess) [m]
    7367. 

  7367.   REAL                                    :: SICEMAX!maximum soil ice content (m3/m3)
    7368. 

  7368.   REAL                                    :: SH2OMIN!minimum soil liquid water content (m3/m3)
    7369. 

  7369.   REAL                                    :: WTSUB  !sum of WCND(K)*DZSNSO(K)
    7370. 

  7370.   REAL                                    :: MH2O   !water mass removal (mm)
    7371. 

  7371.   REAL                                    :: FSAT   !fractional saturated area (-)
    7372. 

  7372.   REAL, DIMENSION(1:NSOIL)                :: MLIQ   !
    7373. 

  7373.   REAL                                    :: XS     !
    7374. 

  7374.   REAL                                    :: WATMIN !
    7375. 

  7375.   REAL                                    :: EPORE  !effective porosity [m3/m3]
    7376. 

  7376.   REAL, DIMENSION(1:NSOIL)                :: FCR    !impermeable fraction due to frozen soil
    7377. 

  7377.   INTEGER                                 :: NITER  !iteration times soil moisture (-)
    7378. 

  7378.   REAL                                    :: SMCTOT !2-m averaged soil moisture (m3/m3)
    7379. 

  7379.   REAL                                    :: DZTOT  !2-m soil depth (m)
    7380. 

  7380.   REAL, PARAMETER :: A = 4.0
    7381. 

  7381. ! ----------------------------------------------------------------------
    7382. 

  7382.     RUNSRF = 0.0
    7383. 

  7383.     PDDUM  = 0.0
    7384. 

  7384.     RSAT   = 0.0
    7385. 

  7385. 

  7386. ! for the case when snowmelt water is too large
    7387. 

  7387. 

  7388.     DO K = 1,NSOIL
    7389. 

  7389.        EPORE   = MAX ( 1.E-4 , ( SMCMAX - SICE(K) ) )
    7390. 

  7390.        RSAT    = RSAT + MAX(0.,SH2O(K)-EPORE)*DZSNSO(K)  
    7391. 

  7391.        SH2O(K) = MIN(EPORE,SH2O(K))             
    7392. 

  7392.     END DO
    7393. 

  7393. 

  7394. !impermeable fraction due to frozen soil
    7395. 

  7395. 

  7396.     DO K = 1,NSOIL
    7397. 

  7397.        FICE    = MIN(1.0,SICE(K)/SMCMAX)
    7398. 

  7398.        FCR(K)  = MAX(0.0,EXP(-A*(1.-FICE))- EXP(-A)) /  &
    7399. 

  7399.                         (1.0              - EXP(-A))
    7400. 

  7400.     END DO
    7401. 

  7401. 

  7402. ! maximum soil ice content and minimum liquid water of all layers
    7403. 

  7403. 

  7404.     SICEMAX = 0.0
    7405. 

  7405.     FCRMAX  = 0.0
    7406. 

  7406.     SH2OMIN = SMCMAX
    7407. 

  7407.     DO K = 1,NSOIL
    7408. 

  7408.        IF (SICE(K) > SICEMAX) SICEMAX = SICE(K)
    7409. 

  7409.        IF (FCR(K)  > FCRMAX)  FCRMAX  = FCR(K)
    7410. 

  7410.        IF (SH2O(K) < SH2OMIN) SH2OMIN = SH2O(K)
    7411. 

  7411.     END DO
    7412. 

  7412. 

  7413. !subsurface runoff for runoff scheme option 2
    7414. 

  7414. 

  7415.     IF(OPT_RUN == 2) THEN 
    7416. 

  7416.         FFF   = 2.0
    7417. 

  7417.         RSBMX = 4.0
    7418. 

  7418.         CALL ZWTEQ (NSOIL  ,NSNOW  ,ZSOIL  ,DZSNSO ,SH2O   ,ZWT)
    7419. 

  7419.         RUNSUB = (1.0-FCRMAX) * RSBMX * EXP(-TIMEAN) * EXP(-FFF*ZWT)   ! mm/s
    7420. 

  7420.     END IF
    7421. 

  7421. 

  7422. !surface runoff and infiltration rate using different schemes
    7423. 

  7423. 

  7424. !jref impermable surface at urban
    7425. 

  7425.     IF ( VEGTYP == ISURBAN ) FCR(1)= 0.95
    7426. 

  7426. 

  7427.     IF(OPT_RUN == 1) THEN
    7428. 

  7428.        FFF = 6.0
    7429. 

  7429.        FSAT   = FSATMX*EXP(-0.5*FFF*(ZWT-2.0))
    7430. 

  7430.        IF(QINSUR > 0.) THEN
    7431. 

  7431.          RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) )
    7432. 

  7432.          PDDUM  = QINSUR - RUNSRF                          ! m/s 
    7433. 

  7433.        END IF
    7434. 

  7434.     END IF
    7435. 

  7435. 

  7436.     IF(OPT_RUN == 2) THEN
    7437. 

  7437.        FFF   = 2.0
    7438. 

  7438.        FSAT   = FSATMX*EXP(-0.5*FFF*ZWT)
    7439. 

  7439.        IF(QINSUR > 0.) THEN
    7440. 

  7440.          RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) )
    7441. 

  7441.          PDDUM  = QINSUR - RUNSRF                          ! m/s 
    7442. 

  7442.        END IF
    7443. 

  7443.     END IF
    7444. 

  7444. 

  7445.     IF(OPT_RUN == 3) THEN
    7446. 

  7446.        CALL INFIL (NSOIL  ,DT     ,ZSOIL  ,SH2O   ,SICE   , & !in
    7447. 

  7447.                    SICEMAX,QINSUR ,                         & !in
    7448. 

  7448.                    PDDUM  ,RUNSRF )                           !out
    7449. 

  7449.     END IF
    7450. 

  7450. 

  7451.     IF(OPT_RUN == 4) THEN
    7452. 

  7452.        SMCTOT = 0.
    7453. 

  7453.        DZTOT  = 0.
    7454. 

  7454.        DO K = 1,NSOIL
    7455. 

  7455.           DZTOT   = DZTOT  + DZSNSO(K)  
    7456. 

  7456.           SMCTOT  = SMCTOT + SMC(K)*DZSNSO(K)
    7457. 

  7457.           IF(DZTOT >= 2.0) EXIT
    7458. 

  7458.        END DO
    7459. 

  7459.        SMCTOT = SMCTOT/DZTOT
    7460. 

  7460.        FSAT   = MAX(0.01,SMCTOT/SMCMAX) ** 4.        !BATS
    7461. 

  7461. 

  7462.        IF(QINSUR > 0.) THEN
    7463. 

  7463.          RUNSRF = QINSUR * ((1.0-FCR(1))*FSAT+FCR(1))  
    7464. 

  7464.          PDDUM  = QINSUR - RUNSRF                       ! m/s
    7465. 

  7465.        END IF
    7466. 

  7466.     END IF
    7467. 

  7467. 

  7468. ! determine iteration times and finer time step
    7469. 

  7469. 

  7470.     NITER = 1
    7471. 

  7471. 

  7472.     IF(OPT_INF == 1) THEN    !OPT_INF =2 may cause water imbalance
    7473. 

  7473.        NITER = 3
    7474. 

  7474.        IF (PDDUM*DT>DZSNSO(1)*SMCMAX ) THEN
    7475. 

  7475.           NITER = NITER*2
    7476. 

  7476.        END IF
    7477. 

  7477.     END IF                 
    7478. 

  7478. 

  7479.     DTFINE  = DT / NITER
    7480. 

  7480. 

  7481. ! solve soil moisture
    7482. 

  7482. 

  7483.     DO ITER = 1, NITER
    7484. 

  7484.        CALL SRT   (NSOIL  ,ZSOIL  ,DTFINE ,PDDUM  ,ETRANI , & !in
    7485. 

  7485.                    QSEVA  ,SH2O   ,SMC    ,ZWT    ,FCR    , & !in
    7486. 

  7486.                    SICEMAX,FCRMAX ,ILOC   ,JLOC   ,         & !in
    7487. 

  7487.                    RHSTT  ,AI     ,BI     ,CI     ,QDRAIN , & !out
    7488. 

  7488.                    WCND   )                                   !out
    7489. 

  7489.   
    7490. 

  7490.        CALL SSTEP (NSOIL  ,NSNOW  ,DTFINE ,ZSOIL  ,DZSNSO , & !in
    7491. 

  7491.                    SICE   ,ILOC   ,JLOC   ,                 & !in
    7492. 

  7492.                    SH2O   ,SMC    ,AI     ,BI     ,CI     , & !inout
    7493. 

  7493.                    RHSTT  ,                                 & !inout
    7494. 

  7494.                    WPLUS)                                     !out
    7495. 

  7495.        RSAT =  RSAT + WPLUS
    7496. 

  7496.     END DO
    7497. 

  7497. 

  7498.     RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT  ! m/s -> mm/s
    7499. 

  7499.     QDRAIN = QDRAIN * 1000.
    7500. 

  7500. 

  7501. ! removal of soil water due to groundwater flow (option 2)
    7502. 

  7502. 

  7503.     IF(OPT_RUN == 2) THEN
    7504. 

  7504.          WTSUB = 0.
    7505. 

  7505.          DO K = 1, NSOIL
    7506. 

  7506.            WTSUB = WTSUB + WCND(K)*DZSNSO(K)
    7507. 

  7507.          END DO
    7508. 

  7508. 

  7509.          DO K = 1, NSOIL
    7510. 

  7510.            MH2O    = RUNSUB*DT*(WCND(K)*DZSNSO(K))/WTSUB       ! mm
    7511. 

  7511.            SH2O(K) = SH2O(K) - MH2O/(DZSNSO(K)*1000.)
    7512. 

  7512.          END DO
    7513. 

  7513.     END IF
    7514. 

  7514. 

  7515. ! Limit MLIQ to be greater than or equal to watmin.
    7516. 

  7516. ! Get water needed to bring MLIQ equal WATMIN from lower layer.
    7517. 

  7517. 

  7518.    IF(OPT_RUN /= 1) THEN
    7519. 

  7519.       DO IZ = 1, NSOIL
    7520. 

  7520.          MLIQ(IZ) = SH2O(IZ)*DZSNSO(IZ)*1000.
    7521. 

  7521.       END DO
    7522. 

  7522. 

  7523.       WATMIN = 0.01           ! mm
    7524. 

  7524.       DO IZ = 1, NSOIL-1
    7525. 

  7525.           IF (MLIQ(IZ) .LT. 0.) THEN
    7526. 

  7526.              XS = WATMIN-MLIQ(IZ)
    7527. 

  7527.           ELSE
    7528. 

  7528.              XS = 0.
    7529. 

  7529.           END IF
    7530. 

  7530.           MLIQ(IZ  ) = MLIQ(IZ  ) + XS
    7531. 

  7531.           MLIQ(IZ+1) = MLIQ(IZ+1) - XS
    7532. 

  7532.       END DO
    7533. 

  7533. 

  7534.         IZ = NSOIL
    7535. 

  7535.         IF (MLIQ(IZ) .LT. WATMIN) THEN
    7536. 

  7536.            XS = WATMIN-MLIQ(IZ)
    7537. 

  7537.         ELSE
    7538. 

  7538.            XS = 0.
    7539. 

  7539.         END IF
    7540. 

  7540.         MLIQ(IZ) = MLIQ(IZ) + XS
    7541. 

  7541.         RUNSUB   = RUNSUB - XS/DT
    7542. 

  7542. 

  7543.       DO IZ = 1, NSOIL
    7544. 

  7544.         SH2O(IZ)     = MLIQ(IZ) / (DZSNSO(IZ)*1000.)
    7545. 

  7545.       END DO
    7546. 

  7546.    END IF
    7547. 

  7547. 

  7548.   END SUBROUTINE SOILWATER
    7549. 

  7549. ! ==================================================================================================
    7550. 

  7550.   SUBROUTINE ZWTEQ (NSOIL  ,NSNOW  ,ZSOIL  ,DZSNSO ,SH2O   ,ZWT)
    7551. 

  7551. ! ----------------------------------------------------------------------
    7552. 

  7552. ! calculate equilibrium water table depth (Niu et al., 2005)
    7553. 

  7553. ! ----------------------------------------------------------------------
    7554. 

  7554.   IMPLICIT NONE
    7555. 

  7555. ! ----------------------------------------------------------------------
    7556. 

  7556. ! input
    7557. 

  7557. 

  7558.   INTEGER,                         INTENT(IN) :: NSOIL  !no. of soil layers
    7559. 

  7559.   INTEGER,                         INTENT(IN) :: NSNOW  !maximum no. of snow layers
    7560. 

  7560.   REAL, DIMENSION(1:NSOIL),        INTENT(IN) :: ZSOIL  !depth of soil layer-bottom [m]
    7561. 

  7561.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m]
    7562. 

  7562.   REAL, DIMENSION(1:NSOIL),        INTENT(IN) :: SH2O   !soil liquid water content [m3/m3]
    7563. 

  7563. 

  7564. ! output
    7565. 

  7565. 

  7566.   REAL,                           INTENT(OUT) :: ZWT    !water table depth [m]
    7567. 

  7567. 

  7568. ! locals
    7569. 

  7569. 

  7570.   INTEGER :: K                      !do-loop index
    7571. 

  7571.   INTEGER, PARAMETER :: NFINE = 100 !no. of fine soil layers of 6m soil
    7572. 

  7572.   REAL    :: WD1                    !water deficit from coarse (4-L) soil moisture profile
    7573. 

  7573.   REAL    :: WD2                    !water deficit from fine (100-L) soil moisture profile
    7574. 

  7574.   REAL    :: DZFINE                 !layer thickness of the 100-L soil layers to 6.0 m
    7575. 

  7575.   REAL    :: TEMP                   !temporary variable
    7576. 

  7576.   REAL, DIMENSION(1:NFINE) :: ZFINE !layer-bottom depth of the 100-L soil layers to 6.0 m
    7577. 

  7577. ! ----------------------------------------------------------------------
    7578. 

  7578. 

  7579.    WD1 = 0.
    7580. 

  7580.    DO K = 1,NSOIL
    7581. 

  7581.      WD1 = WD1 + (SMCMAX-SH2O(K)) * DZSNSO(K) ! [m]
    7582. 

  7582.    ENDDO
    7583. 

  7583. 

  7584.    DZFINE = 3.0 * (-ZSOIL(NSOIL)) / NFINE  
    7585. 

  7585.    do K =1,NFINE
    7586. 

  7586.       ZFINE(K) = FLOAT(K) * DZFINE
    7587. 

  7587.    ENDDO
    7588. 

  7588. 

  7589.    ZWT = -3.*ZSOIL(NSOIL) - 0.001   ! initial value [m]
    7590. 

  7590. 

  7591.    WD2 = 0.
    7592. 

  7592.    DO K = 1,NFINE
    7593. 

  7593.      TEMP  = 1. + (ZWT-ZFINE(K))/PSISAT
    7594. 

  7594.      WD2   = WD2 + SMCMAX*(1.-TEMP**(-1./BEXP))*DZFINE
    7595. 

  7595.      IF(ABS(WD2-WD1).LE.0.01) THEN
    7596. 

  7596.         ZWT = ZFINE(K)
    7597. 

  7597.         EXIT
    7598. 

  7598.      ENDIF
    7599. 

  7599.    ENDDO
    7600. 

  7600. 

  7601.   END SUBROUTINE ZWTEQ
    7602. 

  7602. ! ----------------------------------------------------------------------
    7603. 

  7603. ! ==================================================================================================
    7604. 

  7604.   SUBROUTINE INFIL (NSOIL  ,DT     ,ZSOIL  ,SH2O   ,SICE   , & !in
    7605. 

  7605.                     SICEMAX,QINSUR ,                         & !in
    7606. 

  7606.                     PDDUM  ,RUNSRF )                           !out
    7607. 

  7607. ! --------------------------------------------------------------------------------
    7608. 

  7608. ! compute inflitration rate at soil surface and surface runoff
    7609. 

  7609. ! --------------------------------------------------------------------------------
    7610. 

  7610.     IMPLICIT NONE
    7611. 

  7611. ! --------------------------------------------------------------------------------
    7612. 

  7612. ! inputs
    7613. 

  7613.   INTEGER,                  INTENT(IN) :: NSOIL  !no. of soil layers
    7614. 

  7614.   REAL,                     INTENT(IN) :: DT     !time step (sec)
    7615. 

  7615.   REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL  !depth of soil layer-bottom [m]
    7616. 

  7616.   REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O   !soil liquid water content [m3/m3]
    7617. 

  7617.   REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE   !soil ice content [m3/m3]
    7618. 

  7618.   REAL,                     INTENT(IN) :: QINSUR !water input on soil surface [mm/s]
    7619. 

  7619.   REAL,                     INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3)
    7620. 

  7620. 

  7621. ! outputs
    7622. 

  7622.   REAL,                    INTENT(OUT) :: RUNSRF !surface runoff [mm/s] 
    7623. 

  7623.   REAL,                    INTENT(OUT) :: PDDUM  !infiltration rate at surface
    7624. 

  7624. 

  7625. ! locals
    7626. 

  7626.   INTEGER :: IALP1, J, JJ,  K
    7627. 

  7627.   REAL                     :: VAL
    7628. 

  7628.   REAL                     :: DDT
    7629. 

  7629.   REAL                     :: PX
    7630. 

  7630.   REAL                     :: DT1, DD, DICE
    7631. 

  7631.   REAL                     :: FCR
    7632. 

  7632.   REAL                     :: SUM
    7633. 

  7633.   REAL                     :: ACRT
    7634. 

  7634.   REAL                     :: WDF
    7635. 

  7635.   REAL                     :: WCND
    7636. 

  7636.   REAL                     :: SMCAV
    7637. 

  7637.   REAL                     :: INFMAX
    7638. 

  7638.   REAL, DIMENSION(1:NSOIL) :: DMAX
    7639. 

  7639.   INTEGER, PARAMETER       :: CVFRZ = 3
    7640. 

  7640. ! --------------------------------------------------------------------------------
    7641. 

  7641. 

  7642.     IF (QINSUR >  0.0) THEN
    7643. 

  7643.        DT1 = DT /86400.
    7644. 

  7644.        SMCAV = SMCMAX - SMCWLT
    7645. 

  7645. 

  7646. ! maximum infiltration rate
    7647. 

  7647. 

  7648.        DMAX(1)= -ZSOIL(1) * SMCAV
    7649. 

  7649.        DICE   = -ZSOIL(1) * SICE(1)
    7650. 

  7650.        DMAX(1)= DMAX(1)* (1.0-(SH2O(1) + SICE(1) - SMCWLT)/SMCAV)
    7651. 

  7651. 

  7652.        DD = DMAX(1)
    7653. 

  7653. 

  7654.        DO K = 2,NSOIL
    7655. 

  7655.           DICE    = DICE + (ZSOIL(K-1) - ZSOIL(K) ) * SICE(K)
    7656. 

  7656.           DMAX(K) = (ZSOIL(K-1) - ZSOIL(K)) * SMCAV
    7657. 

  7657.           DMAX(K) = DMAX(K) * (1.0-(SH2O(K) + SICE(K) - SMCWLT)/SMCAV)
    7658. 

  7658.           DD      = DD + DMAX(K)
    7659. 

  7659.        END DO
    7660. 

  7660. 

  7661.        VAL = (1. - EXP ( - KDT * DT1))
    7662. 

  7662.        DDT = DD * VAL
    7663. 

  7663.        PX  = MAX(0.,QINSUR * DT)
    7664. 

  7664.        INFMAX = (PX * (DDT / (PX + DDT)))/ DT
    7665. 

  7665. 

  7666. ! impermeable fraction due to frozen soil
    7667. 

  7667. 

  7668.        FCR = 1.
    7669. 

  7669.        IF (DICE >  1.E-2) THEN
    7670. 

  7670.           ACRT = CVFRZ * FRZX / DICE
    7671. 

  7671.           SUM = 1.
    7672. 

  7672.           IALP1 = CVFRZ - 1
    7673. 

  7673.           DO J = 1,IALP1
    7674. 

  7674.              K = 1
    7675. 

  7675.              DO JJ = J +1,IALP1
    7676. 

  7676.                 K = K * JJ
    7677. 

  7677.              END DO
    7678. 

  7678.              SUM = SUM + (ACRT ** (CVFRZ - J)) / FLOAT(K)
    7679. 

  7679.           END DO
    7680. 

  7680.           FCR = 1. - EXP (-ACRT) * SUM
    7681. 

  7681.        END IF
    7682. 

  7682. 

  7683. ! correction of infiltration limitation
    7684. 

  7684. 

  7685.        INFMAX = INFMAX * FCR
    7686. 

  7686. 

  7687. ! jref for urban areas
    7688. 

  7688. !       IF (VEGTYP == ISURBAN ) INFMAX == INFMAX * 0.05
    7689. 

  7689. 

  7690.        CALL WDFCND2 (WDF,WCND,SH2O(1),SICEMAX)
    7691. 

  7691.        INFMAX = MAX (INFMAX,WCND)
    7692. 

  7692.        INFMAX = MIN (INFMAX,PX)
    7693. 

  7693. 

  7694.        RUNSRF= MAX(0., QINSUR - INFMAX)
    7695. 

  7695.        PDDUM = QINSUR - RUNSRF
    7696. 

  7696. 

  7697.     END IF
    7698. 

  7698. 

  7699.   END SUBROUTINE INFIL
    7700. 

  7700. ! ==================================================================================================
    7701. 

  7701.   SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
    7702. 

  7702.                   QSEVA  ,SH2O   ,SMC    ,ZWT    ,FCR    , & !in
    7703. 

  7703.                   SICEMAX,FCRMAX ,ILOC   ,JLOC   ,         & !in
    7704. 

  7704.                   RHSTT  ,AI     ,BI     ,CI     ,QDRAIN , & !out
    7705. 

  7705.                   WCND   )                                   !out
    7706. 

  7706. ! ----------------------------------------------------------------------
    7707. 

  7707. ! calculate the right hand side of the time tendency term of the soil
    7708. 

  7708. ! water diffusion equation.  also to compute ( prepare ) the matrix
    7709. 

  7709. ! coefficients for the tri-diagonal matrix of the implicit time scheme.
    7710. 

  7710. ! ----------------------------------------------------------------------
    7711. 

  7711.     IMPLICIT NONE
    7712. 

  7712. ! ----------------------------------------------------------------------
    7713. 

  7713. !input
    7714. 

  7714. 

  7715.     INTEGER,                  INTENT(IN)  :: ILOC   !grid index
    7716. 

  7716.     INTEGER,                  INTENT(IN)  :: JLOC   !grid index
    7717. 

  7717.     INTEGER,                  INTENT(IN)  :: NSOIL
    7718. 

  7718.     REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: ZSOIL
    7719. 

  7719.     REAL,                     INTENT(IN)  :: DT
    7720. 

  7720.     REAL,                     INTENT(IN)  :: PDDUM
    7721. 

  7721.     REAL,                     INTENT(IN)  :: QSEVA
    7722. 

  7722.     REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: ETRANI
    7723. 

  7723.     REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: SH2O
    7724. 

  7724.     REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: SMC
    7725. 

  7725.     REAL,                     INTENT(IN)  :: ZWT    ! water table depth [m]
    7726. 

  7726.     REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: FCR
    7727. 

  7727.     REAL, INTENT(IN)                      :: FCRMAX !maximum of FCR (-)
    7728. 

  7728.     REAL,                     INTENT(IN)  :: SICEMAX!maximum soil ice content (m3/m3)
    7729. 

  7729. 

  7730. ! output
    7731. 

  7731. 

  7732.     REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT
    7733. 

  7733.     REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI
    7734. 

  7734.     REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: BI
    7735. 

  7735.     REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: CI
    7736. 

  7736.     REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND    !hydraulic conductivity (m/s)
    7737. 

  7737.     REAL,                     INTENT(OUT) :: QDRAIN  !bottom drainage (m/s)
    7738. 

  7738. 

  7739. ! local
    7740. 

  7740.     INTEGER                               :: K
    7741. 

  7741.     REAL, DIMENSION(1:NSOIL)              :: DDZ
    7742. 

  7742.     REAL, DIMENSION(1:NSOIL)              :: DENOM
    7743. 

  7743.     REAL, DIMENSION(1:NSOIL)              :: DSMDZ
    7744. 

  7744.     REAL, DIMENSION(1:NSOIL)              :: WFLUX
    7745. 

  7745.     REAL, DIMENSION(1:NSOIL)              :: WDF
    7746. 

  7746.     REAL, DIMENSION(1:NSOIL)              :: SMX
    7747. 

  7747.     REAL                                  :: TEMP1
    7748. 

  7748. 

  7749. ! Niu and Yang (2006), J. of Hydrometeorology
    7750. 

  7750. ! ----------------------------------------------------------------------
    7751. 

  7751. 

  7752.     IF(OPT_INF == 1) THEN
    7753. 

  7753.       DO K = 1, NSOIL
    7754. 

  7754.         CALL WDFCND1 (WDF(K),WCND(K),SMC(K),FCR(K))
    7755. 

  7755.         SMX(K) = SMC(K)
    7756. 

  7756.       END DO
    7757. 

  7757.     END IF
    7758. 

  7758. 

  7759.     IF(OPT_INF == 2) THEN
    7760. 

  7760.       DO K = 1, NSOIL
    7761. 

  7761.         CALL WDFCND2 (WDF(K),WCND(K),SH2O(K),SICEMAX)
    7762. 

  7762.         SMX(K) = SH2O(K)
    7763. 

  7763.       END DO
    7764. 

  7764.     END IF
    7765. 

  7765. 

  7766.     DO K = 1, NSOIL
    7767. 

  7767.        IF(K == 1) THEN
    7768. 

  7768.           DENOM(K) = - ZSOIL (K)
    7769. 

  7769.           TEMP1    = - ZSOIL (K+1)
    7770. 

  7770.           DDZ(K)   = 2.0 / TEMP1
    7771. 

  7771.           DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1
    7772. 

  7772.           WFLUX(K) = WDF(K) * DSMDZ(K) + WCND(K) - PDDUM + ETRANI(K) + QSEVA
    7773. 

  7773.        ELSE IF (K < NSOIL) THEN
    7774. 

  7774.           DENOM(k) = (ZSOIL(K-1) - ZSOIL(K))
    7775. 

  7775.           TEMP1    = (ZSOIL(K-1) - ZSOIL(K+1))
    7776. 

  7776.           DDZ(K)   = 2.0 / TEMP1
    7777. 

  7777.           DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1
    7778. 

  7778.           WFLUX(K) = WDF(K  ) * DSMDZ(K  ) + WCND(K  )         &
    7779. 

  7779.                    - WDF(K-1) * DSMDZ(K-1) - WCND(K-1) + ETRANI(K)
    7780. 

  7780.        ELSE
    7781. 

  7781.           DENOM(K) = (ZSOIL(K-1) - ZSOIL(K))
    7782. 

  7782.           IF(OPT_RUN == 1 .or. OPT_RUN == 2) THEN
    7783. 

  7783.              QDRAIN   = 0.
    7784. 

  7784.           END IF
    7785. 

  7785.           IF(OPT_RUN == 3) THEN
    7786. 

  7786.              QDRAIN   = SLOPE*WCND(K)
    7787. 

  7787.           END IF
    7788. 

  7788.           IF(OPT_RUN == 4) THEN
    7789. 

  7789.              QDRAIN   = (1.0-FCRMAX)*WCND(K)
    7790. 

  7790.           END IF
    7791. 

  7791.           WFLUX(K) = -(WDF(K-1)*DSMDZ(K-1))-WCND(K-1)+ETRANI(K) + QDRAIN
    7792. 

  7792.        END IF
    7793. 

  7793.     END DO
    7794. 

  7794. 

  7795.     DO K = 1, NSOIL
    7796. 

  7796.        IF(K == 1) THEN
    7797. 

  7797.           AI(K)    =   0.0
    7798. 

  7798.           BI(K)    =   WDF(K  ) * DDZ(K  ) / DENOM(K)
    7799. 

  7799.           CI(K)    = - BI (K)
    7800. 

  7800.        ELSE IF (K < NSOIL) THEN
    7801. 

  7801.           AI(K)    = - WDF(K-1) * DDZ(K-1) / DENOM(K)
    7802. 

  7802.           CI(K)    = - WDF(K  ) * DDZ(K  ) / DENOM(K)
    7803. 

  7803.           BI(K)    = - ( AI (K) + CI (K) )
    7804. 

  7804.        ELSE
    7805. 

  7805.           AI(K)    = - WDF(K-1) * DDZ(K-1) / DENOM(K)
    7806. 

  7806.           CI(K)    = 0.0
    7807. 

  7807.           BI(K)    = - ( AI (K) + CI (K) )
    7808. 

  7808.        END IF
    7809. 

  7809.           RHSTT(K) = WFLUX(K) / (-DENOM(K))
    7810. 

  7810.     END DO
    7811. 

  7811. 

  7812. ! ----------------------------------------------------------------------
    7813. 

  7813.   END SUBROUTINE SRT
    7814. 

  7814. ! ----------------------------------------------------------------------
    7815. 

  7815. ! ==================================================================================================
    7816. 

  7816.   SUBROUTINE SSTEP (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
    7817. 

  7817.                     SICE   ,ILOC   ,JLOC   ,                 & !in
    7818. 

  7818.                     SH2O   ,SMC    ,AI     ,BI     ,CI     , & !inout
    7819. 

  7819.                     RHSTT  ,                                 & !inout
    7820. 

  7820.                     WPLUS  )                                   !out
    7821. 

  7821. 

  7822. ! ----------------------------------------------------------------------
    7823. 

  7823. ! calculate/update soil moisture content values 
    7824. 

  7824. ! ----------------------------------------------------------------------
    7825. 

  7825.     IMPLICIT NONE
    7826. 

  7826. ! ----------------------------------------------------------------------
    7827. 

  7827. !input
    7828. 

  7828. 

  7829.     INTEGER,                         INTENT(IN) :: ILOC   !grid index
    7830. 

  7830.     INTEGER,                         INTENT(IN) :: JLOC   !grid index
    7831. 

  7831.     INTEGER,                         INTENT(IN) :: NSOIL  !
    7832. 

  7832.     INTEGER,                         INTENT(IN) :: NSNOW  !
    7833. 

  7833.     REAL, INTENT(IN)                            :: DT
    7834. 

  7834.     REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: ZSOIL
    7835. 

  7835.     REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SICE
    7836. 

  7836.     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m]
    7837. 

  7837. 

  7838. !input and output
    7839. 

  7839.     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O
    7840. 

  7840.     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC
    7841. 

  7841.     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI
    7842. 

  7842.     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: BI
    7843. 

  7843.     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: CI
    7844. 

  7844.     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT
    7845. 

  7845. 

  7846. !output
    7847. 

  7847.     REAL, INTENT(OUT)                       :: WPLUS     !saturation excess water (m)
    7848. 

  7848. 

  7849. !local
    7850. 

  7850.     INTEGER                                 :: K
    7851. 

  7851.     REAL, DIMENSION(1:NSOIL)                :: RHSTTIN
    7852. 

  7852.     REAL, DIMENSION(1:NSOIL)                :: CIIN
    7853. 

  7853.     REAL                                    :: STOT
    7854. 

  7854.     REAL                                    :: EPORE
    7855. 

  7855. ! ----------------------------------------------------------------------
    7856. 

  7856.     WPLUS = 0.0
    7857. 

  7857. 

  7858.     DO K = 1,NSOIL
    7859. 

  7859.        RHSTT (K) =   RHSTT(K) * DT
    7860. 

  7860.        AI (K)    =      AI(K) * DT
    7861. 

  7861.        BI (K)    = 1. + BI(K) * DT
    7862. 

  7862.        CI (K)    =      CI(K) * DT
    7863. 

  7863.     END DO
    7864. 

  7864. 

  7865. ! copy values for input variables before calling rosr12
    7866. 

  7866. 

  7867.     DO K = 1,NSOIL
    7868. 

  7868.        RHSTTIN(k) = RHSTT(K)
    7869. 

  7869.        CIIN(k)    = CI(K)
    7870. 

  7870.     END DO
    7871. 

  7871. 

  7872. ! call ROSR12 to solve the tri-diagonal matrix
    7873. 

  7873. 

  7874.     CALL ROSR12 (CI,AI,BI,CIIN,RHSTTIN,RHSTT,1,NSOIL,0)
    7875. 

  7875. 

  7876.     DO K = 1,NSOIL
    7877. 

  7877.         SH2O(K) = SH2O(K) + CI(K)
    7878. 

  7878.     ENDDO
    7879. 

  7879. 

  7880. !  excessive water above saturation in a layer is moved to
    7881. 

  7881. !  its unsaturated layer like in a bucket
    7882. 

  7882. 

  7883.     DO K = NSOIL,2,-1
    7884. 

  7884.       EPORE        = MAX ( 1.E-4 , ( SMCMAX - SICE(K) ) )
    7885. 

  7885.       WPLUS        = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K)
    7886. 

  7886.       SH2O(K)      = MIN(EPORE,SH2O(K))
    7887. 

  7887.       SH2O(K-1)    = SH2O(K-1) + WPLUS/DZSNSO(K-1)
    7888. 

  7888.     END DO
    7889. 

  7889. 

  7890.     EPORE        = MAX ( 1.E-4 , ( SMCMAX - SICE(1) ) )
    7891. 

  7891.     WPLUS        = MAX((SH2O(1)-EPORE), 0.0) * DZSNSO(1) 
    7892. 

  7892.     SH2O(1)      = MIN(EPORE,SH2O(1))
    7893. 

  7893. 

  7894.   END SUBROUTINE SSTEP
    7895. 

  7895. ! ==================================================================================================
    7896. 

  7896.   SUBROUTINE WDFCND1 (WDF,WCND,SMC,FCR)
    7897. 

  7897. ! ----------------------------------------------------------------------
    7898. 

  7898. ! calculate soil water diffusivity and soil hydraulic conductivity.
    7899. 

  7899. ! ----------------------------------------------------------------------
    7900. 

  7900.     IMPLICIT NONE
    7901. 

  7901. ! ----------------------------------------------------------------------
    7902. 

  7902. ! input 
    7903. 

  7903.     REAL,INTENT(IN)  :: SMC
    7904. 

  7904.     REAL,INTENT(IN)  :: FCR
    7905. 

  7905. 

  7906. ! output
    7907. 

  7907.     REAL,INTENT(OUT) :: WCND
    7908. 

  7908.     REAL,INTENT(OUT) :: WDF
    7909. 

  7909. 

  7910. ! local
    7911. 

  7911.     REAL :: EXPON
    7912. 

  7912.     REAL :: FACTR
    7913. 

  7913.     REAL :: VKWGT
    7914. 

  7914. ! ----------------------------------------------------------------------
    7915. 

  7915. 

  7916. ! soil water diffusivity
    7917. 

  7917. 

  7918.     FACTR = MAX(0.01, SMC/SMCMAX)
    7919. 

  7919.     EXPON = BEXP + 2.0
    7920. 

  7920.     WDF   = DWSAT * FACTR ** EXPON
    7921. 

  7921.     WDF   = WDF * (1.0 - FCR)
    7922. 

  7922. 

  7923. ! hydraulic conductivity
    7924. 

  7924. 

  7925.     EXPON = 2.0*BEXP + 3.0
    7926. 

  7926.     WCND  = DKSAT * FACTR ** EXPON
    7927. 

  7927.     WCND  = WCND * (1.0 - FCR)
    7928. 

  7928. 

  7929.   END SUBROUTINE WDFCND1
    7930. 

  7930. ! ==================================================================================================
    7931. 

  7931.   SUBROUTINE WDFCND2 (WDF,WCND,SMC,SICE)
    7932. 

  7932. ! ----------------------------------------------------------------------
    7933. 

  7933. ! calculate soil water diffusivity and soil hydraulic conductivity.
    7934. 

  7934. ! ----------------------------------------------------------------------
    7935. 

  7935.     IMPLICIT NONE
    7936. 

  7936. ! ----------------------------------------------------------------------
    7937. 

  7937. ! input
    7938. 

  7938.     REAL,INTENT(IN)  :: SMC
    7939. 

  7939.     REAL,INTENT(IN)  :: SICE
    7940. 

  7940. 

  7941. ! output
    7942. 

  7942.     REAL,INTENT(OUT) :: WCND
    7943. 

  7943.     REAL,INTENT(OUT) :: WDF
    7944. 

  7944. 

  7945. ! local
    7946. 

  7946.     REAL :: EXPON
    7947. 

  7947.     REAL :: FACTR
    7948. 

  7948.     REAL :: VKWGT
    7949. 

  7949. ! ----------------------------------------------------------------------
    7950. 

  7950. 

  7951. ! soil water diffusivity
    7952. 

  7952. 

  7953.     FACTR = MAX(0.01, SMC/SMCMAX)
    7954. 

  7954.     EXPON = BEXP + 2.0
    7955. 

  7955.     WDF   = DWSAT * FACTR ** EXPON
    7956. 

  7956. 

  7957.     IF (SICE > 0.0) THEN
    7958. 

  7958.     VKWGT = 1./ (1. + (500.* SICE)**3.)
    7959. 

  7959.     WDF   = VKWGT * WDF + (1.-VKWGT)*DWSAT*(0.2/SMCMAX)**EXPON
    7960. 

  7960.     END IF
    7961. 

  7961. 

  7962. ! hydraulic conductivity
    7963. 

  7963. 

  7964.     EXPON = 2.0*BEXP + 3.0
    7965. 

  7965.     WCND  = DKSAT * FACTR ** EXPON
    7966. 

  7966. 

  7967.   END SUBROUTINE WDFCND2
    7968. 

  7968. ! ==================================================================================================
    7969. 

  7969. ! ----------------------------------------------------------------------
    7970. 

  7970.   SUBROUTINE GROUNDWATER(NSNOW  ,NSOIL  ,DT     ,SICE   ,ZSOIL  , & !in
    7971. 

  7971.                          STC    ,WCND   ,FCRMAX ,ILOC   ,JLOC   , & !in
    7972. 

  7972.                          SH2O   ,ZWT    ,WA     ,WT     ,         & !inout
    7973. 

  7973.                          QIN    ,QDIS   )                           !out
    7974. 

  7974. ! ----------------------------------------------------------------------
    7975. 

  7975.   IMPLICIT NONE
    7976. 

  7976. ! ----------------------------------------------------------------------
    7977. 

  7977. ! input
    7978. 

  7978.   INTEGER,                         INTENT(IN) :: ILOC  !grid index
    7979. 

  7979.   INTEGER,                         INTENT(IN) :: JLOC  !grid index
    7980. 

  7980.   INTEGER,                         INTENT(IN) :: NSNOW !maximum no. of snow layers
    7981. 

  7981.   INTEGER,                         INTENT(IN) :: NSOIL !no. of soil layers
    7982. 

  7982.   REAL,                            INTENT(IN) :: DT    !timestep [sec]
    7983. 

  7983.   REAL,                            INTENT(IN) :: FCRMAX!maximum FCR (-)
    7984. 

  7984.   REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SICE  !soil ice content [m3/m3]
    7985. 

  7985.   REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m]
    7986. 

  7986.   REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: WCND  !hydraulic conductivity (m/s)
    7987. 

  7987.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC   !snow/soil temperature (k)
    7988. 

  7988. 

  7989. ! input and output
    7990. 

  7990.   REAL, DIMENSION(    1:NSOIL), INTENT(INOUT) :: SH2O  !liquid soil water [m3/m3]
    7991. 

  7991.   REAL,                         INTENT(INOUT) :: ZWT   !the depth to water table [m]
    7992. 

  7992.   REAL,                         INTENT(INOUT) :: WA    !water storage in aquifer [mm]
    7993. 

  7993.   REAL,                         INTENT(INOUT) :: WT    !water storage in aquifer 
    7994. 

  7994.                                                            !+ saturated soil [mm]
    7995. 

  7995. ! output
    7996. 

  7996.   REAL,                           INTENT(OUT) :: QIN   !groundwater recharge [mm/s]
    7997. 

  7997.   REAL,                           INTENT(OUT) :: QDIS  !groundwater discharge [mm/s]
    7998. 

  7998. 

  7999. ! local
    8000. 

  8000.   REAL                                        :: FFF   !runoff decay factor (m-1)
    8001. 

  8001.   REAL                                        :: RSBMX !baseflow coefficient [mm/s]
    8002. 

  8002.   INTEGER                                     :: IZ    !do-loop index
    8003. 

  8003.   INTEGER                                     :: IWT   !layer index above water table layer
    8004. 

  8004.   REAL,  DIMENSION(    1:NSOIL)               :: DZMM  !layer thickness [mm]
    8005. 

  8005.   REAL,  DIMENSION(    1:NSOIL)               :: ZNODE !node depth [m]
    8006. 

  8006.   REAL,  DIMENSION(    1:NSOIL)               :: MLIQ  !liquid water mass [kg/m2 or mm]
    8007. 

  8007.   REAL,  DIMENSION(    1:NSOIL)               :: EPORE !effective porosity [-]
    8008. 

  8008.   REAL,  DIMENSION(    1:NSOIL)               :: HK    !hydraulic conductivity [mm/s]
    8009. 

  8009.   REAL,  DIMENSION(    1:NSOIL)               :: SMC   !total soil water  content [m3/m3]
    8010. 

  8010.   REAL(KIND=8)                                :: S_NODE!degree of saturation of IWT layer
    8011. 

  8011.   REAL                                        :: DZSUM !cumulative depth above water table [m]
    8012. 

  8012.   REAL                                        :: SMPFZ !matric potential (frozen effects) [mm]
    8013. 

  8013.   REAL                                        :: KA    !aquifer hydraulic conductivity [mm/s]
    8014. 

  8014.   REAL                                        :: WH_ZWT!water head at water table [mm]
    8015. 

  8015.   REAL                                        :: WH    !water head at layer above ZWT [mm]
    8016. 

  8016.   REAL                                        :: WS    !water used to fill air pore [mm]
    8017. 

  8017.   REAL                                        :: WTSUB !sum of HK*DZMM
    8018. 

  8018.   REAL                                        :: WATMIN!minimum soil vol soil moisture [m3/m3]
    8019. 

  8019.   REAL                                        :: XS    !excessive water above saturation [mm]
    8020. 

  8020.   REAL, PARAMETER                             :: ROUS = 0.2    !specific yield [-]
    8021. 

  8021.   REAL, PARAMETER                             :: CMIC = 0.20   !microprore content (0.0-1.0)
    8022. 

  8022.                                                                !0.0-close to free drainage
    8023. 

  8023. ! -------------------------------------------------------------
    8024. 

  8024.       QDIS      = 0.0
    8025. 

  8025.       QIN       = 0.0
    8026. 

  8026. 

  8027. ! Derive layer-bottom depth in [mm]
    8028. 

  8028. !KWM:  Derive layer thickness in mm
    8029. 

  8029. 

  8030.       DZMM(1) = -ZSOIL(1)*1.E3
    8031. 

  8031.       DO IZ = 2, NSOIL
    8032. 

  8032.          DZMM(IZ)  = 1.E3 * (ZSOIL(IZ - 1) - ZSOIL(IZ))
    8033. 

  8033.       ENDDO
    8034. 

  8034. 

  8035. ! Derive node (middle) depth in [m]
    8036. 

  8036. !KWM:  Positive number, depth below ground surface in m
    8037. 

  8037.       ZNODE(1) = -ZSOIL(1) / 2.
    8038. 

  8038.       DO IZ = 2, NSOIL
    8039. 

  8039.          ZNODE(IZ)  = -ZSOIL(IZ-1) + 0.5 * (ZSOIL(IZ-1) - ZSOIL(IZ))
    8040. 

  8040.       ENDDO
    8041. 

  8041. 

  8042. ! Convert volumetric soil moisture "sh2o" to mass
    8043. 

  8043. 

  8044.       DO IZ = 1, NSOIL
    8045. 

  8045.          SMC(IZ)      = SH2O(IZ) + SICE(IZ)
    8046. 

  8046.          MLIQ(IZ)     = SH2O(IZ) * DZMM(IZ)
    8047. 

  8047.          EPORE(IZ)    = MAX(0.01,SMCMAX - SICE(IZ))
    8048. 

  8048.          HK(IZ)       = 1.E3*WCND(IZ)
    8049. 

  8049.       ENDDO
    8050. 

  8050. 

  8051. ! The layer index of the first unsaturated layer,
    8052. 

  8052. ! i.e., the layer right above the water table
    8053. 

  8053. 

  8054.       IWT = NSOIL
    8055. 

  8055.       DO IZ = 2,NSOIL
    8056. 

  8056.          IF(ZWT   .LE. -ZSOIL(IZ) ) THEN
    8057. 

  8057.             IWT = IZ-1
    8058. 

  8058.             EXIT
    8059. 

  8059.          END IF
    8060. 

  8060.       ENDDO
    8061. 

  8061. 

  8062. ! Groundwater discharge [mm/s]
    8063. 

  8063. 

  8064.       FFF   = 6.0
    8065. 

  8065.       RSBMX = 5.0
    8066. 

  8066. 

  8067.       QDIS = (1.0-FCRMAX)*RSBMX*EXP(-TIMEAN)*EXP(-FFF*(ZWT-2.0))
    8068. 

  8068. 

  8069. ! Matric potential at the layer above the water table
    8070. 

  8070. 

  8071.       S_NODE = MIN(1.0,SMC(IWT)/SMCMAX )
    8072. 

  8072.       S_NODE = MAX(S_NODE,REAL(0.01,KIND=8))
    8073. 

  8073.       SMPFZ  = -PSISAT*1000.*S_NODE**(-BEXP)   ! m --> mm
    8074. 

  8074.       SMPFZ  = MAX(-120000.0,CMIC*SMPFZ)   
    8075. 

  8075. 

  8076. ! Recharge rate qin to groundwater
    8077. 

  8077. 

  8078.       KA  = HK(IWT)
    8079. 

  8079. 

  8080.       WH_ZWT  = - ZWT * 1.E3                          !(mm)
    8081. 

  8081.       WH      = SMPFZ  - ZNODE(IWT)*1.E3              !(mm)
    8082. 

  8082.       QIN     = - KA * (WH_ZWT-WH)  /((ZWT-ZNODE(IWT))*1.E3)
    8083. 

  8083.       QIN     = MAX(-10.0/DT,MIN(10./DT,QIN))
    8084. 

  8084.      
    8085. 

  8085. ! Water storage in the aquifer + saturated soil
    8086. 

  8086. 

  8087.       WT  = WT + (QIN - QDIS) * DT     !(mm)
    8088. 

  8088. 

  8089.       IF(IWT.EQ.NSOIL) THEN
    8090. 

  8090.          WA          = WA + (QIN - QDIS) * DT     !(mm)
    8091. 

  8091.          WT          = WA
    8092. 

  8092.          ZWT         = (-ZSOIL(NSOIL) + 25.) - WA/1000./ROUS      !(m)
    8093. 

  8093.          MLIQ(NSOIL) = MLIQ(NSOIL) - QIN * DT        ! [mm]
    8094. 

  8094. 

  8095.          MLIQ(NSOIL) = MLIQ(NSOIL) + MAX(0.,(WA - 5000.))
    8096. 

  8096.          WA          = MIN(WA, 5000.)
    8097. 

  8097.       ELSE
    8098. 

  8098.          
    8099. 

  8099.          IF (IWT.EQ.NSOIL-1) THEN
    8100. 

  8100.             ZWT = -ZSOIL(NSOIL)                   &
    8101. 

  8101.                  - (WT-ROUS*1000*25.) / (EPORE(NSOIL))/1000.
    8102. 

  8102.          ELSE
    8103. 

  8103.             WS = 0.   ! water used to fill soil air pores
    8104. 

  8104.             DO IZ = IWT+2,NSOIL
    8105. 

  8105.                WS = WS + EPORE(IZ) * DZMM(IZ)
    8106. 

  8106.             ENDDO
    8107. 

  8107.             ZWT = -ZSOIL(IWT+1)                  &
    8108. 

  8108.                   - (WT-ROUS*1000.*25.-WS) /(EPORE(IWT+1))/1000.
    8109. 

  8109.          ENDIF
    8110. 

  8110. 

  8111.          WTSUB = 0.
    8112. 

  8112.          DO IZ = 1, NSOIL
    8113. 

  8113.            WTSUB = WTSUB + HK(IZ)*DZMM(IZ)
    8114. 

  8114.          END DO
    8115. 

  8115. 

  8116.          DO IZ = 1, NSOIL           ! Removing subsurface runoff
    8117. 

  8117.          MLIQ(IZ) = MLIQ(IZ) - QDIS*DT*HK(IZ)*DZMM(IZ)/WTSUB
    8118. 

  8118.          END DO
    8119. 

  8119.       END IF
    8120. 

  8120. 

  8121.       ZWT = MAX(1.5,ZWT)
    8122. 

  8122. 

  8123. !
    8124. 

  8124. ! Limit MLIQ to be greater than or equal to watmin.
    8125. 

  8125. ! Get water needed to bring MLIQ equal WATMIN from lower layer.
    8126. 

  8126. !
    8127. 

  8127.       WATMIN = 0.01
    8128. 

  8128.       DO IZ = 1, NSOIL-1
    8129. 

  8129.           IF (MLIQ(IZ) .LT. 0.) THEN
    8130. 

  8130.              XS = WATMIN-MLIQ(IZ)
    8131. 

  8131.           ELSE
    8132. 

  8132.              XS = 0.
    8133. 

  8133.           END IF
    8134. 

  8134.           MLIQ(IZ  ) = MLIQ(IZ  ) + XS
    8135. 

  8135.           MLIQ(IZ+1) = MLIQ(IZ+1) - XS
    8136. 

  8136.       END DO
    8137. 

  8137. 

  8138.         IZ = NSOIL
    8139. 

  8139.         IF (MLIQ(IZ) .LT. WATMIN) THEN
    8140. 

  8140.            XS = WATMIN-MLIQ(IZ)
    8141. 

  8141.         ELSE
    8142. 

  8142.            XS = 0.
    8143. 

  8143.         END IF
    8144. 

  8144.         MLIQ(IZ) = MLIQ(IZ) + XS
    8145. 

  8145.         WA       = WA - XS
    8146. 

  8146.         WT       = WT - XS
    8147. 

  8147. 

  8148.       DO IZ = 1, NSOIL
    8149. 

  8149.         SH2O(IZ)     = MLIQ(IZ) / DZMM(IZ)
    8150. 

  8150.       END DO
    8151. 

  8151. 

  8152.   END SUBROUTINE GROUNDWATER
    8153. 

  8153. ! ==================================================================================================
    8154. 

  8154. ! ********************* end of water subroutines ******************************************
    8155. 

  8155. ! ==================================================================================================
    8156. 

  8156.   SUBROUTINE CARBON (NSNOW  ,NSOIL  ,VEGTYP ,NROOT  ,DT     ,ZSOIL  , & !in
    8157. 

  8157.                      DZSNSO ,STC    ,SMC    ,TV     ,TG     ,PSN    , & !in
    8158. 

  8158.                      FOLN   ,SMCMAX ,BTRAN  ,APAR   ,FVEG   ,IGS    , & !in
    8159. 

  8159.                      TROOT  ,IST    ,LAT    ,ILOC   ,JLOC   ,         & !in
    8160. 

  8160.                      LFMASS ,RTMASS ,STMASS ,WOOD   ,STBLCP ,FASTCP , & !inout
    8161. 

  8161.                      GPP    ,NPP    ,NEE    ,AUTORS ,HETERS ,TOTSC  , & !out
    8162. 

  8162.                      TOTLB  ,XLAI   ,XSAI   )                   !out
    8163. 

  8163. ! ------------------------------------------------------------------------------------------
    8164. 

  8164.   USE NOAHMP_VEG_PARAMETERS
    8165. 

  8165. ! ------------------------------------------------------------------------------------------
    8166. 

  8166.       IMPLICIT NONE
    8167. 

  8167. ! ------------------------------------------------------------------------------------------
    8168. 

  8168. ! inputs (carbon)
    8169. 

  8169. 

  8170.   INTEGER                        , INTENT(IN) :: ILOC   !grid index
    8171. 

  8171.   INTEGER                        , INTENT(IN) :: JLOC   !grid index
    8172. 

  8172.   INTEGER                        , INTENT(IN) :: VEGTYP !vegetation type 
    8173. 

  8173.   INTEGER                        , INTENT(IN) :: NSNOW  !number of snow layers
    8174. 

  8174.   INTEGER                        , INTENT(IN) :: NSOIL  !number of soil layers
    8175. 

  8175.   INTEGER                        , INTENT(IN) :: NROOT  !no. of root layers
    8176. 

  8176.   REAL                           , INTENT(IN) :: LAT    !latitude (radians)
    8177. 

  8177.   REAL                           , INTENT(IN) :: DT     !time step (s)
    8178. 

  8178.   REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: ZSOIL  !depth of layer-bottom from soil surface
    8179. 

  8179.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m]
    8180. 

  8180.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC    !snow/soil temperature [k]
    8181. 

  8181.   REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SMC    !soil moisture (ice + liq.) [m3/m3]
    8182. 

  8182.   REAL                           , INTENT(IN) :: TV     !vegetation temperature (k)
    8183. 

  8183.   REAL                           , INTENT(IN) :: TG     !ground temperature (k)
    8184. 

  8184.   REAL                           , INTENT(IN) :: FOLN   !foliage nitrogen (%)
    8185. 

  8185.   REAL                           , INTENT(IN) :: SMCMAX !soil porosity (m3/m3)
    8186. 

  8186.   REAL                           , INTENT(IN) :: BTRAN  !soil water transpiration factor (0 to 1)
    8187. 

  8187.   REAL                           , INTENT(IN) :: PSN    !total leaf photosyn (umolco2/m2/s) [+]
    8188. 

  8188.   REAL                           , INTENT(IN) :: APAR   !PAR by canopy (w/m2)
    8189. 

  8189.   REAL                           , INTENT(IN) :: IGS    !growing season index (0=off, 1=on)
    8190. 

  8190.   REAL                           , INTENT(IN) :: FVEG   !vegetation greenness fraction
    8191. 

  8191.   REAL                           , INTENT(IN) :: TROOT  !root-zone averaged temperature (k)
    8192. 

  8192.   INTEGER                        , INTENT(IN) :: IST    !surface type 1->soil; 2->lake
    8193. 

  8193. 

  8194. ! input & output (carbon)
    8195. 

  8195. 

  8196.   REAL                        , INTENT(INOUT) :: LFMASS !leaf mass [g/m2]
    8197. 

  8197.   REAL                        , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2]
    8198. 

  8198.   REAL                        , INTENT(INOUT) :: STMASS !stem mass [g/m2]
    8199. 

  8199.   REAL                        , INTENT(INOUT) :: WOOD   !mass of wood (incl. woody roots) [g/m2]
    8200. 

  8200.   REAL                        , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2]
    8201. 

  8201.   REAL                        , INTENT(INOUT) :: FASTCP !short-lived carbon in shallow soil [g/m2]
    8202. 

  8202. 

  8203. ! outputs: (carbon)
    8204. 

  8204. 

  8205.   REAL                          , INTENT(OUT) :: GPP    !net instantaneous assimilation [g/m2/s C]
    8206. 

  8206.   REAL                          , INTENT(OUT) :: NPP    !net primary productivity [g/m2/s C]
    8207. 

  8207.   REAL                          , INTENT(OUT) :: NEE    !net ecosystem exchange [g/m2/s CO2]
    8208. 

  8208.   REAL                          , INTENT(OUT) :: AUTORS !net ecosystem respiration [g/m2/s C]
    8209. 

  8209.   REAL                          , INTENT(OUT) :: HETERS !organic respiration [g/m2/s C]
    8210. 

  8210.   REAL                          , INTENT(OUT) :: TOTSC  !total soil carbon [g/m2 C]
    8211. 

  8211.   REAL                          , INTENT(OUT) :: TOTLB  !total living carbon ([g/m2 C]
    8212. 

  8212.   REAL                          , INTENT(OUT) :: XLAI   !leaf area index [-]
    8213. 

  8213.   REAL                          , INTENT(OUT) :: XSAI   !stem area index [-]
    8214. 

  8214. !  REAL                          , INTENT(OUT) :: VOCFLX(5) ! voc fluxes [ug C m-2 h-1]
    8215. 

  8215. 

  8216. ! local variables
    8217. 

  8217. 

  8218.   INTEGER :: J         !do-loop index
    8219. 

  8219.   REAL    :: WROOT     !root zone soil water [-]
    8220. 

  8220.   REAL    :: WSTRES    !water stress coeficient [-]  (1. for wilting )
    8221. 

  8221.   REAL    :: LAPM      !leaf area per unit mass [m2/g]
    8222. 

  8222. ! ------------------------------------------------------------------------------------------
    8223. 

  8223. 

  8224.    IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISSNOW ) ) THEN
    8225. 

  8225.       XLAI   = 0.
    8226. 

  8226.       XSAI   = 0.
    8227. 

  8227.       GPP    = 0.
    8228. 

  8228.       NPP    = 0.
    8229. 

  8229.       NEE    = 0.
    8230. 

  8230.       AUTORS = 0.
    8231. 

  8231.       HETERS = 0.
    8232. 

  8232.       TOTSC  = 0.
    8233. 

  8233.       TOTLB  = 0.
    8234. 

  8234.       LFMASS = 0.
    8235. 

  8235.       RTMASS = 0.
    8236. 

  8236.       STMASS = 0.
    8237. 

  8237.       WOOD   = 0.
    8238. 

  8238.       STBLCP = 0.
    8239. 

  8239.       FASTCP = 0.
    8240. 

  8240. 

  8241.       RETURN
    8242. 

  8242.    END IF
    8243. 

  8243. 

  8244.       LAPM       = SLA(VEGTYP) / 1000.   ! m2/kg -> m2/g
    8245. 

  8245. 

  8246. ! water stress
    8247. 

  8247. 

  8248.       WSTRES  = 1.- BTRAN
    8249. 

  8249. 

  8250.       WROOT  = 0.
    8251. 

  8251.       DO J=1,NROOT
    8252. 

  8252.         WROOT = WROOT + SMC(J)/SMCMAX *  DZSNSO(J) / (-ZSOIL(NROOT))
    8253. 

  8253.       ENDDO
    8254. 

  8254. 

  8255.   CALL CO2FLUX (NSNOW  ,NSOIL  ,VEGTYP ,IGS    ,DT     , & !in
    8256. 

  8256.                 DZSNSO ,STC    ,PSN    ,TROOT  ,TV     , & !in
    8257. 

  8257.                 WROOT  ,WSTRES ,FOLN   ,LAPM   ,         & !in
    8258. 

  8258.                 LAT    ,ILOC   ,JLOC   ,FVEG   ,         & !in
    8259. 

  8259.                 XLAI   ,XSAI   ,LFMASS ,RTMASS ,STMASS , & !inout
    8260. 

  8260.                 FASTCP ,STBLCP ,WOOD   ,                 & !inout
    8261. 

  8261.                 GPP    ,NPP    ,NEE    ,AUTORS ,HETERS , & !out
    8262. 

  8262.                 TOTSC  ,TOTLB  )                           !out
    8263. 

  8263. 

  8264. !   CALL BVOC (VOCFLX,  VEGTYP,  VEGFAC,   APAR,   TV)
    8265. 

  8265. !   CALL CH4
    8266. 

  8266. 

  8267.   END SUBROUTINE CARBON
    8268. 

  8268. ! ==================================================================================================
    8269. 

  8269.   SUBROUTINE CO2FLUX (NSNOW  ,NSOIL  ,VEGTYP ,IGS    ,DT     , & !in
    8270. 

  8270.                       DZSNSO ,STC    ,PSN    ,TROOT  ,TV     , & !in
    8271. 

  8271.                       WROOT  ,WSTRES ,FOLN   ,LAPM   ,         & !in
    8272. 

  8272.                       LAT    ,ILOC   ,JLOC   ,FVEG   ,         & !in
    8273. 

  8273.                       XLAI   ,XSAI   ,LFMASS ,RTMASS ,STMASS , & !inout
    8274. 

  8274.                       FASTCP ,STBLCP ,WOOD   ,                 & !inout
    8275. 

  8275.                       GPP    ,NPP    ,NEE    ,AUTORS ,HETERS , & !out
    8276. 

  8276.                       TOTSC  ,TOTLB  )                           !out
    8277. 

  8277. ! -----------------------------------------------------------------------------------------
    8278. 

  8278. ! The original code is from RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004
    8279. 

  8279. ! -----------------------------------------------------------------------------------------
    8280. 

  8280.   USE NOAHMP_VEG_PARAMETERS
    8281. 

  8281. ! -----------------------------------------------------------------------------------------
    8282. 

  8282.   IMPLICIT NONE
    8283. 

  8283. ! -----------------------------------------------------------------------------------------
    8284. 

  8284. 

  8285. ! input
    8286. 

  8286. 

  8287.   INTEGER                        , INTENT(IN) :: ILOC   !grid index
    8288. 

  8288.   INTEGER                        , INTENT(IN) :: JLOC   !grid index
    8289. 

  8289.   INTEGER                        , INTENT(IN) :: VEGTYP !vegetation physiology type
    8290. 

  8290.   INTEGER                        , INTENT(IN) :: NSNOW  !number of snow layers
    8291. 

  8291.   INTEGER                        , INTENT(IN) :: NSOIL  !number of soil layers
    8292. 

  8292.   REAL                           , INTENT(IN) :: DT     !time step (s)
    8293. 

  8293.   REAL                           , INTENT(IN) :: LAT    !latitude (radians)
    8294. 

  8294.   REAL                           , INTENT(IN) :: IGS    !growing season index (0=off, 1=on)
    8295. 

  8295.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m]
    8296. 

  8296.   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC    !snow/soil temperature [k]
    8297. 

  8297.   REAL                           , INTENT(IN) :: PSN    !total leaf photosynthesis (umolco2/m2/s)
    8298. 

  8298.   REAL                           , INTENT(IN) :: TROOT  !root-zone averaged temperature (k)
    8299. 

  8299.   REAL                           , INTENT(IN) :: TV     !leaf temperature (k)
    8300. 

  8300.   REAL                           , INTENT(IN) :: WROOT  !root zone soil water
    8301. 

  8301.   REAL                           , INTENT(IN) :: WSTRES !soil water stress
    8302. 

  8302.   REAL                           , INTENT(IN) :: FOLN   !foliage nitrogen (%)
    8303. 

  8303.   REAL                           , INTENT(IN) :: LAPM   !leaf area per unit mass [m2/g]
    8304. 

  8304.   REAL                           , INTENT(IN) :: FVEG   !vegetation greenness fraction
    8305. 

  8305. 

  8306. ! input and output
    8307. 

  8307. 

  8308.   REAL                        , INTENT(INOUT) :: XLAI   !leaf  area index from leaf carbon [-]
    8309. 

  8309.   REAL                        , INTENT(INOUT) :: XSAI   !stem area index from leaf carbon [-]
    8310. 

  8310.   REAL                        , INTENT(INOUT) :: LFMASS !leaf mass [g/m2]
    8311. 

  8311.   REAL                        , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2]
    8312. 

  8312.   REAL                        , INTENT(INOUT) :: STMASS !stem mass [g/m2]
    8313. 

  8313.   REAL                        , INTENT(INOUT) :: FASTCP !short lived carbon [g/m2]
    8314. 

  8314.   REAL                        , INTENT(INOUT) :: STBLCP !stable carbon pool [g/m2]
    8315. 

  8315.   REAL                        , INTENT(INOUT) :: WOOD   !mass of wood (incl. woody roots) [g/m2]
    8316. 

  8316. 

  8317. ! output
    8318. 

  8318. 

  8319.   REAL                          , INTENT(OUT) :: GPP    !net instantaneous assimilation [g/m2/s]
    8320. 

  8320.   REAL                          , INTENT(OUT) :: NPP    !net primary productivity [g/m2]
    8321. 

  8321.   REAL                          , INTENT(OUT) :: NEE    !net ecosystem exchange (autors+heters-gpp)
    8322. 

  8322.   REAL                          , INTENT(OUT) :: AUTORS !net ecosystem resp. (maintance and growth)
    8323. 

  8323.   REAL                          , INTENT(OUT) :: HETERS !organic respiration
    8324. 

  8324.   REAL                          , INTENT(OUT) :: TOTSC  !total soil carbon (g/m2)
    8325. 

  8325.   REAL                          , INTENT(OUT) :: TOTLB  !total living carbon (g/m2)
    8326. 

  8326. 

  8327. ! local
    8328. 

  8328. 

  8329.   REAL                   :: CFLUX    !carbon flux to atmosphere [g/m2/s]
    8330. 

  8330.   REAL                   :: LFMSMN   !minimum leaf mass [g/m2]
    8331. 

  8331.   REAL                   :: RSWOOD   !wood respiration [g/m2]
    8332. 

  8332.   REAL                   :: RSLEAF   !leaf maintenance respiration per timestep [g/m2]
    8333. 

  8333.   REAL                   :: RSROOT   !fine root respiration per time step [g/m2]
    8334. 

  8334.   REAL                   :: NPPL     !leaf net primary productivity [g/m2/s]
    8335. 

  8335.   REAL                   :: NPPR     !root net primary productivity [g/m2/s]
    8336. 

  8336.   REAL                   :: NPPW     !wood net primary productivity [g/m2/s]
    8337. 

  8337.   REAL                   :: NPPS     !wood net primary productivity [g/m2/s]
    8338. 

  8338.   REAL                   :: DIELF    !death of leaf mass per time step [g/m2]
    8339. 

  8339. 

  8340.   REAL                   :: ADDNPPLF !leaf assimil after resp. losses removed [g/m2]
    8341. 

  8341.   REAL                   :: ADDNPPST !stem assimil after resp. losses removed [g/m2]
    8342. 

  8342.   REAL                   :: CARBFX   !carbon assimilated per model step [g/m2]
    8343. 

  8343.   REAL                   :: GRLEAF   !growth respiration rate for leaf [g/m2/s]
    8344. 

  8344.   REAL                   :: GRROOT   !growth respiration rate for root [g/m2/s]
    8345. 

  8345.   REAL                   :: GRWOOD   !growth respiration rate for wood [g/m2/s]
    8346. 

  8346.   REAL                   :: GRSTEM   !growth respiration rate for stem [g/m2/s]
    8347. 

  8347.   REAL                   :: LEAFPT   !fraction of carbon allocated to leaves [-]
    8348. 

  8348.   REAL                   :: LFDEL    !maximum  leaf mass  available to change [g/m2/s]
    8349. 

  8349.   REAL                   :: LFTOVR   !stem turnover per time step [g/m2]
    8350. 

  8350.   REAL                   :: STTOVR   !stem turnover per time step [g/m2]
    8351. 

  8351.   REAL                   :: WDTOVR   !wood turnover per time step [g/m2]
    8352. 

  8352.   REAL                   :: RSSOIL   !soil respiration per time step [g/m2]
    8353. 

  8353.   REAL                   :: RTTOVR   !root carbon loss per time step by turnover [g/m2]
    8354. 

  8354.   REAL                   :: STABLC   !decay rate of fast carbon to slow carbon [g/m2/s]
    8355. 

  8355.   REAL                   :: WOODF    !calculated wood to root ratio [-]
    8356. 

  8356.   REAL                   :: NONLEF   !fraction of carbon to root and wood [-]
    8357. 

  8357.   REAL                   :: ROOTPT   !fraction of carbon flux to roots [-]
    8358. 

  8358.   REAL                   :: WOODPT   !fraction of carbon flux to wood [-]
    8359. 

  8359.   REAL                   :: STEMPT   !fraction of carbon flux to stem [-]
    8360. 

  8360.   REAL                   :: RESP     !leaf respiration [umol/m2/s]
    8361. 

  8361.   REAL                   :: RSSTEM   !stem respiration [g/m2/s]
    8362. 

  8362. 

  8363.   REAL                   :: FSW      !soil water factor for microbial respiration
    8364. 

  8364.   REAL                   :: FST      !soil temperature factor for microbial respiration
    8365. 

  8365.   REAL                   :: FNF      !foliage nitrogen adjustemt to respiration (<= 1)
    8366. 

  8366.   REAL                   :: TF       !temperature factor
    8367. 

  8367.   REAL                   :: RF       !respiration reduction factor (<= 1)
    8368. 

  8368.   REAL                   :: STDEL
    8369. 

  8369.   REAL                   :: STMSMN
    8370. 

  8370.   REAL                   :: SAPM     !stem area per unit mass (m2/g)
    8371. 

  8371.   REAL                   :: DIEST
    8372. 

  8372. ! -------------------------- constants -------------------------------
    8373. 

  8373.   REAL                   :: BF       !parameter for present wood allocation [-]
    8374. 

  8374.   REAL                   :: RSWOODC  !wood respiration coeficient [1/s]
    8375. 

  8375.   REAL                   :: STOVRC   !stem turnover coefficient [1/s]
    8376. 

  8376.   REAL                   :: RSDRYC   !degree of drying that reduces soil respiration [-]
    8377. 

  8377.   REAL                   :: RTOVRC   !root turnover coefficient [1/s]
    8378. 

  8378.   REAL                   :: WSTRC    !water stress coeficient [-]
    8379. 

  8379.   REAL                   :: LAIMIN   !minimum leaf area index [m2/m2]
    8380. 

  8380.   REAL                   :: XSAMIN   !minimum leaf area index [m2/m2]
    8381. 

  8381.   REAL                   :: SC
    8382. 

  8382.   REAL                   :: SD
    8383. 

  8383.   REAL                   :: VEGFRAC
    8384. 

  8384. 

  8385. ! Respiration as a function of temperature
    8386. 

  8386. 

  8387.   real :: r,x
    8388. 

  8388.           r(x) = exp(0.08*(x-298.16))
    8389. 

  8389. ! ---------------------------------------------------------------------------------
    8390. 

  8390. 

  8391. ! constants
    8392. 

  8392.     RTOVRC  = 2.0E-8        !original was 2.0e-8
    8393. 

  8393.     RSDRYC  = 40.0          !original was 40.0
    8394. 

  8394.     RSWOODC = 3.0E-10       !
    8395. 

  8395.     BF      = 0.90          !original was 0.90   ! carbon to roots
    8396. 

  8396.     WSTRC   = 100.0
    8397. 

  8397.     LAIMIN  = 0.05   
    8398. 

  8398.     XSAMIN  = 0.01
    8399. 

  8399. 

  8400.     SAPM    = 3.*0.001      ! m2/kg -->m2/g
    8401. 

  8401.     LFMSMN  = laimin/lapm
    8402. 

  8402.     STMSMN  = xsamin/sapm
    8403. 

  8403. ! ---------------------------------------------------------------------------------
    8404. 

  8404. 

  8405. ! respiration
    8406. 

  8406. 

  8407.      IF(IGS .EQ. 0.) THEN
    8408. 

  8408.        RF = 0.5
    8409. 

  8409.      ELSE
    8410. 

  8410.        RF = 1.0
    8411. 

  8411.      ENDIF
    8412. 

  8412.             
    8413. 

  8413.      FNF     = MIN( FOLN/MAX(1.E-06,FOLNMX(VEGTYP)), 1.0 )
    8414. 

  8414.      TF      = ARM(VEGTYP)**( (TV-298.16)/10. )
    8415. 

  8415.      RESP    = RMF25(VEGTYP) * TF * FNF * XLAI * RF * (1.-WSTRES) ! umol/m2/s
    8416. 

  8416.      RSLEAF  = MIN(LFMASS/DT,RESP*12.e-6)                         ! g/m2/s
    8417. 

  8417.      
    8418. 

  8418.      RSROOT  = RMR25(VEGTYP)*(RTMASS*1E-3)*TF *RF* 12.e-6         ! g/m2/s
    8419. 

  8419.      RSSTEM  = RMS25(VEGTYP)*(STMASS*1E-3)*TF *RF* 12.e-6         ! g/m2/s
    8420. 

  8420.      RSWOOD  = RSWOODC * R(TV) * WOOD*WDPOOL(VEGTYP)
    8421. 

  8421. 

  8422. ! carbon assimilation
    8423. 

  8423. ! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon;
    8424. 

  8424. 

  8425.      CARBFX  = PSN * 12.e-6              ! umol co2 /m2/ s -> g/m2/s carbon
    8426. 

  8426. 

  8427. ! fraction of carbon into leaf versus nonleaf
    8428. 

  8428. 

  8429.      LEAFPT = EXP(0.01*(1.-EXP(0.75*XLAI))*XLAI)
    8430. 

  8430.      IF(VEGTYP ==EBLFOREST) LEAFPT = EXP(0.01*(1.-EXP(0.50*XLAI))*XLAI)
    8431. 

  8431. 

  8432.      NONLEF = 1.0 - LEAFPT
    8433. 

  8433.      STEMPT = XLAI/10.0
    8434. 

  8434.      LEAFPT = LEAFPT - STEMPT
    8435. 

  8435. 

  8436. !  fraction of carbon into wood versus root
    8437. 

  8437. 

  8438.      IF(WOOD.GT.0) THEN
    8439. 

  8439.         WOODF = (1.-EXP(-BF*(WRRAT(VEGTYP)*RTMASS/WOOD))/BF)*WDPOOL(VEGTYP)
    8440. 

  8440.      ELSE
    8441. 

  8441.         WOODF = 0.
    8442. 

  8442.      ENDIF
    8443. 

  8443. 

  8444.      ROOTPT = NONLEF*(1.-WOODF)
    8445. 

  8445.      WOODPT = NONLEF*WOODF
    8446. 

  8446. 

  8447. ! leaf and root turnover per time step
    8448. 

  8448. 

  8449.      LFTOVR = LTOVRC(VEGTYP)*1.E-6*LFMASS
    8450. 

  8450.      STTOVR = LTOVRC(VEGTYP)*1.E-6*STMASS
    8451. 

  8451.      RTTOVR = RTOVRC*RTMASS
    8452. 

  8452.      WDTOVR = 9.5E-10*WOOD
    8453. 

  8453. 

  8454. ! seasonal leaf die rate dependent on temp and water stress
    8455. 

  8455. ! water stress is set to 1 at permanent wilting point
    8456. 

  8456. 

  8457.      SC  = EXP(-0.3*MAX(0.,TV-TDLEF(VEGTYP))) * (LFMASS/120.) 
    8458. 

  8458.      SD  = EXP((WSTRES-1.)*WSTRC)
    8459. 

  8459.      DIELF = LFMASS*1.E-6*(DILEFW(VEGTYP) * SD + DILEFC(VEGTYP)*SC)
    8460. 

  8460.      DIEST = STMASS*1.E-6*(DILEFW(VEGTYP) * SD + DILEFC(VEGTYP)*SC)
    8461. 

  8461. 

  8462. ! calculate growth respiration for leaf, rtmass and wood
    8463. 

  8463. 

  8464.      GRLEAF = MAX(0.0,FRAGR(VEGTYP)*(LEAFPT*CARBFX - RSLEAF))
    8465. 

  8465.      GRSTEM = MAX(0.0,FRAGR(VEGTYP)*(STEMPT*CARBFX - RSSTEM))
    8466. 

  8466.      GRROOT = MAX(0.0,FRAGR(VEGTYP)*(ROOTPT*CARBFX - RSROOT))
    8467. 

  8467.      GRWOOD = MAX(0.0,FRAGR(VEGTYP)*(WOODPT*CARBFX - RSWOOD))
    8468. 

  8468. 

  8469. ! Impose lower T limit for photosynthesis
    8470. 

  8470. 

  8471.      ADDNPPLF = MAX(0.,LEAFPT*CARBFX - GRLEAF-RSLEAF)
    8472. 

  8472.      ADDNPPST = MAX(0.,STEMPT*CARBFX - GRSTEM-RSSTEM)
    8473. 

  8473.      IF(TV.LT.TMIN(VEGTYP)) ADDNPPLF =0.
    8474. 

  8474.      IF(TV.LT.TMIN(VEGTYP)) ADDNPPST =0.
    8475. 

  8475. 

  8476. ! update leaf, root, and wood carbon
    8477. 

  8477. ! avoid reducing leaf mass below its minimum value but conserve mass
    8478. 

  8478. 

  8479.      LFDEL = (LFMASS - LFMSMN)/DT
    8480. 

  8480.      STDEL = (STMASS - STMSMN)/DT
    8481. 

  8481.      DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR)
    8482. 

  8482.      DIEST = MIN(DIEST,STDEL+ADDNPPST-STTOVR)
    8483. 

  8483. 

  8484. ! net primary productivities
    8485. 

  8485. 

  8486.      NPPL   = MAX(ADDNPPLF,-LFDEL)
    8487. 

  8487.      NPPS   = MAX(ADDNPPST,-STDEL)
    8488. 

  8488.      NPPR   = ROOTPT*CARBFX - RSROOT - GRROOT
    8489. 

  8489.      NPPW   = WOODPT*CARBFX - RSWOOD - GRWOOD
    8490. 

  8490. 

  8491. ! masses of plant components
    8492. 

  8492. 

  8493.      LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT
    8494. 

  8494.      STMASS = STMASS + (NPPS-STTOVR-DIEST)*DT   ! g/m2
    8495. 

  8495.      RTMASS = RTMASS + (NPPR-RTTOVR)      *DT
    8496. 

  8496. 

  8497.      IF(RTMASS.LT.0.0) THEN
    8498. 

  8498.            RTTOVR = NPPR
    8499. 

  8499.            RTMASS = 0.0
    8500. 

  8500.      ENDIF
    8501. 

  8501.      WOOD = (WOOD+(NPPW-WDTOVR)*DT)*WDPOOL(VEGTYP)
    8502. 

  8502. 

  8503. ! soil carbon budgets
    8504. 

  8504. 

  8505.      FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF)*DT
    8506. 

  8506. 

  8507.      FST = 2.0**( (STC(1)-283.16)/10. )
    8508. 

  8508.      FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT)
    8509. 

  8509.      RSSOIL = FSW * FST * MRP(VEGTYP)* MAX(0.,FASTCP*1.E-3)*12.E-6
    8510. 

  8510. 

  8511.      STABLC = 0.1*RSSOIL
    8512. 

  8512.      FASTCP = FASTCP - (RSSOIL + STABLC)*DT
    8513. 

  8513.      STBLCP = STBLCP + STABLC*DT
    8514. 

  8514. 

  8515. !  total carbon flux
    8516. 

  8516. 

  8517.      CFLUX  = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM &
    8518. 

  8518.               + RSSOIL + GRLEAF + GRROOT + GRWOOD                ! g/m2/s
    8519. 

  8519. 

  8520. ! for outputs
    8521. 

  8521. 

  8522.      GPP    = CARBFX                                             !g/m2/s C
    8523. 

  8523.      NPP    = NPPL + NPPW + NPPR                                 !g/m2/s C
    8524. 

  8524.      AUTORS = RSROOT + RSWOOD  + RSLEAF +  &                     !g/m2/s C
    8525. 

  8525.               GRLEAF + GRROOT + GRWOOD                           !g/m2/s C
    8526. 

  8526.      HETERS = RSSOIL                                             !g/m2/s C
    8527. 

  8527.      NEE    = (AUTORS + HETERS - GPP)*44./12.                    !g/m2/s CO2
    8528. 

  8528.      TOTSC  = FASTCP + STBLCP                                    !g/m2   C
    8529. 

  8529.      TOTLB  = LFMASS + RTMASS + WOOD                             !g/m2   C
    8530. 

  8530. 

  8531. ! leaf area index and stem area index
    8532. 

  8532. 

  8533.      XLAI    = MAX(LFMASS*LAPM,LAIMIN)
    8534. 

  8534.      XSAI    = MAX(STMASS*SAPM,XSAMIN)
    8535. 

  8535.     
    8536. 

  8536.   END SUBROUTINE CO2FLUX
    8537. 

  8537. ! ==================================================================================================
    8538. 

  8538. ! ------------------------------------------------------------------------------------------
    8539. 

  8539.   SUBROUTINE BVOCFLUX(VOCFLX,  VEGTYP,  VEGFRAC,  APAR,   TV )
    8540. 

  8540.     use NOAHMP_VEG_PARAMETERS , ONLY : SLAREA, EPS
    8541. 

  8541. ! ------------------------------------------------------------------------------------------
    8542. 

  8542. 

  8543. ! ------------------------------------------------------------------------------------------
    8544. 

  8544.       implicit none
    8545. 

  8545. ! ------------------------------------------------------------------------------------------
    8546. 

  8546. 

  8547. ! ------------------------ code history ---------------------------
    8548. 

  8548. ! source file:       BVOC
    8549. 

  8549. ! purpose:           BVOC emissions
    8550. 

  8550. ! DESCRIPTION:
    8551. 

  8551. ! Volatile organic compound emission 
    8552. 

  8552. ! This code simulates volatile organic compound emissions
    8553. 

  8553. ! following the algorithm presented in Guenther, A., 1999: Modeling
    8554. 

  8554. ! Biogenic Volatile Organic Compound Emissions to the Atmosphere. In
    8555. 

  8555. ! Reactive Hydrocarbons in the Atmosphere, Ch. 3
    8556. 

  8556. ! This model relies on the assumption that 90% of isoprene and monoterpene
    8557. 

  8557. ! emissions originate from canopy foliage:
    8558. 

  8558. !    E = epsilon * gamma * density * delta
    8559. 

  8559. ! The factor delta (longterm activity factor) applies to isoprene emission
    8560. 

  8560. ! from deciduous plants only. We neglect this factor at the present time.
    8561. 

  8561. ! This factor is discussed in Guenther (1997).
    8562. 

  8562. ! Subroutine written to operate at the patch level.
    8563. 

  8563. ! IN FINAL IMPLEMENTATION, REMEMBER:
    8564. 

  8564. ! 1. may wish to call this routine only as freq. as rad. calculations
    8565. 

  8565. ! 2. may wish to place epsilon values directly in pft-physiology file
    8566. 

  8566. ! ------------------------ input/output variables -----------------
    8567. 

  8567. ! input
    8568. 

  8568.   integer                     ,INTENT(IN) :: vegtyp  !vegetation type 
    8569. 

  8569.   real                        ,INTENT(IN) :: vegfrac !green vegetation fraction [0.0-1.0]
    8570. 

  8570.   real                        ,INTENT(IN) :: apar    !photosynthesis active energy by canopy (w/m2)
    8571. 

  8571.   real                        ,INTENT(IN) :: tv      !vegetation canopy temperature (k)
    8572. 

  8572. 

  8573. ! output
    8574. 

  8574.   real                        ,INTENT(OUT) :: vocflx(5) ! voc fluxes [ug C m-2 h-1]
    8575. 

  8575. 

  8576. ! Local Variables
    8577. 

  8577. 

  8578.   real, parameter :: R      = 8.314    ! univ. gas constant [J K-1 mol-1]
    8579. 

  8579.   real, parameter :: alpha  = 0.0027   ! empirical coefficient
    8580. 

  8580.   real, parameter :: cl1    = 1.066    ! empirical coefficient
    8581. 

  8581.   real, parameter :: ct1    = 95000.0  ! empirical coefficient [J mol-1]
    8582. 

  8582.   real, parameter :: ct2    = 230000.0 ! empirical coefficient [J mol-1]
    8583. 

  8583.   real, parameter :: ct3    = 0.961    ! empirical coefficient
    8584. 

  8584.   real, parameter :: tm     = 314.0    ! empirical coefficient [K]
    8585. 

  8585.   real, parameter :: tstd   = 303.0    ! std temperature [K]
    8586. 

  8586.   real, parameter :: bet    = 0.09     ! beta empirical coefficient [K-1]
    8587. 

  8587. 

  8588.   integer ivoc        ! do-loop index
    8589. 

  8589.   integer ityp        ! do-loop index
    8590. 

  8590.   real epsilon(5)
    8591. 

  8591.   real gamma(5)
    8592. 

  8592.   real density
    8593. 

  8593.   real elai
    8594. 

  8594.   real par,cl,reciprod,ct
    8595. 

  8595. 

  8596. ! epsilon :
    8597. 

  8597. 

  8598.     do ivoc = 1, 5
    8599. 

  8599.     epsilon(ivoc) = eps(VEGTYP,ivoc)
    8600. 

  8600.     end do
    8601. 

  8601. 

  8602. ! gamma : Activity factor. Units [dimensionless]
    8603. 

  8603. 

  8604.       reciprod = 1. / (R * tv * tstd)
    8605. 

  8605.       ct = exp(ct1 * (tv - tstd) * reciprod) / &
    8606. 

  8606.            (ct3 + exp(ct2 * (tv - tm) * reciprod))
    8607. 

  8607. 

  8608.       par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s)
    8609. 

  8609.       cl  = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5)
    8610. 

  8610. 

  8611.    gamma(1) = cl * ct ! for isoprenes
    8612. 

  8612. 

  8613.    do ivoc = 2, 5
    8614. 

  8614.    gamma(ivoc) = exp(bet * (tv - tstd))
    8615. 

  8615.    end do
    8616. 

  8616. 

  8617. ! Foliage density
    8618. 

  8618. 

  8619. ! transform vegfrac to lai      
    8620. 

  8620. 

  8621.    elai    = max(0.0,-6.5/2.5*alog((1.-vegfrac)))
    8622. 

  8622.    density = elai / (slarea(VEGTYP) * 0.5)
    8623. 

  8623. 

  8624. ! calculate the voc flux
    8625. 

  8625. 

  8626.    do ivoc = 1, 5
    8627. 

  8627.    vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density
    8628. 

  8628.    end do
    8629. 

  8629. 

  8630.    end subroutine bvocflux
    8631. 

  8631. ! ==================================================================================================
    8632. 

  8632. ! ********************************* end of carbon subroutines *****************************
    8633. 

  8633. ! ==================================================================================================
    8634. 

  8634.   SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,SLDPTH,ZSOIL,NSOIL,ISURBAN)
    8635. 

  8635.    
    8636. 

  8636. !niu  use module_sf_noahlsm_param_init
    8637. 

  8637. 

  8638.     IMPLICIT NONE
    8639. 

  8639. ! ----------------------------------------------------------------------
    8640. 

  8640. ! Internally set (default valuess)
    8641. 

  8641. ! all soil and vegetation parameters required for the execusion oF
    8642. 

  8642. ! the Noah lsm are defined in VEGPARM.TBL, SOILPARM.TB, and GENPARM.TBL.
    8643. 

  8643. ! ----------------------------------------------------------------------
    8644. 

  8644. !     Vegetation parameters:
    8645. 

  8645. !             CMXTBL: MAX CNPY Capacity
    8646. 

  8646. !              NROOT: Rooting depth
    8647. 

  8647. !
    8648. 

  8648. ! ----------------------------------------------------------------------
    8649. 

  8649. !      Soil parameters:
    8650. 

  8650. !       SSATPSI: SAT (saturation) soil potential
    8651. 

  8651. !        SSATDW: SAT soil diffusivity
    8652. 

  8652. !           F1: Soil thermal diffusivity/conductivity coef.
    8653. 

  8653. !        QUARTZ: Soil quartz content
    8654. 

  8654. !  Modified by F. Chen (12/22/97)  to use the STATSGO soil map
    8655. 

  8655. !  Modified By F. Chen (01/22/00)  to include PLaya, Lava, and White San
    8656. 

  8656. !  Modified By F. Chen (08/05/02)  to include additional parameters for the Noah
    8657. 

  8657. ! NOTE: SATDW = BB*SATDK*(SATPSI/MAXSMC)
    8658. 

  8658. !         F11 = ALOG10(SATPSI) + BB*ALOG10(MAXSMC) + 2.0
    8659. 

  8659. !       REFSMC1=MAXSMC*(5.79E-9/SATDK)**(1/(2*BB+3)) 5.79E-9 m/s= 0.5 mm
    8660. 

  8660. !       REFSMC=REFSMC1+1./3.(MAXSMC-REFSMC1)
    8661. 

  8661. !       WLTSMC1=MAXSMC*(200./SATPSI)**(-1./BB)    (Wetzel and Chang, 198
    8662. 

  8662. !       WLTSMC=WLTSMC1-0.5*WLTSMC1
    8663. 

  8663. ! Note: the values for playa is set for it to have a thermal conductivit
    8664. 

  8664. ! as sand and to have a hydrulic conductivity as clay
    8665. 

  8665. !
    8666. 

  8666. ! ----------------------------------------------------------------------
    8667. 

  8667. ! BLANK        OCEAN/SEA
    8668. 

  8668. !       CSOIL_DATA: soil heat capacity [J M-3 K-1]
    8669. 

  8669. !       ZBOT_DATA: depth[M] of lower boundary soil temperature
    8670. 

  8670. !       CZIL_DATA: calculate roughness length of heat
    8671. 

  8671. !       SMLOW_DATA and MHIGH_DATA: two soil moisture wilt, soil moisture referen
    8672. 

  8672. !                 parameters
    8673. 

  8673. ! Set maximum number of soil- and veg- in data statement.
    8674. 

  8674. ! ----------------------------------------------------------------------
    8675. 

  8675.     INTEGER, PARAMETER     :: MAX_SOILTYP=30,MAX_VEGTYP=30
    8676. 

  8676. 

  8677. ! Veg parameters
    8678. 

  8678.     INTEGER, INTENT(IN)    :: VEGTYP
    8679. 

  8679.     INTEGER, INTENT(IN)    :: ISURBAN
    8680. 

  8680. ! Soil parameters
    8681. 

  8681.     INTEGER, INTENT(IN)    :: SOILTYP
    8682. 

  8682. ! General parameters
    8683. 

  8683.     INTEGER, INTENT(IN)    :: SLOPETYP
    8684. 

  8684. ! General parameters
    8685. 

  8685.     INTEGER, INTENT(IN)    :: NSOIL
    8686. 

  8686. ! Layer parameters
    8687. 

  8687.     REAL,DIMENSION(NSOIL),INTENT(IN) :: SLDPTH
    8688. 

  8688.     REAL,DIMENSION(NSOIL),INTENT(IN) :: ZSOIL
    8689. 

  8689. 

  8690. ! Locals
    8691. 

  8691.     REAL    :: REFDK
    8692. 

  8692.     REAL    :: REFKDT
    8693. 

  8693.     REAL    :: FRZK
    8694. 

  8694.     REAL                   :: FRZFACT
    8695. 

  8695.     INTEGER                :: I
    8696. 

  8696.     CHARACTER(len=256)     :: message
    8697. 

  8697. ! ----------------------------------------------------------------------
    8698. 

  8698. !
    8699. 

  8699.     IF (SOILTYP .gt. SLCATS) THEN
    8700. 

  8700.        call wrf_message('SOILTYP must be less than SLCATS:')
    8701. 

  8701.        write(message, '("SOILTYP = ", I6, ";    SLCATS = ", I6)') SOILTYP, SLCATS
    8702. 

  8702.        call wrf_message(trim(message))
    8703. 

  8703.        call wrf_error_fatal ('REDPRM: Error: too many input soil types')
    8704. 

  8704.     END IF
    8705. 

  8705.     IF (VEGTYP .gt. LUCATS) THEN
    8706. 

  8706.        call wrf_message('VEGTYP must be less than LUCATS:')
    8707. 

  8707.        write(message, '("VEGTYP = ", I6, ";    LUCATS = ", I6)') VEGTYP, LUCATS
    8708. 

  8708.        call wrf_message(trim(message))
    8709. 

  8709.        call wrf_error_fatal ('Error: too many input landuse types')
    8710. 

  8710.     END IF
    8711. 

  8711. 

  8712. ! ----------------------------------------------------------------------
    8713. 

  8713. !  SET-UP SOIL PARAMETERS
    8714. 

  8714. ! ----------------------------------------------------------------------
    8715. 

  8715.     CSOIL  = CSOIL_DATA
    8716. 

  8716.     BEXP   = BB (SOILTYP)
    8717. 

  8717.     DKSAT  = SATDK (SOILTYP)
    8718. 

  8718.     DWSAT  = SATDW (SOILTYP)
    8719. 

  8719.     F1     = F11 (SOILTYP)
    8720. 

  8720.     PSISAT = SATPSI (SOILTYP)
    8721. 

  8721.     QUARTZ = QTZ (SOILTYP)
    8722. 

  8722.     SMCDRY = DRYSMC (SOILTYP)
    8723. 

  8723.     SMCMAX = MAXSMC (SOILTYP)
    8724. 

  8724.     SMCREF = REFSMC (SOILTYP)
    8725. 

  8725.     SMCWLT = WLTSMC (SOILTYP)
    8726. 

  8726. 

  8727.     IF(VEGTYP==ISURBAN)THEN
    8728. 

  8728.        SMCMAX = 0.45 
    8729. 

  8729.        SMCREF = 0.42 
    8730. 

  8730.        SMCWLT = 0.40 
    8731. 

  8731.        SMCDRY = 0.40 
    8732. 

  8732.        CSOIL  = 3.E6
    8733. 

  8733.     ENDIF
    8734. 

  8734. 

  8735. ! ----------------------------------------------------------------------
    8736. 

  8736. ! Set-up universal parameters (not dependent on SOILTYP, VEGTYP)
    8737. 

  8737. ! ----------------------------------------------------------------------
    8738. 

  8738.     ZBOT   = ZBOT_DATA
    8739. 

  8739.     CZIL   = CZIL_DATA
    8740. 

  8740. 

  8741.     FRZK   = FRZK_DATA
    8742. 

  8742.     REFDK  = REFDK_DATA
    8743. 

  8743.     REFKDT = REFKDT_DATA
    8744. 

  8744.     KDT    = REFKDT * DKSAT / REFDK
    8745. 

  8745.     SLOPE  = SLOPE_DATA (SLOPETYP)
    8746. 

  8746. 

  8747. ! adjust FRZK parameter to actual soil type: FRZK * FRZFACT
    8748. 

  8748. 

  8749.     if(SOILTYP /= 14) then
    8750. 

  8750.       FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468)
    8751. 

  8751.       FRZX = FRZK * FRZFACT
    8752. 

  8752.     end if
    8753. 

  8753. 

  8754. !    write(*,*) FRZK, FRZX, KDT, SLOPE, SLOPETYP
    8755. 

  8755. ! ----------------------------------------------------------------------
    8756. 

  8756. ! SET-UP VEGETATION PARAMETERS
    8757. 

  8757. ! ----------------------------------------------------------------------
    8758. 

  8758.     ! Six redprm_canres variables:
    8759. 

  8759.     TOPT = TOPT_DATA
    8760. 

  8760.     RGL = RGLTBL (VEGTYP)
    8761. 

  8761.     RSMAX = RSMAX_DATA
    8762. 

  8762.     RSMIN = RSTBL (VEGTYP)
    8763. 

  8763.     HS = HSTBL (VEGTYP)
    8764. 

  8764.     NROOT = NROTBL (VEGTYP)
    8765. 

  8765. 

  8766.     IF(VEGTYP==ISURBAN)THEN
    8767. 

  8767.        RSMIN=400.0
    8768. 

  8768.     ENDIF
    8769. 

  8769. 

  8770. !    SHDFAC = SHDTBL(VEGTYP)
    8771. 

  8771. !    IF (VEGTYP .eq. BARE) SHDFAC = 0.0
    8772. 

  8772. 

  8773.     IF (NROOT .gt. NSOIL) THEN
    8774. 

  8774.        WRITE (*,*) 'Warning: too many root layers'
    8775. 

  8775.        write (*,*) 'NROOT = ', nroot
    8776. 

  8776.        write (*,*) 'NSOIL = ', nsoil
    8777. 

  8777.        call wrf_error_fatal("STOP in Noah-MP")
    8778. 

  8778.     END IF
    8779. 

  8779. 

  8780. ! ----------------------------------------------------------------------
    8781. 

  8781. 

  8782.   END  SUBROUTINE REDPRM
    8783. 

  8783. !jref:start; calculate effective parameters for PBL and diagnostics
    8784. 

  8784. ! ==================================================================
    8785. 

  8785.   SUBROUTINE EPARM(ILOC  ,JLOC  ,TAH  ,TGB    ,FVEG , & 
    8786. 

  8786.                    CHV   ,CHB   ,VEG  ,CHSTAR ,TSTAR) !inout
    8787. 

  8787. 

  8788. ! ------------------------------------------------------------------
    8789. 

  8789. ! calculate effective parameters for diagnostic terms.
    8790. 

  8790. ! Joakim Refslund, 2011
    8791. 

  8791. ! ------------------------------------------------------------------
    8792. 

  8792.   IMPLICIT NONE
    8793. 

  8793. ! ------------------------------------------------------------------
    8794. 

  8794. ! input
    8795. 

  8795.   INTEGER, INTENT(IN)  :: ILOC
    8796. 

  8796.   INTEGER, INTENT(IN)  :: JLOC
    8797. 

  8797.   REAL   , INTENT(IN)  :: TAH     !canopy air  temperature (k)
    8798. 

  8798.   REAL   , INTENT(IN)  :: TGB     !ground surface  temp. [k]
    8799. 

  8799.   REAL   , INTENT(IN)  :: FVEG    !greeness vegetation fraction (-)
    8800. 

  8800.   REAL   , INTENT(IN)  :: CHV     !coefficient sens. heat canopy air to atm
    8801. 

  8801.   REAL   , INTENT(IN)  :: CHB     !coefficient sens. heat ground to atm
    8802. 

  8802.   LOGICAL, INTENT(IN)  :: VEG     !Veg.Fraction based on LAI/SAI - NOT min. value
    8803. 

  8803. 

  8804. ! output  
    8805. 

  8805.   REAL, INTENT(OUT) :: CHSTAR  !effective sensible heat exchange coefficient
    8806. 

  8806.   REAL, INTENT(OUT) :: TSTAR   !effective skin temperature
    8807. 

  8807. 

  8808. ! local
    8809. 

  8809.   REAL              :: W       !weight
    8810. 

  8810. 

  8811. !  INTEGER, INTENT(IN)    :: VEGTYP
    8812. 

  8812. 

  8813. ! ------------------------------------------------------------------
    8814. 

  8814. ! effective exchange coefficient for PBL.
    8815. 

  8815.   IF (VEG) THEN
    8816. 

  8816.     CHSTAR  = FVEG*CHV +(1.-FVEG)*CHB
    8817. 

  8817.     W = FVEG*CHV*TAH+(1.-FVEG)*CHB*TGB
    8818. 

  8818.     TSTAR = W/CHSTAR
    8819. 

  8819.   ELSE
    8820. 

  8820.     CHSTAR = CHB
    8821. 

  8821.     TSTAR  = TGB
    8822. 

  8822.   ENDIF
    8823. 

  8823. 

  8824.   END SUBROUTINE EPARM
    8825. 

  8825. !jref:end
    8826. 

  8826. ! ==================================================================================================
    8827. 

  8827. 

  8828.   subroutine noahmp_options(idveg     ,iopt_crs  ,iopt_btr  ,iopt_run  ,iopt_sfc  ,iopt_frz , & 
    8829. 

  8829.                              iopt_inf  ,iopt_rad  ,iopt_alb  ,iopt_snf  ,iopt_tbot, iopt_stc )
    8830. 

  8830. 

  8831.   implicit none
    8832. 

  8832. 

  8833.   INTEGER,  INTENT(IN) :: idveg     !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1
    8834. 

  8834.   INTEGER,  INTENT(IN) :: iopt_crs  !canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)
    8835. 

  8835.   INTEGER,  INTENT(IN) :: iopt_btr  !soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)
    8836. 

  8836.   INTEGER,  INTENT(IN) :: iopt_run  !runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS)
    8837. 

  8837.   INTEGER,  INTENT(IN) :: iopt_sfc  !surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97)
    8838. 

  8838.   INTEGER,  INTENT(IN) :: iopt_frz  !supercooled liquid water (1-> NY06; 2->Koren99)
    8839. 

  8839.   INTEGER,  INTENT(IN) :: iopt_inf  !frozen soil permeability (1-> NY06; 2->Koren99)
    8840. 

  8840.   INTEGER,  INTENT(IN) :: iopt_rad  !radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg)
    8841. 

  8841.   INTEGER,  INTENT(IN) :: iopt_alb  !snow surface albedo (1->BATS; 2->CLASS)
    8842. 

  8842.   INTEGER,  INTENT(IN) :: iopt_snf  !rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)
    8843. 

  8843.   INTEGER,  INTENT(IN) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->Noah)
    8844. 

  8844. 

  8845.   INTEGER,  INTENT(IN) :: iopt_stc  !snow/soil temperature time scheme (only layer 1)
    8846. 

  8846.                                     ! 1 -> semi-implicit; 2 -> full implicit (original Noah)
    8847. 

  8847. 

  8848. ! -------------------------------------------------------------------------------------------------
    8849. 

  8849. 

  8850.   dveg = idveg
    8851. 

  8851.   
    8852. 

  8852.   opt_crs  = iopt_crs  
    8853. 

  8853.   opt_btr  = iopt_btr  
    8854. 

  8854.   opt_run  = iopt_run  
    8855. 

  8855.   opt_sfc  = iopt_sfc  
    8856. 

  8856.   opt_frz  = iopt_frz  
    8857. 

  8857.   opt_inf  = iopt_inf  
    8858. 

  8858.   opt_rad  = iopt_rad  
    8859. 

  8859.   opt_alb  = iopt_alb  
    8860. 

  8860.   opt_snf  = iopt_snf  
    8861. 

  8861.   opt_tbot = iopt_tbot 
    8862. 

  8862.   opt_stc  = iopt_stc
    8863. 

  8863.   
    8864. 

  8864.   end subroutine noahmp_options
    8865. 

  8865.  
    8866. 

  8866. END MODULE NOAHMP_ROUTINES
    8867. 

  8867. ! ==================================================================================================
    8868. 

  8868. 

  8869. MODULE MODULE_SF_NOAHMPLSM
    8870. 

  8870. 

  8871.   USE NOAHMP_ROUTINES
    8872. 

  8872.   USE NOAHMP_GLOBALS
    8873. 

  8873.   USE NOAHMP_VEG_PARAMETERS
    8874. 

  8874. 

  8875. END MODULE MODULE_SF_NOAHMPLSM
    8876. 

  8876.