MODULE module_sf_ssib 1
!This version of SSiB land-surface model includes a multi-layer snow scheme
!For better results, please use the SSiB vegetation map (geog_data_res in WPS)
!References for the SSiB:
!Xue et al. 1991, J. Climate, 4, 345-364.
!Sun and Xue, 2001, Adv. in Atmos. Sci, 18, 335-354.
!Xue et al., 2003, J. Geophy. Res. 108, D22, doi: 10.1029/2002JD003174.
!Coding by Fernando De Sales and Zhengxin Liu (2011)
REAL, PARAMETER :: CPAIR = 1004.6 &
,STEFAN = 5.669 * 10E-9 &
,GRAV = 9.81 &
,VKC = 0.4 &
,PIE = 3.14159265 &
,TIMCON = PIE/86400. &
,CLAI = 4.2 * 1000. * 0.2 &
,CW = 4.2 * 1000. * 1000. &
,TF = 273.16 &
,GASR = 287.05 &
,HLAT = 2.52E6 &
,SNOMEL = 370518.5 * 1000.
INTEGER, PARAMETER :: ITRUNK = 3
!crr snow
REAL, PARAMETER :: SSISNOW = 0.04 &
,FLMIN = 0.03 &
,FLMAX = 0.10 &
,DZMIN = 0.002 &
,WOMIN = 0.0004 &
,CL = 4212.7 &
,DLM = 3.335d5 &
,RHOWATER = 1000.0 &
,DICE = 920.0 &
,DKSATSNOW= 0.01 &
,SNODEP_CR= 0.07
INTEGER, PARAMETER :: N = 3 &
,N1 = 4 &
,N2 = 4
!crr snow
!ssib vegetation parameters
REAL, DIMENSION (13,2,3,2) :: tran0,ref0
REAL, DIMENSION (13,12,2) :: green0,vcover0,zlt0
REAL, DIMENSION (13,2,3) :: rstpar0
REAL, DIMENSION (13,12) :: z000,d0,z20,z10,rdc0,rbc0
REAL, DIMENSION (13,3) :: depth0,soref0
REAL, DIMENSION (13,2) :: chil0,topt0,tl0,tu0,defac0,ph10,ph20,rootd0
REAL, DIMENSION (13) :: bee0,phsat0,poros0,satco0,slope0
!
data tran0/ &
0.5000000E-01, 0.5000000E-01, 0.5000000E-01, 0.5000000E-01, &
0.5000000E-01, 0.5000000E-01, 0.7000000E-01, 0.5000000E-01, &
0.5000000E-01, 0.5000000E-01, 0.1000000E-02, 0.5000000E-01, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.7000000E-01, 0.1000000E-02, 0.7000000E-01, &
0.1000000E-02, 0.7000000E-01, 0.1000000E-02, 0.7000000E-01, &
0.1000000E-02, &
0.2500000E+00, 0.2500000E+00, 0.1500000E+00, 0.1000000E+00, &
0.1000000E+00, 0.2500000E+00, 0.2475000E+00, 0.2500000E+00, &
0.2500000E+00, 0.2500000E+00, 0.1000000E-02, 0.2500000E+00, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.2475000E+00, 0.1000000E-02, 0.2475000E+00, &
0.1000000E-02, 0.2475000E+00, 0.1000000E-02, 0.2475000E+00, &
0.1000000E-02, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.2200000E+00, 0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.2200000E+00, 0.1000000E-02, 0.2200000E+00, &
0.1000000E-02, 0.2200000E+00, 0.1000000E-02, 0.2200000E+00, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.3750000E+00, 0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.3750000E+00, 0.1000000E-02, 0.3750000E+00, &
0.1000000E-02, 0.3750000E+00, 0.1000000E-02, 0.3750000E+00, &
0.1000000E-02, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00/
data ref0/ &
0.1000000E+00, 0.1000000E+00, 0.7000000E-01, 0.7000000E-01, &
0.7000000E-01, 0.1000000E+00, 0.1050000E+00, 0.1000000E+00, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-02, 0.1000000E+00, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.1050000E+00, 0.1000000E-02, 0.1050000E+00, &
0.1000000E-02, 0.1050000E+00, 0.1000000E-02, 0.1050000E+00, &
0.1000000E-02, &
0.4500000E+00, 0.4500000E+00, 0.4000000E+00, 0.3500000E+00, &
0.3500000E+00, 0.4500000E+00, 0.5775000E+00, 0.4500000E+00, &
0.4500000E+00, 0.4500000E+00, 0.1000000E-02, 0.4500000E+00, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
0.1000000E-02, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.1600000E+00, 0.1600000E+00, 0.1600000E+00, 0.1600000E+00, &
0.1600000E+00, 0.1600000E+00, 0.3600000E+00, 0.1600000E+00, &
0.1600000E+00, 0.1600000E+00, 0.1000000E-02, 0.1600000E+00, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.3600000E+00, 0.1000000E-02, 0.3600000E+00, &
0.1000000E-02, 0.3600000E+00, 0.1000000E-02, 0.3600000E+00, &
0.1000000E-02, &
0.3900000E+00, 0.3900000E+00, 0.3900000E+00, 0.3900000E+00, &
0.3900000E+00, 0.3900000E+00, 0.5775000E+00, 0.3900000E+00, &
0.3900000E+00, 0.3900000E+00, 0.1000000E-02, 0.3900000E+00, &
0.1000000E-02, &
0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
0.1000000E-02, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00/
data green0/ &
0.9050000E+00, 0.2564000E-01, 0.8680600E+00, 0.9132400E+00, &
0.2475200E+00, 0.6319100E+00, 0.5681800E+00, 0.7978700E+00, &
0.8364300E+00, 0.4512600E+00, 0.1000000E-03, 0.2083300E+00, &
0.1000000E-03, &
0.9050000E+00, 0.2564000E-01, 0.8717700E+00, 0.9170300E+00, &
0.2475200E+00, 0.6566600E+00, 0.6218900E+00, 0.5319100E+00, &
0.7172100E+00, 0.4512600E+00, 0.1000000E-03, 0.2083300E+00, &
0.1000000E-03, &
0.9050000E+00, 0.4153800E+00, 0.8847300E+00, 0.9226600E+00, &
0.2475200E+00, 0.5176000E+00, 0.6637200E+00, 0.3623200E+00, &
0.2577300E+00, 0.4512600E+00, 0.1000000E-03, 0.4411800E+00, &
0.1000000E-03, &
0.9050000E+00, 0.7594900E+00, 0.9061000E+00, 0.9247000E+00, &
0.6637200E+00, 0.6527400E+00, 0.6972100E+00, 0.5681800E+00, &
0.7246400E+00, 0.4512600E+00, 0.1000000E-03, 0.7594900E+00, &
0.1000000E-03, &
0.9050000E+00, 0.8875700E+00, 0.9164200E+00, 0.9266400E+00, &
0.8104700E+00, 0.6527400E+00, 0.8104700E+00, 0.5681800E+00, &
0.1736100E+00, 0.4512600E+00, 0.1000000E-03, 0.8875700E+00, &
0.1000000E-03, &
0.9050000E+00, 0.9252000E+00, 0.9259300E+00, 0.9045800E+00, &
0.8680600E+00, 0.7246400E+00, 0.9079900E+00, 0.5681800E+00, &
0.5681800E+00, 0.6218900E+00, 0.1000000E-03, 0.9252000E+00, &
0.1000000E-03, &
0.9050000E+00, 0.8364300E+00, 0.9293700E+00, 0.9021600E+00, &
0.6040900E+00, 0.8712500E+00, 0.8132000E+00, 0.5681800E+00, &
0.5681800E+00, 0.9200800E+00, 0.1000000E-03, 0.8364300E+00, &
0.1000000E-03, &
0.9050000E+00, 0.6967200E+00, 0.8209400E+00, 0.9126500E+00, &
0.5854000E+00, 0.7966000E+00, 0.3943200E+00, 0.8680600E+00, &
0.7246400E+00, 0.6970300E+00, 0.1000000E-03, 0.6967200E+00, &
0.1000000E-03, &
0.9050000E+00, 0.3306900E+00, 0.7123000E+00, 0.8982800E+00, &
0.4990000E+00, 0.7654600E+00, 0.4434600E+00, 0.6505600E+00, &
0.8403400E+00, 0.7567000E-01, 0.1000000E-03, 0.3439200E+00, &
0.1000000E-03, &
0.9050000E+00, 0.1656400E+00, 0.6145700E+00, 0.8548200E+00, &
0.3834400E+00, 0.6146100E+00, 0.5434800E+00, 0.5154600E+00, &
0.8680600E+00, 0.4512600E+00, 0.1000000E-03, 0.1785700E+00, &
0.1000000E-03, &
0.9050000E+00, 0.1538000E-01, 0.8599500E+00, 0.8733600E+00, &
0.2487600E+00, 0.5086500E+00, 0.5531000E+00, 0.6302500E+00, &
0.8875700E+00, 0.4512600E+00, 0.1000000E-03, 0.1470600E+00, &
0.1000000E-03, &
0.9050000E+00, 0.2564000E-01, 0.8599500E+00, 0.9132400E+00, &
0.1984100E+00, 0.7898900E+00, 0.4975100E+00, 0.7978700E+00, &
0.9132400E+00, 0.4512600E+00, 0.1000000E-03, 0.2083300E+00, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03/
data vcover0/ &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
0.1000000E-04/
data chil0/ &
0.1000000E+00, 0.2500000E+00, 0.1300000E+00, 0.1000000E-01, &
0.1000000E-01, 0.1000000E-01, -0.3000000E+00, 0.1000000E-01, &
0.1000000E-01, 0.2000000E+00, 0.1000000E-01, -0.2000000E-01, &
0.1000000E-01, &
0.1000000E+00, 0.2500000E+00, 0.1300000E+00, 0.1000000E-01, &
0.1000000E-01, -0.3000000E+00, -0.3000000E+00, -0.3000000E+00, &
0.1000000E-01, 0.2000000E+00, 0.1000000E-01, -0.2000000E-01, &
0.1000000E-01/
data rstpar0/ &
0.2335900E+04, 0.9802230E+04, 0.6335955E+04, 0.2869680E+04, &
0.2869680E+04, 0.5665121E+05, 0.2582010E+04, 0.9398942E+05, &
0.9398942E+05, 0.9802230E+04, 0.1000000E+04, 0.7459000E+04, &
0.1000000E+04, &
0.2335900E+04, 0.9802230E+04, 0.6335955E+04, 0.2869680E+04, &
0.2869680E+04, 0.2582010E+04, 0.2582010E+04, 0.2582010E+04, &
0.1000000E+01, 0.2582010E+04, 0.1000000E+04, 0.7459000E+04, &
0.1000000E+04, &
0.1450000E-01, 0.1055000E+02, 0.7120000E+01, 0.3690000E+01, &
0.3690000E+01, 0.1083000E+02, 0.1090000E+01, 0.1000000E-01, &
0.1000000E-01, 0.1055000E+02, 0.1000000E+04, 0.5700000E+01, &
0.1000000E+04, &
0.1450000E-01, 0.1055000E+02, 0.7120000E+01, 0.3690000E+01, &
0.3690000E+01, 0.1090000E+01, 0.1090000E+01, 0.1090000E+01, &
0.1000000E+01, 0.1090000E+01, 0.1000000E+04, 0.5700000E+01, &
0.1000000E+04, &
0.1534900E+03, 0.1800000E+03, 0.2065000E+03, 0.2330000E+03, &
0.2330000E+03, 0.1650000E+03, 0.1100000E+03, 0.8550000E+03, &
0.8550000E+03, 0.1800000E+03, 0.1000000E+04, 0.2520000E+02, &
0.1000000E+04, &
0.1534900E+03, 0.1800000E+03, 0.2065000E+03, 0.2330000E+03, &
0.2330000E+03, 0.1100000E+03, 0.1100000E+03, 0.1100000E+03, &
0.1000000E+01, 0.1100000E+03, 0.1000000E+04, 0.2520000E+02, &
0.1000000E+04/
data topt0/ &
0.3030000E+03, 0.3000000E+03, 0.2940000E+03, 0.2880000E+03, &
0.2880000E+03, 0.2970000E+03, 0.3130000E+03, 0.3150000E+03, &
0.3150000E+03, 0.3000000E+03, 0.3100000E+03, 0.3000000E+03, &
0.3100000E+03, &
0.3030000E+03, 0.3000000E+03, 0.2940000E+03, 0.2880000E+03, &
0.2880000E+03, 0.3120000E+03, 0.3130000E+03, 0.3130000E+03, &
0.3150000E+03, 0.2890000E+03, 0.3100000E+03, 0.3000000E+03, &
0.3100000E+03/
data tl0/ &
0.2730000E+03, 0.2730000E+03, 0.2700000E+03, 0.2680000E+03, &
0.2680000E+03, 0.2730000E+03, 0.2830000E+03, 0.2830000E+03, &
0.2830000E+03, 0.2730000E+03, 0.3000000E+03, 0.2730000E+03, &
0.3000000E+03, &
0.2730000E+03, 0.2730000E+03, 0.2700000E+03, 0.2680000E+03, &
0.2680000E+03, 0.2730000E+03, 0.2830000E+03, 0.2830000E+03, &
0.2830000E+03, 0.2730000E+03, 0.3000000E+03, 0.2730000E+03, &
0.3000000E+03/
data tu0/ &
0.3180000E+03, 0.3180000E+03, 0.3150000E+03, 0.3130000E+03, &
0.3130000E+03, 0.3230000E+03, 0.3280000E+03, 0.3230000E+03, &
0.3230000E+03, 0.3230000E+03, 0.3200000E+03, 0.3180000E+03, &
0.3200000E+03, &
0.3180000E+03, 0.3180000E+03, 0.3150000E+03, 0.3130000E+03, &
0.3130000E+03, 0.3230000E+03, 0.3280000E+03, 0.3280000E+03, &
0.3230000E+03, 0.3090000E+03, 0.3200000E+03, 0.3150000E+03, &
0.3200000E+03/
data defac0/ &
0.2730000E-01, 0.3570000E-01, 0.3400000E-01, 0.3100000E-01, &
0.3100000E-01, 0.3570000E-01, 0.2380000E-01, 0.2750000E-01, &
0.2750000E-01, 0.2750000E-01, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, &
0.2730000E-01, 0.3570000E-01, 0.3400000E-01, 0.3100000E-01, &
0.3100000E-01, 0.2380000E-01, 0.2380000E-01, 0.2380000E-01, &
0.2380000E-01, 0.2380000E-01, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00/
data ph10/ &
0.1200000E+01, 0.5350000E+01, 0.1920000E+01, 0.3700000E+01, &
0.7800000E+01, 0.1800000E+01, 0.1730000E+01, 0.1920000E+01, &
0.1390000E+01, 0.9600000E+00, 0.3000000E+01, 0.1800000E+01, &
0.5000000E+01, &
0.1200000E+01, 0.5350000E+01, 0.1920000E+01, 0.3700000E+01, &
0.7800000E+01, 0.1800000E+01, 0.1730000E+01, 0.1920000E+01, &
0.1390000E+01, 0.9600000E+00, 0.3000000E+01, 0.1800000E+01, &
0.5000000E+01/
data ph20/ &
0.6250000E+01, 0.5570000E+01, 0.5730000E+01, 0.5530000E+01, &
0.5660000E+01, 0.5670000E+01, 0.5800000E+01, 0.5610000E+01, &
0.6370000E+01, 0.5370000E+01, 0.6000000E+01, 0.5670000E+01, &
0.6000000E+01, &
0.6250000E+01, 0.5570000E+01, 0.5730000E+01, 0.5530000E+01, &
0.5660000E+01, 0.5670000E+01, 0.5800000E+01, 0.5610000E+01, &
0.6370000E+01, 0.5370000E+01, 0.6000000E+01, 0.5670000E+01, &
0.6000000E+01/
data zlt0/ &
0.5014160E+01, 0.3900000E+00, 0.3456000E+01, 0.6570000E+01, &
0.4040000E+00, 0.1766000E+01, 0.7040000E+00, 0.5780000E+00, &
0.1076000E+01, 0.3776000E+00, 0.1000000E-03, 0.4800000E-01, &
0.1000000E-03, &
0.5014160E+01, 0.3900000E+00, 0.3556000E+01, 0.6870000E+01, &
0.4040000E+00, 0.1546000E+01, 0.8040000E+00, 0.5780000E+00, &
0.9760000E+00, 0.3776000E+00, 0.1000000E-03, 0.4800000E-01, &
0.1000000E-03, &
0.5014160E+01, 0.6500000E+00, 0.3956000E+01, 0.7370000E+01, &
0.4040000E+00, 0.1416000E+01, 0.9040000E+00, 0.4480000E+00, &
0.7760000E+00, 0.3776000E+00, 0.1000000E-03, 0.6800000E-01, &
0.1000000E-03, &
0.5014160E+01, 0.1580000E+01, 0.4856000E+01, 0.7570000E+01, &
0.9040000E+00, 0.1216000E+01, 0.1004000E+01, 0.2880000E+00, &
0.2760000E+00, 0.3776000E+00, 0.1000000E-03, 0.1580000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.3380000E+01, 0.5456000E+01, 0.7770000E+01, &
0.1604000E+01, 0.1186000E+01, 0.1604000E+01, 0.2580000E+00, &
0.5760000E+00, 0.3776000E+00, 0.1000000E-03, 0.3380000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.5080000E+01, 0.6156000E+01, 0.8070000E+01, &
0.2304000E+01, 0.1416000E+01, 0.3304000E+01, 0.2580000E+00, &
0.1760000E+00, 0.5076000E+00, 0.1000000E-03, 0.5080000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.5380000E+01, 0.6456000E+01, 0.7870000E+01, &
0.4304000E+01, 0.2606000E+01, 0.4304000E+01, 0.2580000E+00, &
0.1760000E+00, 0.1737600E+01, 0.1000000E-03, 0.5380000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.4880000E+01, 0.6456000E+01, 0.7670000E+01, &
0.2904000E+01, 0.5206000E+01, 0.3804000E+01, 0.8080000E+00, &
0.2760000E+00, 0.1937600E+01, 0.1000000E-03, 0.4880000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.3780000E+01, 0.5756000E+01, 0.7570000E+01, &
0.2004000E+01, 0.4556000E+01, 0.1804000E+01, 0.1508000E+01, &
0.4760000E+00, 0.1477600E+01, 0.1000000E-03, 0.3780000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.1630000E+01, 0.4556000E+01, 0.7370000E+01, &
0.1304000E+01, 0.3816000E+01, 0.1104000E+01, 0.1148000E+01, &
0.5760000E+00, 0.3776000E+00, 0.1000000E-03, 0.1680000E+00, &
0.1000000E-03, &
0.5014160E+01, 0.6500000E+00, 0.3256000E+01, 0.6870000E+01, &
0.8040000E+00, 0.2806000E+01, 0.9040000E+00, 0.7480000E+00, &
0.6760000E+00, 0.3776000E+00, 0.1000000E-03, 0.6800000E-01, &
0.1000000E-03, &
0.5014160E+01, 0.3900000E+00, 0.3256000E+01, 0.6570000E+01, &
0.5040000E+00, 0.1866000E+01, 0.8040000E+00, 0.5780000E+00, &
0.8760000E+00, 0.3776000E+00, 0.1000000E-03, 0.4800000E-01, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
0.1000000E-03/
data z000/ &
0.2652970E+01, 0.5201000E+00, 0.5706300E+00, 0.1112210E+01, &
0.6414000E+00, 0.8427100E+00, 0.7771000E-01, 0.2446700E+00, &
0.6559000E-01, 0.7524000E-01, 0.1118000E-01, 0.1448500E+00, &
0.1011000E-01, &
0.2652970E+01, 0.5201000E+00, 0.5696600E+00, 0.1102780E+01, &
0.6414000E+00, 0.8087800E+00, 0.7779000E-01, 0.2446700E+00, &
0.6549000E-01, 0.7524000E-01, 0.1118000E-01, 0.1448500E+00, &
0.1011000E-01, &
0.2652970E+01, 0.6664900E+00, 0.5656600E+00, 0.1087660E+01, &
0.6414000E+00, 0.7875000E+00, 0.7785000E-01, 0.2272100E+00, &
0.6521000E-01, 0.7524000E-01, 0.1118000E-01, 0.1752100E+00, &
0.1011000E-01, &
0.2652970E+01, 0.9105300E+00, 0.5654400E+00, 0.1081830E+01, &
0.8633500E+00, 0.7284100E+00, 0.7788000E-01, 0.1998800E+00, &
0.6360000E-01, 0.7524000E-01, 0.1118000E-01, 0.2871900E+00, &
0.1011000E-01, &
0.2652970E+01, 0.1031200E+01, 0.5592300E+00, 0.1076120E+01, &
0.9728300E+00, 0.7284100E+00, 0.7779000E-01, 0.1998800E+00, &
0.6480000E-01, 0.7524000E-01, 0.1118000E-01, 0.4302000E+00, &
0.1011000E-01, &
0.2652970E+01, 0.1043680E+01, 0.5524400E+00, 0.1067790E+01, &
0.1005600E+01, 0.7875000E+00, 0.7712000E-01, 0.1998800E+00, &
0.6331000E-01, 0.7575000E-01, 0.1118000E-01, 0.5087600E+00, &
0.1011000E-01, &
0.2652970E+01, 0.1041940E+01, 0.5497000E+00, 0.1073310E+01, &
0.9967700E+00, 0.9266800E+00, 0.7594000E-01, 0.1998800E+00, &
0.6331000E-01, 0.7767000E-01, 0.1118000E-01, 0.5200300E+00, &
0.1011000E-01, &
0.2652970E+01, 0.1037530E+01, 0.5497000E+00, 0.1078960E+01, &
0.1011190E+01, 0.9715300E+00, 0.7658000E-01, 0.2674000E+00, &
0.6360000E-01, 0.7782000E-01, 0.1118000E-01, 0.5009500E+00, &
0.1011000E-01, &
0.2652970E+01, 0.1036510E+01, 0.5562600E+00, 0.1081830E+01, &
0.9965000E+00, 0.9658800E+00, 0.7776000E-01, 0.2923300E+00, &
0.6446000E-01, 0.7745000E-01, 0.1118000E-01, 0.4503800E+00, &
0.1011000E-01, &
0.2652970E+01, 0.9170700E+00, 0.5686600E+00, 0.1087660E+01, &
0.9386100E+00, 0.9555100E+00, 0.7790000E-01, 0.2803400E+00, &
0.6480000E-01, 0.7524000E-01, 0.1118000E-01, 0.2973700E+00, &
0.1011000E-01, &
0.2652970E+01, 0.6664900E+00, 0.5725100E+00, 0.1102780E+01, &
0.8346400E+00, 0.9204000E+00, 0.7785000E-01, 0.2580600E+00, &
0.6510000E-01, 0.7524000E-01, 0.1118000E-01, 0.1752100E+00, &
0.1011000E-01, &
0.2652970E+01, 0.5201000E+00, 0.5725100E+00, 0.1112210E+01, &
0.7049800E+00, 0.8427100E+00, 0.7779000E-01, 0.2446700E+00, &
0.6537000E-01, 0.7524000E-01, 0.1118000E-01, 0.1448500E+00, &
0.1011000E-01/
data d0/ &
0.2737261E+02, 0.1366377E+02, 0.1813464E+02, 0.1376361E+02, &
0.9193320E+01, 0.1390777E+02, 0.2185200E+00, 0.2812600E+01, &
0.1638000E+00, 0.1062900E+00, 0.6000000E-04, 0.6314240E+01, &
0.4000000E-04, &
0.2737261E+02, 0.1366377E+02, 0.1814677E+02, 0.1380041E+02, &
0.9193320E+01, 0.1376090E+02, 0.2265800E+00, 0.2812600E+01, &
0.1548100E+00, 0.1062900E+00, 0.6000000E-04, 0.6314240E+01, &
0.4000000E-04, &
0.2737261E+02, 0.1461883E+02, 0.1819051E+02, 0.1385740E+02, &
0.9193320E+01, 0.1367074E+02, 0.2332800E+00, 0.2662290E+01, &
0.1343400E+00, 0.1062900E+00, 0.6000000E-04, 0.7639520E+01, &
0.4000000E-04, &
0.2737261E+02, 0.1569677E+02, 0.1825890E+02, 0.1387880E+02, &
0.9903400E+01, 0.1344527E+02, 0.2389500E+00, 0.2390910E+01, &
0.6191000E-01, 0.1062900E+00, 0.6000000E-04, 0.1070958E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1632865E+02, 0.1829956E+02, 0.1389946E+02, &
0.1030010E+02, 0.1344527E+02, 0.2605400E+00, 0.2390910E+01, &
0.1096800E+00, 0.1062900E+00, 0.6000000E-04, 0.1278272E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1662263E+02, 0.1833903E+02, 0.1392915E+02, &
0.1053455E+02, 0.1367074E+02, 0.2988000E+00, 0.2390910E+01, &
0.5103000E-01, 0.1229900E+00, 0.6000000E-04, 0.1356813E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1666297E+02, 0.1835387E+02, 0.1390953E+02, &
0.1091967E+02, 0.1425275E+02, 0.3251800E+00, 0.2390910E+01, &
0.5103000E-01, 0.2152100E+00, 0.6000000E-04, 0.1366182E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1660123E+02, 0.1835387E+02, 0.1388922E+02, &
0.1068047E+02, 0.1459719E+02, 0.3130700E+00, 0.2974600E+01, &
0.6191000E-01, 0.2289700E+00, 0.6000000E-04, 0.1349985E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1641343E+02, 0.1831739E+02, 0.1387880E+02, &
0.1044517E+02, 0.1452246E+02, 0.2649800E+00, 0.3137710E+01, &
0.9547000E-01, 0.1996100E+00, 0.6000000E-04, 0.1301951E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1572679E+02, 0.1823553E+02, 0.1385740E+02, &
0.1016423E+02, 0.1443002E+02, 0.2438100E+00, 0.3062460E+01, &
0.1096800E+00, 0.1062900E+00, 0.6000000E-04, 0.1090759E+02, &
0.4000000E-04, &
0.2737261E+02, 0.1461883E+02, 0.1810866E+02, 0.1380041E+02, &
0.9814290E+01, 0.1422050E+02, 0.2332800E+00, 0.2907360E+01, &
0.1225000E+00, 0.1062900E+00, 0.6000000E-04, 0.7639520E+01, &
0.4000000E-04, &
0.2737261E+02, 0.1366377E+02, 0.1810866E+02, 0.1376361E+02, &
0.9417390E+01, 0.1390777E+02, 0.2265800E+00, 0.2812600E+01, &
0.1450200E+00, 0.1062900E+00, 0.6000000E-04, 0.6314240E+01, &
0.4000000E-04/
data z10/ &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03, &
0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
0.1000000E-03/
data z20/ &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00, &
0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
0.1000000E+00/
data rdc0/ &
0.2858700E+03, 0.2113200E+03, 0.2985200E+03, 0.5654100E+03, &
0.1852000E+03, 0.2301300E+03, 0.2443000E+02, 0.1036000E+03, &
0.2311000E+02, 0.2286000E+02, 0.2376000E+02, 0.1949000E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2113200E+03, 0.3013500E+03, 0.5870500E+03, &
0.1852000E+03, 0.2244200E+03, 0.2463000E+02, 0.1036000E+03, &
0.2294000E+02, 0.2286000E+02, 0.2376000E+02, 0.1949000E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2187800E+03, 0.3124600E+03, 0.6234600E+03, &
0.1852000E+03, 0.2215700E+03, 0.2480000E+02, 0.1023500E+03, &
0.2262000E+02, 0.2286000E+02, 0.2376000E+02, 0.1964400E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2434000E+03, 0.3312300E+03, 0.6381300E+03, &
0.2048700E+03, 0.2164100E+03, 0.2496000E+02, 0.1007200E+03, &
0.2189000E+02, 0.2286000E+02, 0.2376000E+02, 0.2014400E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2948700E+03, 0.3458300E+03, 0.6528600E+03, &
0.2330100E+03, 0.2164100E+03, 0.2572000E+02, 0.1007200E+03, &
0.2230000E+02, 0.2286000E+02, 0.2376000E+02, 0.2071300E+03, &
0.2850000E+02, &
0.2858700E+03, 0.3459000E+03, 0.3619400E+03, 0.6750500E+03, &
0.2620800E+03, 0.2215700E+03, 0.2774000E+02, 0.1007200E+03, &
0.2182000E+02, 0.2301000E+02, 0.2376000E+02, 0.2107900E+03, &
0.2850000E+02, &
0.2858700E+03, 0.3551800E+03, 0.3685400E+03, 0.6602400E+03, &
0.3443100E+03, 0.2500700E+03, 0.3006000E+02, 0.1007200E+03, &
0.2182000E+02, 0.2436000E+02, 0.2376000E+02, 0.2113100E+03, &
0.2850000E+02, &
0.2858700E+03, 0.3418400E+03, 0.3685400E+03, 0.6454900E+03, &
0.2870900E+03, 0.2885700E+03, 0.2886000E+02, 0.1053000E+03, &
0.2189000E+02, 0.2469000E+02, 0.2376000E+02, 0.2104200E+03, &
0.2850000E+02, &
0.2858700E+03, 0.3072200E+03, 0.3528500E+03, 0.6381300E+03, &
0.2495800E+03, 0.2780300E+03, 0.2590000E+02, 0.1079400E+03, &
0.2216000E+02, 0.2404000E+02, 0.2376000E+02, 0.2081500E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2448400E+03, 0.3236500E+03, 0.6231300E+03, &
0.2211200E+03, 0.2668400E+03, 0.2511000E+02, 0.1065900E+03, &
0.2230000E+02, 0.2286000E+02, 0.2376000E+02, 0.2018800E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2187800E+03, 0.2927900E+03, 0.5870500E+03, &
0.2008900E+03, 0.2475700E+03, 0.2480000E+02, 0.1044900E+03, &
0.2244000E+02, 0.2286000E+02, 0.2376000E+02, 0.1964400E+03, &
0.2850000E+02, &
0.2858700E+03, 0.2113200E+03, 0.2927900E+03, 0.5654100E+03, &
0.1892600E+03, 0.2301300E+03, 0.2464000E+02, 0.1036000E+03, &
0.2277000E+02, 0.2286000E+02, 0.2376000E+02, 0.1949000E+03, &
0.2850000E+02/
data rbc0/ &
0.5430000E+01, 0.6936000E+02, 0.8590000E+01, 0.8800000E+00, &
0.7850000E+01, 0.2661000E+02, 0.2207000E+02, 0.2188000E+02, &
0.1761000E+02, 0.4351000E+02, 0.3592951E+05, 0.5600000E+03, &
0.3546177E+05, &
0.5430000E+01, 0.6936000E+02, 0.8450000E+01, 0.8600000E+00, &
0.7850000E+01, 0.3044000E+02, 0.2053000E+02, 0.2188000E+02, &
0.1942000E+02, 0.4351000E+02, 0.3592951E+05, 0.5600000E+03, &
0.3546177E+05, &
0.5430000E+01, 0.4257000E+02, 0.7980000E+01, 0.8400000E+00, &
0.7850000E+01, 0.3295000E+02, 0.1934000E+02, 0.2673000E+02, &
0.2446000E+02, 0.4351000E+02, 0.3592951E+05, 0.4019700E+03, &
0.3546177E+05, &
0.5430000E+01, 0.1897000E+02, 0.7180000E+01, 0.8300000E+00, &
0.3810000E+01, 0.4003000E+02, 0.1838000E+02, 0.3712000E+02, &
0.6928000E+02, 0.4351000E+02, 0.3592951E+05, 0.1855200E+03, &
0.3546177E+05, &
0.5430000E+01, 0.1035000E+02, 0.6810000E+01, 0.8200000E+00, &
0.2400000E+01, 0.4003000E+02, 0.1516000E+02, 0.3712000E+02, &
0.3303000E+02, 0.4351000E+02, 0.3592951E+05, 0.9801000E+02, &
0.3546177E+05, &
0.5430000E+01, 0.7880000E+01, 0.6480000E+01, 0.8100000E+00, &
0.1860000E+01, 0.3295000E+02, 0.1068000E+02, 0.3712000E+02, &
0.8702000E+02, 0.3568000E+02, 0.3592951E+05, 0.7224000E+02, &
0.3546177E+05, &
0.5430000E+01, 0.7610000E+01, 0.6360000E+01, 0.8200000E+00, &
0.1290000E+01, 0.1870000E+02, 0.8300000E+01, 0.3712000E+02, &
0.8702000E+02, 0.1449000E+02, 0.3592951E+05, 0.6938000E+02, &
0.3546177E+05, &
0.5430000E+01, 0.8090000E+01, 0.6360000E+01, 0.8300000E+00, &
0.1600000E+01, 0.1318000E+02, 0.9330000E+01, 0.1722000E+02, &
0.6928000E+02, 0.1281000E+02, 0.3592951E+05, 0.7434000E+02, &
0.3546177E+05, &
0.5430000E+01, 0.9570000E+01, 0.6660000E+01, 0.8300000E+00, &
0.2040000E+01, 0.1420000E+02, 0.1457000E+02, 0.1317000E+02, &
0.4003000E+02, 0.1669000E+02, 0.3592951E+05, 0.8988000E+02, &
0.3546177E+05, &
0.5430000E+01, 0.1847000E+02, 0.7400000E+01, 0.8400000E+00, &
0.2820000E+01, 0.1559000E+02, 0.1760000E+02, 0.1497000E+02, &
0.3303000E+02, 0.4351000E+02, 0.3592951E+05, 0.1757600E+03, &
0.3546177E+05, &
0.5430000E+01, 0.4257000E+02, 0.8880000E+01, 0.8600000E+00, &
0.4210000E+01, 0.1933000E+02, 0.1934000E+02, 0.1906000E+02, &
0.2810000E+02, 0.4351000E+02, 0.3592951E+05, 0.4019700E+03, &
0.3546177E+05, &
0.5430000E+01, 0.6936000E+02, 0.8880000E+01, 0.8800000E+00, &
0.6400000E+01, 0.2661000E+02, 0.2053000E+02, 0.2188000E+02, &
0.2165000E+02, 0.4351000E+02, 0.3592951E+05, 0.5600000E+03, &
0.3546177E+05/
data rootd0/ &
0.1000000E+01, 0.1000000E+01, 0.1000000E+01, 0.5000000E+00, &
0.5000000E+00, 0.5000000E+00, 0.5000000E+00, 0.5000000E+00, &
0.5000000E+00, 0.2000000E+00, 0.1000000E+00, 0.1000000E+01, &
0.1000000E+01, &
0.1000000E+01, 0.1000000E+01, 0.1000000E+01, 0.5000000E+00, &
0.5000000E+00, 0.5000000E+00, 0.5000000E+00, 0.5000000E+00, &
0.5000000E+00, 0.2000000E+00, 0.1000000E+00, 0.1000000E+01, &
0.1000000E+01/
data soref0/ &
0.1100000E+00, 0.1100000E+00, 0.1100000E+00, 0.1100000E+00, &
0.1100000E+00, 0.1100000E+00, 0.1000000E+00, 0.1000000E+00, &
0.3000000E+00, 0.1000000E+00, 0.3000000E+00, 0.1000000E+00, &
0.1000000E+00, &
0.2250000E+00, 0.2250000E+00, 0.2250000E+00, 0.2250000E+00, &
0.2250000E+00, 0.2250000E+00, 0.2000000E+00, 0.2000000E+00, &
0.3500000E+00, 0.2000000E+00, 0.3500000E+00, 0.1500000E+00, &
0.1500000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
0.0000000E+00/
data bee0/ &
0.7120000E+01, 0.7120000E+01, 0.7120000E+01, 0.7120000E+01, &
0.7120000E+01, 0.7120000E+01, 0.7120000E+01, 0.4050000E+01, &
0.4050000E+01, 0.7120000E+01, 0.4050000E+01, 0.7797000E+01, &
0.4804000E+01/
data phsat0/ &
-0.8600000E-01, -0.8600000E-01, -0.8600000E-01, -0.8600000E-01, &
-0.8600000E-01, -0.8600000E-01, -0.8600000E-01, -0.3500000E-01, &
-0.3500000E-01, -0.8600000E-01, -0.3500000E-01, -0.1980000E+00, &
-0.1670000E+00/
data poros0/ &
0.4200000E+00, 0.4200000E+00, 0.4200000E+00, 0.4200000E+00, &
0.4200000E+00, 0.4200000E+00, 0.4200000E+00, 0.4352000E+00, &
0.4352000E+00, 0.4200000E+00, 0.4352000E+00, 0.4577000E+00, &
0.4352000E+00/
data satco0/ &
0.2000000E-04, 0.2000000E-04, 0.2000000E-04, 0.2000000E-04, &
0.2000000E-04, 0.2000000E-04, 0.2000000E-04, 0.1760000E-03, &
0.1760000E-03, 0.2000000E-04, 0.1760000E-03, 0.3500000E-05, &
0.7620000E-04/
data slope0/ &
0.1736000E+00, 0.1736000E+00, 0.1736000E+00, 0.1736000E+00, &
0.1736000E+00, 0.1736000E+00, 0.1736000E+00, 0.8720000E-01, &
0.8720000E-01, 0.1736000E+00, 0.8720000E-01, 0.3420000E+00, &
0.8720000E-01/
data depth0/ &
0.2000000E-01, 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, &
0.2000000E-01, 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, &
0.2000000E-01, 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, &
0.1000000E+01, &
0.1480000E+01, 0.1480000E+01, 0.1480000E+01, 0.1480000E+01, &
0.1480000E+01, 0.1480000E+01, 0.4700000E+00, 0.4700000E+00, &
0.4700000E+00, 0.1700000E+00, 0.1700000E+00, 0.1480000E+01, &
0.1000000E+01, &
0.2000000E+01, 0.2000000E+01, 0.2000000E+01, 0.2000000E+01, &
0.2000000E+01, 0.2000000E+01, 0.1000000E+01, 0.1000000E+01, &
0.1000000E+01, 0.1000000E+01, 0.3000000E+00, 0.2000000E+01, &
0.1000000E+01/
!------------------------------------------------------------------------
CONTAINS
!
!-----------------------------------------------------------------------
!**********************************************
SUBROUTINE SSIB( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE, & 1,20
PPL, PPC, RLWDOWN, ZWIND2, &
WWW1, WWW2, WWW3, &
TC, TGS, TD, &
SNOA, ROFF, &
UMM, VMM, QM, TM, &
PM, PSUR, ivgtyp, &
SWDOWN1, SNOB, &
SALB11, SALB12, SALB21, SALB22, &
RADFRAC11, RADFRAC12, RADFRAC21, RADFRAC22, &
XHSFLX, ELATEN, GHTFLX, XHLFLX, TGEFF, &
USTAR, RIB, FM, FH, CM, &
XLHF, XSHF, XGHF, XEGS, XECI, XECT, & ! output
XEGI, XEGT, XSDN, XSUP, XLDN, XLUP, & ! output
XWAT, XHCX, XHGX, XZLT, XVCF, XXZ0, & ! output
XVEG, XDD, & ! output
ISNOW,SWE,SNOWDEN,SNOWDEPTH,TKAIR, & ! snow
DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, & ! snow
DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, & ! snow
DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, & ! snow
DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, & ! snow
DAY, CLOUD, Q2M, TA, BEDO, &
sw_physics, MMINLU &
)
!**********************************************
!-----------------------------------------------------------------------
! THERE ARE A MAIN SSIB PROGRAM AND 12 SUBROUTINE FILES, WHICH ARE:
! VEGOUT
! CROPS
! RADAB
! ROOT1
! STOMA1
! INTERC
! TEMRS1
! UPDAT1
! RASIT5
! STRES1
! NEWTON
! YONGKANG XUE
!-----------------------------------------------------------------------
! INPUT
! DDTT: TIME INTERVAL
! SUNANGLE: SOLAR ZENITH ANGLE
! SWDOWN: SHORT WAVE DOWN(W/M*M);
! RADFRAC: SHORT WAVE COMPONENTS (visible and near IR; direct and diffuse)
! RLWDOWN: LONG WAVE DOWN(W/M*M);
! PPL, PPC: LARGE SCALE AND CONVECTIVE PRECIPITATIONS AT THE TIME STEP (mm)
! TM: TEMPERETURE AT LOWEST MODEL LAYER (K)
! UMM,VMM: ZONAL AND MERIDIONAL WINDS AT LOWEST MODEL LAYER (m/S)
! QM: WATER VAPOR AT LOWEST MODEL LAYER;
! PSURF: SURFACE PRESSURE (mb)
! ZWIND: HEIGHT (m) OF LOWEST MODEL LAYER
! ITYPE: VEGETATION TYPE
! ZLAT: LATITUDE, SOUTH POLE IS -90 DEGREE AND NORTH POLE IS 90 DEGREE
! MONTH: MONTH
! DAY: CALENDER DATE
! IYEAR: YEAR
! OUTPUT
! ETMASS: EVAPORATION (mm/step)
! ELATEN: LATENT HEAT FLUX (w/m*m)
! EVAPSOIL,EVAPWC,EVAPDC,EVAPSN: LATENT HEAT FROM (SOIL, INTERCEPTION,
! TRANSPIRATION, AND SNOW SURFACE)
! HFLUX: SENSIBLE HEAT FLUX(w/m*m)
! GHTFLX: GROUND HEAT FLUX(w/m*m) = CHF+SHF
! USTAR: FRICTION VELOCITY (m/s)
! DRAG: MOMENTUM FLUX (kg/m/s**2)
! DRAGU: U COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
! DRAGV: V COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
! TGEFF: RADIATIVE TEMPERATURE (K)
! BEDO: TOTAL ALBEDO
! SALB: ALBEDO FOR 4 COMPONENTS
! RADT: NET RADIATION AT CANOPY AND GROUND LEVELS
! TGS: SOIL SURFACE TEMPERATURE (K)
! TC: CANOPY TEMPERATURE (K)
! TD: DEEP SOIL TEMPERATURE (K)
! TA: TEMPERATURE AT CANOPY AIR SPACE (K)
! CAPAC: INTERCEPTION AT CANOPY (1) and SNOW DEPTH (2)
! WWW: SOIL MOISTURE
! SOILM: TOTAL SOIL WATER CONTENT
! ROFF: RUN OFF
!
!----------------------------------------------------------------------
INTEGER, DIMENSION (12) :: IDAYS
REAL, DIMENSION (2) :: CAPAC, SATCAP, GREEN, VCOVER, ZLT, CHIL, TOPT, TL, &
TU, DEFAC, PH1, PH2, RST, ROOTD, RADT, PAR, PD
REAL, DIMENSION (3) :: WWW, SOREF, ZDEPTH, ROOTP, PHSOIL, YMATT, YMATQ
REAL, DIMENSION (2,2) :: RADFRAC, SALB
REAL, DIMENSION (2,3) :: RSTPAR
REAL, DIMENSION (2,4) :: RSTFAC
REAL, DIMENSION (3,2) :: RADN
REAL, DIMENSION (2,3,2) :: TRAN, REF, ALBEDO, EXTK
REAL, DIMENSION (2,2,2) :: RADFAC
INTEGER, DIMENSION (24) :: IVUSGS
REAL, DIMENSION (13) :: TD_DEPTH
INTEGER :: sw_physics !choice of SW radiation scheme
CHARACTER(LEN=*), INTENT(IN ) :: MMINLU !type of landuse/vegetation map
!snow
REAL, DIMENSION (N2) :: SS,SSO,POROSITY,H,HO,BI,BIO,DZ,DZO,BW,BWO,BL
REAL, DIMENSION (N2) :: BLO,TSSN,TSSNO,W,WO,WF,FI,FIO, FL,FLO,DMLT
REAL, DIMENSION (N2) :: DMLTO,BT,BTO,S,SO,CT,CTO,DLIQVOL,DICEVOL
REAL, DIMENSION (N2) :: QK,PDZDTC,DMASS,DSOL,DHP,THK
!snow
! Julian day
DATA IDAYS/31,59,90,120,151,181,212,243,273,304,334,366/
!
! Deep soil temperature depth by vegetation type --------------------
DATA TD_DEPTH/1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.0, 1.0, 1.0 &
& , 0.5, 0.5, 1.5, 1.5/
!
! Check vegetation/landuse map choice
! If using USGS, translate to SSIB types (IVUSGS)
DATA IVUSGS / 7, 12, 12, 12, 12, 12, 7, 9, &
8, 6, 2, 5, 1, 4, 3, 0, &
10, 3, 11, 10, 10, 10, 10, 13/
IF(MMINLU.EQ.'SSIB') THEN
ITYPE=IVGTYP
ELSEIF(MMINLU.EQ.'USGS') THEN
ITYPE=IVUSGS(IVGTYP)
ELSE
CALL wrf_error_fatal
( 'SSIB LSM only works with SSIB or USGS vegetation (landuse) map' )
ENDIF
! Check for error in vegetation map
if(itype.le.0.or.itype.gt.13) then
!Make sure the correct vegetation map is being used!
print *,"veg type: ",itype
CALL wrf_error_fatal ( 'module_sf_ssib: ERROR in vegetation/landuse map' )
endif
!
INTG=1
XADJ=0.
CTLPA=1.
NROOT=1
WFSOIL=0.
!------------------------------------------------
ZWIND=ZWIND2*0.5 ! TM & UM are on the middle lowest model layer
!------------------------------------------------
! set DAY in year and current month MON_COR
!------------------------------------------------
IMONTH=1
IDAY=INT(DAY)
DO I=1,12
IF(IDAY.LE.IDAYS(I)) THEN
IMONTH=I
EXIT
ENDIF
ENDDO
!crr correction for southern hemisphere (reverse months) Ratko, Oct 28, 2005
IF(ZLAT.LT.0.0) THEN
MON_COR=IMONTH+6
IF(MON_COR.GT.12) MON_COR=MON_COR-12
ELSE
MON_COR=IMONTH
ENDIF
!------------------------------------------------
IF (ITIME.EQ.1) TA=TC
!
PSURF=PSUR*0.01
DTT =DDTT*FLOAT(INTG)
!------------------------------------------------
! ** Read in vegetation parameters
CALL VEGOUT(TRAN,REF,GREEN,VCOVER,CHIL, &
RSTPAR,TOPT,TL,TU,DEFAC,PH1,PH2, &
ZLT,Z0,XDD,Z2,Z1,RDC,RBC,ROOTD,SOREF, &
BEE, PHSAT, POROS, SATCO,SLOPE, &
ZDEPTH,MON_COR,ITYPE)
!
IF (ITYPE.EQ.12) CALL CROPS(ZLAT,DAY,CHIL, &
ZLT,GREEN,VCOVER,RSTPAR,TOPT,TL,TU,DEFAC,PH2,PH1)
!
!crr ------------ STC initialization ------------------------------------
IF (ITIME.EQ.1) THEN
STLEV1=0.05 ! half of 10cm layer
STLEV2=1.05 ! half of second + first layer
DEPTH = TD_DEPTH(ITYPE)
IF (DEPTH.GT.STLEV1.AND.DEPTH.LE.STLEV2)THEN ! interp.
TD = ( (STLEV2-DEPTH)*TGS + (DEPTH-STLEV1)*TD ) &
& /(STLEV2-STLEV1)
ELSE IF(DEPTH.GT.STLEV2)THEN ! extrap.
TD = ( (DEPTH-STLEV1)*TD - (DEPTH-STLEV2)*TGS) &
& /(STLEV2-STLEV1)
ENDIF
ENDIF
!------------------------------------------------------------------------
WWW(1) = WWW1 / POROS
WWW(2) = WWW2 / POROS
WWW(3) = WWW3 / POROS
!------------------------------------------------
!cfds Convert WEASD (kg/m2) to meter
SNOA = SNOA/1000.
SNOB = SNOB/1000.
!------------------------------------------------
!
CALL CONVDIM(0, &
DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, &
DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, &
DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, &
DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, &
DZO, WO, TSSN, TSSNO, BWO, BTO, CTO, FIO, FLO, BIO, BLO, HO )
!
IF (ITIME.EQ.1) THEN
ISNOW = 1
SNOWDEN = 3.75
SWE = SNOA
SNOWDEPTH = SWE * SNOWDEN
TGG=AMIN1(273.15,TGS)
!fds temp IF (SNOWDEPTH.gt.SNODEP_CR) THEN
!fds temp ISNOW = 0
!fds temp CALL LAYERN (TGG,SWE,SNOWDEPTH, DZO,BWO,WO,BTO,CTO &
!fds temp ,FLO,FIO,HO,BLO,BIO,DLIQVOL,DICEVOL,TSSNO,DMLTO)
!fds temp ENDIF
ENDIF
!
CAPAC(1)=SNOB
CAPAC(2)=SNOA
IF (ITIME.EQ.1) THEN
IF (SNOA.GT.0.) THEN
!cxx IF (SNOA.GT.5.) THEN
CAPAC(1) = ZLT(1) * 0.0001
TC = AMIN1(TC ,TF-0.01)
TGS = AMIN1(TGS,TF-0.01)
ENDIF
ENDIF
!
UM=SQRT(UMM**2+VMM**2)
RHOAIR=100./GASR*(PSURF+0.01*PM)/(TM+TA)
AKAPPA = GASR/CPAIR
BPS =1.0 / EXP ( AKAPPA * ALOG (0.01*PM/PSURF) )
! BPS0 =1.0 / EXP ( AKAPPA * ALOG (PSURF/1000.) )
! BPS1 =1.0 / EXP ( AKAPPA * ALOG (0.01*PM/1000.) )
!Cl 2001,2,2 added the following line
IF (ISNOW.EQ.0) THEN
TSOIL=TGS
TGS=TSSNO(N)
CAPAC(2)=SWE
IPTYPE=2
IF(TM.ge.TF) IPTYPE=1
END IF
!C
!
! CONVERT TO VAPOR PRES. TO MB
EM=(PSURF*QM)/0.6220
IF (ITIME.EQ.1) EA=EM
!
SUNANG=AMAX1(SUNANGLE,0.01746)
! By Zhenxin 2011-06-20
! IF (sw_physics.eq.3) THEN
IF (sw_physics.eq.3 .or. sw_physics.eq.4) THEN
! End By Zhenxin 2011-06-20
!**********************************************
!fds - RADFRAC from radiation scheme 3 (06/2010)
!fds - Otherwise use cloud cover to calculate radfrac
radfrac11 = amax1(radfrac11,0.025)
radfrac12 = amax1(radfrac12,0.025)
radfrac21 = amax1(radfrac21,0.025)
radfrac22 = amax1(radfrac22,0.025)
swdown = radfrac11 + radfrac12 + radfrac21 + radfrac22
RADFRAC(1,1) = radfrac11/swdown
RADFRAC(1,2) = radfrac12/swdown
RADFRAC(2,1) = radfrac21/swdown
RADFRAC(2,2) = radfrac22/swdown
ELSE
!**********************************************
! ** CALCULATE THE CLOUD COVER USING AN EMPIRICAL EQUATION
! ONLY USE THIS PART WHEN IT IS NEEDED
!
swdown = amax1(swdown1,0.1)
CLOUD = AMAX1(CLOUD,0.0)
CLOUD = AMIN1(CLOUD,1.0)
CLOUD = AMAX1(0.58,CLOUD)
!
DIFRAT = 0.0604 / ( SUNANG-0.0223 ) + 0.0683
IF ( DIFRAT .LT. 0.0 ) DIFRAT = 0.0
IF ( DIFRAT .GT. 1.0 ) DIFRAT = 1.0
!
DIFRAT = DIFRAT + ( 1.0 - DIFRAT ) * CLOUD
VNRAT = ( 580.0 - CLOUD*464.0 ) / ( ( 580.0-CLOUD*499.0) &
& + ( 580.0 - CLOUD*464.0 ) )
!
RADFRAC(1,1) = (1.0-DIFRAT)*VNRAT
RADFRAC(1,2) = DIFRAT*VNRAT
RADFRAC(2,1) = (1.0-DIFRAT)*(1.0-VNRAT)
RADFRAC(2,2) = DIFRAT*(1.0-VNRAT)
!**********************************************
ENDIF
!
RADN(1,1) = RADFRAC(1,1) * SWDOWN
RADN(1,2) = RADFRAC(1,2) * SWDOWN
RADN(2,1) = RADFRAC(2,1) * SWDOWN
RADN(2,2) = RADFRAC(2,2) * SWDOWN
RADN(3,1) = 0.
RADN(3,2) = RLWDOWN
!
! END OF EMPIRICAL EQUATIONS
! *********************************************************
!
CALL RADAB (TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF,TC, &
TGS,SATCAP,EXTK,RADFAC,THERMK,RADT,PAR,PD,ALBEDO,SALB, &
TGEFF,SUNANG,XADJ,CAPAC,RADN,ZLWUP,RADFRAC, &
ISNOW,SNOWDEN,SNOWDEPTH,SWDOWN,BEDO,SNOCV,0, &
fsdown,fldown,fsup,flup)
!
CALL ROOT1(PHSAT,BEE,WWW,PHSOIL)
!
CALL STOMA1(GREEN,VCOVER,CHIL,ZLT,PAR,PD,EXTK,SUNANG,RST, &
RSTPAR, CTLPA)
!
RSTUN = RST(1)
CALL INTERCS (DTT,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL, &
ROFF,ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET, &
EXTK,ISNOW,P0,CSOIL,dzsoil,CHISL,SMELT)
CALL SET0(TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO, &
SSO,CTO,BTO,DMLTO,WF,DHP)
!
!***************************************************************************************
IF (ISNOW.EQ.0) THEN ! MULTI-LAYER SNOW
!***************************************************************************************
PRCP=P0
TKAIR=TM
CALL GETMET(IPTYPE,PRCP,TKAIR, &
PRCPS,PRCPW,FIFALL,FLFALL,BIFALL,BLFALL)
!c ** aerodynamic resistance and flux calculations
SOLAR=0.
DO 1100 IVEG = 2, 2
DO 1100 IWAVE = 1, 2
DO 1100 IRAD = 1, 2
SOLAR=SOLAR+RADFAC(IVEG,IWAVE,IRAD)*RADN(IWAVE,IRAD)
1100 CONTINUE
CALL SNOW_1ST (DTT,TM,SOLAR,PRCPW,PRCPS,BIO,BLO,DICEVOL, &
DLIQVOL,TSSNO,PDZDTC,POROSITY,SO,SSO,WF,DHP,DZO,WO, &
BWO,BTO,CTO,DMASS,DSOL,SNROFF,HROFF,SNOWDEPTH,SOLSOIL, &
FLO,FIO,DMLTO,HO,BIFALL,BLFALL,FLFALL)
!
CALL TEMRS2(DTT,TC,TGS,TD,TA,TM,QM,EM,PSUR,WWW,CAPAC,SATCAP, &
DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,XDD,Z0,RDC,RBC,VCOVER, &
Z2,ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP, &
PH1,PH2,ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF, &
ALBEDO,ZLWUP,THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, &
ISNOW,CHISL,TSOIL,SOLSOIL,CSOIL,WFSOIL,POROSITY, &
DZ,DZO,W,WO,WF,TSSN,TSSNO,BW,BWO,CT,CTO,FI,FIO,FL,FLO, &
BL,BLO,BI,BIO,BT,BTO,DMLT,DMLTO,H,HO,S,SO,SS,SSO,DSOL,DHP, &
DICEVOL,DLIQVOL,THK,QK,SWE,SNOWDEN,SNOWDEPTH,TKAIR,SNROFF, &
DZSOIL,BPS,rib,CU,XCT,flup,ii,jj)
!
CALL OLD(TSSN,BW,BL,BI,H,FL,FI,W,DZ,SS,CT,BT,DMLT, &
TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO,SSO,CTO,BTO,DMLTO)
!
!***************************************************************************************
ELSE ! SINGLE-LAYER SNOW
!***************************************************************************************
!
CALL TEMRS1(DTT,TC,TGS,TD,TA,TM,QM,EM,PSUR,WWW,CAPAC,SATCAP, &
DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,XDD,Z0,RDC,RBC,VCOVER,Z2, &
ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP, &
THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN, &
BPS,rib,CU,XCT,flup,ii,jj)
!
SWE=CAPAC(2)
SNOWDEPTH=SWE*SNOWDEN
SNROFF=0.
!
END IF
!***************************************************************************************
!
CALL UPDAT1(DTT,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, &
EGS,EG,HC,HG,HFLUX,ETMASS,ROFF, &
1,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF, ISNOW,WFSOIL,SWE,SNROFF,SMELT)
!
IF (ISNOW.EQ.0) THEN
CAPAC(2)=SWE
IF (SNOWDEPTH.LT.SNODEP_CR) THEN
ISNOW=1
CALL LAYER1 (CSOIL,TGS,DZSOIL,H,W,SNOWDEPTH,SWE,STEMP,N2)
ELSE
ISNOW=0
CALL MODNODE(SNOWDEPTH,DZO,WO,HO,TSSNO,BWO,BIO, &
BLO,BTO,FIO,FLO,CTO,DLIQVOL,DICEVOL)
END IF
ELSE IF(ISNOW.GT.0) THEN
IF (CAPAC(2)*SNOWDEN.GT.SNODEP_CR) THEN
SWE=CAPAC(2)
SNOWDEPTH=CAPAC(2)*SNOWDEN
ISNOW=0
CALL LAYERN (TGS,SWE,SNOWDEPTH, DZO,BWO,WO,BTO,CTO,FLO,FIO, &
HO,BLO,BIO,DLIQVOL,DICEVOL,TSSNO,DMLTO)
ELSE
ISNOW=1
END IF
END IF
ROFF=ROFF+SNROFF
!
!------------------------------------------------------------------------
SOILM=(WWW(1)*ZDEPTH(1)+WWW(2)*ZDEPTH(2)+WWW(3)*ZDEPTH(3))*POROS
!------------------------------------------------------------------------
UMOM=RHOAIR*CU*USTAR*UMM
VMOM=RHOAIR*CU*USTAR*VMM
HLFLX= ETMASS/RHOAIR/DTT
HSFLX= HFLUX/CPAIR/RHOAIR/DTT
ULWSF1=TGEFF*TGEFF*TGEFF*TGEFF*STEFAN
Q2M=0.622*EA/(PSURF-EA)
EVAP=ETMASS*HLAT
CM=(USTAR*USTAR)/(UM*UM)
CH=1/(UM*RA)
!
FM=VKC/CU
FH=VKC/XCT
!
!
EVAPSOIL=EGS /DTT
EVAPWC=ECI /DTT
EVAPDC=ECT /DTT
EVAPSN=EGI /DTT
EVAPGX=EGT /DTT
ELATEN=EVAPSOIL+EVAPWC+EVAPDC+EVAPSN+EVAPGX
XHLFLX=ELATEN/HLAT
GHTFLX=CHF+SHF
!=====================================================================
xhsflx=(hc+hg)/dtt
!=====================================================================
!
CALL CONVDIM(1, &
DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, &
DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, &
DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, &
DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, &
DZO, WO, TSSN, TSSNO, BWO, BTO, CTO, FIO, FLO, BIO, BLO, HO )
!
WWW1=WWW(1)*POROS
WWW2=WWW(2)*POROS
WWW3=WWW(3)*POROS
SNOA = CAPAC(2)
SNOB = CAPAC(1)
!------------------------------------------------
!cfds Convert WEASD back to kg/m2
SNOA = SNOA*1000.
SNOB = SNOB*1000.
!------------------------------------------------
SALB11=SALB(1,1)
SALB12=SALB(1,2)
SALB21=SALB(2,1)
SALB22=SALB(2,2)
!
! output
!
xlhf = elaten
xshf = xhsflx
xghf = ghtflx
xegs = evapsoil
xeci = evapwc
xect = evapdc
xegi = evapsn
xegt = evapgx
xsdn = fsdown
xsup = fsup
xldn = fldown
xlup = flup
xwat = soilm
xhcx = hc/dtt
xhgx = hg/dtt
xzlt = zlt(1)
xvcf = vcover(1)
xxz0 = z0
xveg = float(itype)
!------------------------------------------------------
END SUBROUTINE SSIB
!------------------------------------------------------
!
!-----------------------------------------------------------------------
!**********************************************
SUBROUTINE SSIB_SEAICE & 1,7
( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE, &
PPL, PPC, RLWDOWN, ZWIND2, &
WWW1, WWW2, WWW3, &
TC, TGS, TD, &
SNOA, ROFF, YICE, &
UMM, VMM, QM, TM, &
PM, PSUR, &
SWDOWN1, SNOB, &
SALB11, SALB12, SALB21, SALB22, &
RADFRAC11, RADFRAC12, RADFRAC21, RADFRAC22, &
XHSFLX, ELATEN, GHTFLX, XHLFLX, TGEFF, &
USTAR, RIB, FM, FH, CM, &
XLHF, XSHF, XGHF, & ! output
XSDN, XSUP, XLDN, XLUP, & ! output
XWAT, XXZ0, & ! output
XVEG, & ! output
DAY, CLOUD, Q2M, TA, BEDO, &
sw_physics,ice_threshold &
)
!**********************************************
!-----------------------------------------------------------------------
! THERE ARE A MAIN SSIB PROGRAM AND 12 SUBROUTINE FILES, WHICH ARE:
! VEGOUT
! CROPS
! RADAB
! ROOT1
! STOMA1
! INTERC
! TEMRS1
! UPDAT1
! RASIT5
! STRES1
! NEWTON
! YONGKANG XUE
!-----------------------------------------------------------------------
! INPUT
! DDTT: TIME INTERVAL
! SUNANGLE: SOLAR ZENITH ANGLE
! SWDOWN: SHORT WAVE DOWN(W/M*M);
! RADFRAC: SHORT WAVE COMPONENTS (visible and near IR; direct and diffuse)
! RLWDOWN: LONG WAVE DOWN(W/M*M);
! PPL, PPC: LARGE SCALE AND CONVECTIVE PRECIPITATIONS AT THE TIME STEP (mm)
! TM: TEMPERETURE AT LOWEST MODEL LAYER (K)
! UMM,VMM: ZONAL AND MERIDIONAL WINDS AT LOWEST MODEL LAYER (m/S)
! QM: WATER VAPOR AT LOWEST MODEL LAYER;
! PSURF: SURFACE PRESSURE (mb)
! ZWIND: HEIGHT (m) OF LOWEST MODEL LAYER
! ITYPE: VEGETATION TYPE
! ZLAT: LATITUDE, SOUTH POLE IS -90 DEGREE AND NORTH POLE IS 90 DEGREE
! MONTH: MONTH
! DAY: CALENDER DATE
! IYEAR: YEAR
! OUTPUT
! ETMASS: EVAPORATION (mm/step)
! ELATEN: LATENT HEAT FLUX (w/m*m)
! EVAPSOIL,EVAPWC,EVAPDC,EVAPSN: LATENT HEAT FROM (SOIL, INTERCEPTION,
! TRANSPIRATION, AND SNOW SURFACE)
! HFLUX: SENSIBLE HEAT FLUX(w/m*m)
! GHTFLX: GROUND HEAT FLUX(w/m*m) = CHF+SHF
! USTAR: FRICTION VELOCITY (m/s)
! DRAG: MOMENTUM FLUX (kg/m/s**2)
! DRAGU: U COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
! DRAGV: V COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
! TGEFF: RADIATIVE TEMPERATURE (K)
! BEDO: TOTAL ALBEDO
! SALB: ALBEDO FOR 4 COMPONENTS
! RADT: NET RADIATION AT CANOPY AND GROUND LEVELS
! TGS: SOIL SURFACE TEMPERATURE (K)
! TC: CANOPY TEMPERATURE (K)
! TD: DEEP SOIL TEMPERATURE (K)
! TA: TEMPERATURE AT CANOPY AIR SPACE (K)
! CAPAC: INTERCEPTION AT CANOPY (1) and SNOW DEPTH (2)
! WWW: SOIL MOISTURE
! SOILM: TOTAL SOIL WATER CONTENT
! ROFF: RUN OFF
!
!----------------------------------------------------------------------
INTEGER, DIMENSION (12) :: IDAYS
REAL, DIMENSION (2) :: CAPAC, SATCAP, GREEN, VCOVER, ZLT, CHIL, TOPT, TL, &
TU, DEFAC, PH1, PH2, RST, ROOTD, RADT, PAR, PD
REAL, DIMENSION (3) :: WWW, SOREF, ZDEPTH, ROOTP, PHSOIL, YMATT, YMATQ
REAL, DIMENSION (2,2) :: RADFRAC, SALB
REAL, DIMENSION (2,3) :: RSTPAR
REAL, DIMENSION (2,4) :: RSTFAC
REAL, DIMENSION (3,2) :: RADN
REAL, DIMENSION (2,3,2) :: TRAN, REF, ALBEDO, EXTK
REAL, DIMENSION (13) :: TD_DEPTH
REAL :: ice_threshold
INTEGER :: sw_physics !choice of SW radiation scheme
!
DATA IDAYS/31,59,90,120,151,181,212,243,273,304,334,366/
!
DATA TD_DEPTH/1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.0, 1.0, 1.0 &
& , 0.5, 0.5, 1.5, 1.5/
!**********************************************
! The final albedo=original albedo+XADJ
XADJ=0.
! CTLPA controls stomatal resistance;
! Final stomatal resistance=ctlpa * stomatal resistance
CTLPA=1.
! NROOT controls root distribution. nroot=1: root uniformly distributes
! in the soil layer;
! If NROOT not =1, root distribution is controled by rootp.
NROOT=1
! INTG=? TIME INTEGRATION OF SURFACE PHYSICAL VARIABLE IS DONE
! INTG=2: LEAP-FROG IMPLICIT SCHEME. INTG=1 BACKWORD IMPLICIT SCHEME
INTG=1 !!!!!! in MM5 version hardwired for INTG=1 !!!!!!!!!!!!!
!------------------------------------------------
ITYPE=13
ZWIND=ZWIND2*0.5
!------------------------------------------------
! set DAY in year and current month MON_COR
!------------------------------------------------
IMONTH=1
IDAY=INT(DAY)
DO I=1,12
IF(IDAY.LE.IDAYS(I)) THEN
IMONTH=I
EXIT
ENDIF
ENDDO
!crr correction for southern hemisphere (reverse months) Ratko, Oct 28, 2005
IF(ZLAT.LT.0.0) THEN
MON_COR=IMONTH+6
IF(MON_COR.GT.12) MON_COR=MON_COR-12
ELSE
MON_COR=IMONTH
ENDIF
!------------------------------------------------
IF (ITIME.EQ.1) TA=TC
!
PSURF=PSUR*0.01
DTT =DDTT*FLOAT(INTG)
!------------------------------------------------
! ** Read in vegetation parameters
CALL VEGOUT(TRAN,REF,GREEN,VCOVER,CHIL, &
RSTPAR,TOPT,TL,TU,DEFAC,PH1,PH2, &
ZLT,Z0,XDD,Z2,Z1,RDC,RBC,ROOTD,SOREF, &
BEE, PHSAT, POROS, SATCO,SLOPE, &
ZDEPTH,MON_COR,ITYPE)
!
!crr ------------ STC initialization ------------------------------------
IF (ITIME.EQ.1) THEN
STLEV1=0.05 ! half of 10cm layer
STLEV2=1.05 ! half of second + first layer
DEPTH = TD_DEPTH(ITYPE)
IF (DEPTH.GT.STLEV1.AND.DEPTH.LE.STLEV2)THEN ! interp.
TD = ( (STLEV2-DEPTH)*TGS + (DEPTH-STLEV1)*TD ) &
& /(STLEV2-STLEV1)
ELSE IF(DEPTH.GT.STLEV2)THEN ! extrap.
TD = ( (DEPTH-STLEV1)*TD - (DEPTH-STLEV2)*TGS) &
& /(STLEV2-STLEV1)
ENDIF
ENDIF
!------------------------------------------------------------------------
WWW(1) = 1.
WWW(2) = 1.
WWW(3) = 1.
!------------------------------------------------
!cfds Convert WEASD (kg/m2) to meter
SNOA = SNOA/1000.
SNOB = SNOB/1000.
!------------------------------------------------
CAPAC(1)=SNOB
CAPAC(2)=SNOA
SNOWDEN = 3.75 ! mchen add for initialization
ISNOW = 1
IF (ITIME.EQ.1) THEN
TA=TGS
CAPAC(1)=0.
CAPAC(2)=0.
IF (SNOA.GT.0.) CAPAC(1) = ZLT(1) * 0.0001
TC = AMIN1(TC ,273.15)
TGS= AMIN1(TGS,273.15)
TD = AMIN1(TD ,272.50)
ELSE
! IF( YICE .LT. 0.5 ) THEN ! previous sea, now sea-ice
IF( YICE .LT. ice_threshold ) THEN ! previously water, now sea-ice
CAPAC(1)= 0.
CAPAC(2)= 0.
XADIA = EXP(GASR/CPAIR*LOG(PSUR/PM))
XX = MIN(TM*XADIA,273.15)
TC = MIN(TM*XADIA,273.15)
TGS= MIN(TM*XADIA,273.15)
IF(TD.EQ.0.) TD=272.5
TD = MIN(TD,272.5)
ENDIF
ENDIF
!
UM=SQRT(UMM**2+VMM**2)
RHOAIR=100./GASR*(PSURF+0.01*PM)/(TM+TA)
AKAPPA = GASR/CPAIR
BPS =1.0 / EXP ( AKAPPA * ALOG (0.01*PM/PSURF) )
!
! CONVERT TO VAPOR PRES. TO MB
EM=(PSURF*QM)/0.6220
IF (ITIME.EQ.1) EA=EM
!
SUNANG=AMAX1(SUNANGLE,0.01746)
!
! By Zhenxin 2011-06-20
! IF (sw_physics.eq.3) THEN
IF (sw_physics.eq.3 .or. sw_physics.eq.4) THEN
! End by Zhenxin 2011-06-20
!**********************************************
!fds - RADFRAC from radiation scheme 3 (06/2010)
!fds - Otherwise use cloud cover to calculate radfrac
radfrac11 = amax1(radfrac11,0.025)
radfrac12 = amax1(radfrac12,0.025)
radfrac21 = amax1(radfrac21,0.025)
radfrac22 = amax1(radfrac22,0.025)
swdown = radfrac11 + radfrac12 + radfrac21 + radfrac22
RADFRAC(1,1) = radfrac11/swdown
RADFRAC(1,2) = radfrac12/swdown
RADFRAC(2,1) = radfrac21/swdown
RADFRAC(2,2) = radfrac22/swdown
ELSE
! ** CALCULATE THE CLOUD COVER USING AN EMPIRICAL EQUATION
! ONLY USE THIS PART WHEN IT IS NEEDED
! ** ONLY USE THIS PART WHEN SW_PHYSICS = 1 IS USED ** By Zhenxin 2011-06
swdown = amax1(swdown1,0.1)
CLOUD = AMAX1(CLOUD,0.0)
CLOUD = AMIN1(CLOUD,1.0)
CLOUD = AMAX1(0.58,CLOUD)
!
DIFRAT = 0.0604 / ( SUNANG-0.0223 ) + 0.0683
IF ( DIFRAT .LT. 0.0 ) DIFRAT = 0.0
IF ( DIFRAT .GT. 1.0 ) DIFRAT = 1.0
!
DIFRAT = DIFRAT + ( 1.0 - DIFRAT ) * CLOUD
VNRAT = ( 580.0 - CLOUD*464.0 ) / ( ( 580.0-CLOUD*499.0) &
& + ( 580.0 - CLOUD*464.0 ) )
!
RADFRAC(1,1) = (1.0-DIFRAT)*VNRAT
RADFRAC(1,2) = DIFRAT*VNRAT
RADFRAC(2,1) = (1.0-DIFRAT)*(1.0-VNRAT)
RADFRAC(2,2) = DIFRAT*(1.0-VNRAT)
!**********************************************
ENDIF
!
RADN(1,1) = RADFRAC(1,1) * SWDOWN
RADN(1,2) = RADFRAC(1,2) * SWDOWN
RADN(2,1) = RADFRAC(2,1) * SWDOWN
RADN(2,2) = RADFRAC(2,2) * SWDOWN
RADN(3,1) = 0.
RADN(3,2) = RLWDOWN
!
! END OF EMPIRICAL EQUATIONS
! *********************************************************
!
CALL RADAB_ICE(TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF, &
TC,TGS,SATCAP,EXTK,CLOSS,GLOSS,THERMK,P1F,P2F, &
RADT,PAR,PD,SALB,ALBEDO,TGEFF,SUNANG,XADJ,CAPAC, &
RADN,BEDO,ZLWUP,RADFRAC,SWDOWN,SNOCV,1, &
fsdown,fldown,fsup,flup)
CALL ROOT1(PHSAT,BEE,WWW,PHSOIL)
CALL STOMA1(GREEN,VCOVER,CHIL,ZLT,PAR,PD,EXTK,SUNANG,RST, &
RSTPAR, CTLPA)
!***
POROSAVE=POROS
POROS=0.95
!***
!
CALL INTERC(DTT ,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL,ROFF, &
ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET,EXTK,RNOFFS,FILTR, &
SMELT)
!
CALL TEMRS1(DTT,TC,TGS,TD,TA,TM,QM,EM,PSUR,WWW,CAPAC,SATCAP, &
DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,XDD,Z0,RDC,RBC,VCOVER,Z2, &
ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP, &
THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN, &
BPS,rib,CU,XCT,flup,ii,jj)
!
CALL UPDAT1_ICE(DTT ,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, &
EGS,EG,HC,HG,HFLUX,ETMASS,FILTR,SOILDIF,SOILDRA,ROFF, &
RNOFFB,RNOFFS,NROOT,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF,SMELT)
!***
POROS=POROSAVE
TD = AMIN1(TD ,273.15)
TC = AMIN1(TC ,273.15)
TGS = AMIN1(TGS,273.15)
!***
!
!------------------------------------------------------------------------
SOILM=(WWW(1)*ZDEPTH(1)+WWW(2)*ZDEPTH(2)+WWW(3)*ZDEPTH(3))*POROS
!------------------------------------------------------------------------
UMOM=RHOAIR*CU*USTAR*UMM
VMOM=RHOAIR*CU*USTAR*VMM
HLFLX= ETMASS/RHOAIR/DTT
HSFLX= HFLUX/CPAIR/RHOAIR/DTT
ULWSF1=TGEFF*TGEFF*TGEFF*TGEFF*STEFAN
Q2M=0.622*EA/(PSURF-EA)
EVAP=ETMASS*HLAT
CM=(USTAR*USTAR)/(UM*UM)
CH=1/(UM*RA)
!
FM=VKC/CU
! FH=VKC/CT !fds corrected (02/2012)
FH=VKC/XCT
!
!
ELATEN=EVAP/DTT
XHLFLX=ELATEN/HLAT
GHTFLX=CHF+SHF
!=====================================================================
xhsflx=(hc+hg)/dtt
!=====================================================================
!
WWW1=WWW(1)*POROS
WWW2=WWW(2)*POROS
WWW3=WWW(3)*POROS
SNOA = CAPAC(2)
SNOB = CAPAC(1)
SALB11=SALB(1,1)
SALB12=SALB(1,2)
SALB21=SALB(2,1)
SALB22=SALB(2,2)
!
! later for output
!
xlhf = elaten
xshf = xhsflx
xghf = ghtflx
xsdn = fsdown
xsup = fsup
xldn = fldown
xlup = flup
xwat = soilm
xxz0 = z0
xveg = float(itype)
!
!------------------------------------------------------
END SUBROUTINE SSIB_SEAICE
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE CROPS(XLAT,DAY,CHIL,ZLT,GREEN,XCOVER & 1
,RSTPAR,TOPT,TL,TU,DEFAC,PH2,PH1)
!
!=======================================================================
!
! A NEW CROP VERSION BY XUE. AUG., 1998
!
! XLAT IS FROM -90 TO 90 DEGREES FROM S. TO N.
!
!----------------------------------------------------------------------
REAL, DIMENSION (2) :: GREEN, XCOVER, CHIL, ZLT, TOPT, TL, TU, DEFAC, PH1, PH2
REAL, DIMENSION (2,3) :: RSTPAR
REAL, DIMENSION (9) :: PHENST, WLAI, WGRN
!
!-----------------------------------------------------------------
!** E J H SD R HRV CUT PRE-E E
! SAVE WLAI,WGRN,IHEAD,IEND,DEND,IWHEAT,SYR
DATA WLAI/1.0, 2.0, 6.0, 4.0, 3.0, 1.0, 0.01, 0.01, 1.0/
DATA WGRN/0.6, 0.9, 0.8, 0.5, 0.2, 0.1, 0.01, 0.01, 0.6/
DATA IHEAD,IEND,DEND,IWHEAT/3,9,244.,12/,SYR/365.25E0/
IF (XLAT.LT.0.) THEN
RDAY= DAY+184
IF (RDAY.GT.365) RDAY=RDAY-365
ELSE
RDAY= DAY
END IF
JULDAY=INT(RDAY+0.2)
PHI=XLAT
APHI = ABS(PHI)
IF (APHI.GT.55.) PHI=SIGN(55.,PHI)
IF (APHI.LT.20.) PHI=SIGN(20.,PHI)
!
FLIP = 0.0
!
! ** DETERMINE WHEAT PHENOLOGY FOR LATITUDE AND JULIAN DAY
PHENST(2) = 4.50 *ABS(PHI) - 64.0 + FLIP
PHENST(3) = 4.74 *ABS(PHI) - 46.2 + FLIP
PHENST(4) = 4.86 *ABS(PHI) - 30.8 + FLIP
PHENST(5) = 4.55 *ABS(PHI) - 3.0 + FLIP
PHENST(6) = 4.35 *ABS(PHI) + 11.5 + FLIP
PHENST(7) = PHENST(6) + 3.0
DEMG = ABS( 5.21 *ABS(PHI) - 0.3 )
PHENST(1) = PHENST(2) - DEMG
PHENST(9) = PHENST(1)
PHENST(8) = PHENST(9) - 5.0
!
DO 10 NS = 1,9
IF(PHENST(NS) .LT. 0.0E0)PHENST(NS) = PHENST(NS) + 365.
IF(PHENST(NS) .GT. 365. )PHENST(NS) = PHENST(NS) - 365.
10 CONTINUE
!
ROOTGC = 1.0
CHILW =-0.02
TLAI = 0.5
GRLF = 0.6
!
! ** FIND GROWTH STAGE GIVEN LATITUDE AND DAY
DO 50 NS = 1,8
TOP = PHENST(NS+1)
BOT = PHENST(NS)
DIFF1 = TOP-BOT
DIFF2 = RDAY-BOT
IF(RDAY.GE. BOT .AND. RDAY .LE. TOP ) GO TO 40
IF(BOT .LT. TOP ) GO TO 50
!
! ** PHENOLOGY STAGES OVERLAP THE END OF YEAR?
ICOND = 0
IF(RDAY .GE. BOT .AND. RDAY .LE. 365.) ICOND = 1
IF(RDAY .GE. 0.0 .AND. RDAY .LE. TOP ) ICOND = 2
!
IF(ICOND .EQ. 0)GO TO 50
IF(ICOND .EQ. 2)GO TO 35
DIFF1 = 365. - BOT + TOP
DIFF2 = RDAY - BOT
GO TO 40
!
35 CONTINUE
DIFF1 = 365. - BOT + TOP
DIFF2 = 365. - BOT + RDAY
!
! ** DATE FOUND IN PHENOLOGY STAGE
40 CONTINUE
IF ((RDAY.GT.PHENST(IHEAD)).AND.(RDAY.LE.DEND)) THEN
TLAI=WLAI(IHEAD)
GRLF=WGRN(IHEAD)
GO TO 77
END IF
IF ((RDAY.GT.DEND).AND.(RDAY.LE.PHENST(IEND))) THEN
DIFF1=PHENST(IEND)-DEND
DIFF2=RDAY-DEND
PERC = DIFF2/DIFF1
TLAI = PERC*(WLAI(IEND)-WLAI(IHEAD)) + WLAI(IHEAD)
GRLF = PERC*(WGRN(IEND)-WGRN(IHEAD)) + WGRN(IHEAD)
GO TO 77
END IF
PERC = DIFF2/DIFF1
TLAI = PERC*(WLAI(NS+1)-WLAI(NS)) + WLAI(NS)
GRLF = PERC*(WGRN(NS+1)-WGRN(NS)) + WGRN(NS)
77 CONTINUE
GO TO 95
50 CONTINUE
95 CONTINUE
XCOVER(1)=0.90*(1.0 - EXP(-TLAI))
ZLTGMX = WLAI(IHEAD)
ROOTGC = 2910.0 * (0.5 +0.5 *TLAI/ZLTGMX * GRLF)
IF (NS.NE.1.AND.NS.NE.2) CHILW=-0.2
!
ZLT (1) = TLAI
GREEN (1) = GRLF
CHIL (1) = CHILW
!
!------------------------------------------------------
END SUBROUTINE CROPS
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE ROOT1(PHSAT,BEE,WWW,PHSOIL) 2
! 12 AUG 2000
!=======================================================================
!
! CALCULATION OF SOIL MOISTURE POTENTIALS IN ROOT ZONE OF EACH
! VEGETATION LAYER AND SUMMED SOIL+ROOT RESISTANCE
!
!-----------------------------------------------------------------------
!----------------------------------------------------------------------
REAL, DIMENSION (3) :: WWW, PHSOIL
!
DO 1000 IL = 1, 3
PHSOIL(IL) = PHSAT * AMAX1( 0.05, WWW(IL) ) ** ( - BEE )
1000 CONTINUE
!
!-----------------------------------------------------------------------
! AVERAGE SOIL MOISTURE POTENTIAL IN ROOT ZONE USED FOR SOURCE
!-----------------------------------------------------------------------
!
!
! PHROOT(1) = PHSOIL(1)-0.01
!
! DO 1200 I = 2 ,3
!1200 PHROOT(1) = AMAX1( PHROOT(1), PHSOIL(I) )
! PHROOT(2) = PHROOT(1)
!
!
!------------------------------------------------------
END SUBROUTINE ROOT1
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE STOMA1(GREEN,VCOVER,CHIL,ZLT,PAR,PD,EXTK,SUNANG,RST, & 2
RSTPAR,CTLPA)
! 12 AUG 2000
!=======================================================================
!
! CALCULATION OF PAR-LIMITED STOMATAL RESISTANCE
!
!-----------------------------------------------------------------------
!----------------------------------------------------------------------
REAL, DIMENSION (2) :: GREEN, VCOVER, ZLT, CHIL, PAR, PD, RST
REAL, DIMENSION (2,3) :: RSTPAR
REAL, DIMENSION (2,3,2) :: EXTK
!
DO 1000 IVEG = 1, 2
!
AT = ZLT(IVEG) / VCOVER(IVEG)
!
IF (SUNANG .LE. 0.02) THEN
XABC = RSTPAR(IVEG,1) / RSTPAR(IVEG,2) + RSTPAR(IVEG,3)
RST(IVEG) = 0.5 / XABC * AT
IF (RST(IVEG) .LT. 0.) RST(IVEG) = 0.00001
GO TO 1010
END IF
!
GAMMA = ( RSTPAR(IVEG,1) + RSTPAR(IVEG,2) * RSTPAR(IVEG,3) ) / &
RSTPAR(IVEG,3)
!
POWER1 = AMIN1( 50., AT * EXTK(IVEG,1,1) )
POWER2 = AMIN1( 50., AT * EXTK(IVEG,1,2) )
!
!-----------------------------------------------------------------------
! ROSS INCLINATION FUNCTION
!-----------------------------------------------------------------------
!
AA = 0.5 - 0.633 * CHIL(IVEG)- 0.33 * CHIL(IVEG)* CHIL(IVEG)
BB = 0.877 * ( 1. - 2. * AA )
!
!-----------------------------------------------------------------------
! COMBINED ESTIMATE OF K-PAR USING WEIGHTS FOR DIFFERENT COMPONENTS
!-----------------------------------------------------------------------
!
ZAT = ALOG( ( EXP(-POWER1) + 1. )/2. ) * PD(IVEG) &
/ ( POWER1/AT )
ZAT = ZAT + ALOG( ( EXP(-POWER2) + 1. )/2. ) &
* ( 1. - PD(IVEG) ) / ( POWER2/AT )
!
POW1 = AMIN1( 50., (POWER1*ZAT/AT) )
POW2 = AMIN1( 50., (POWER2*ZAT/AT) )
!
ZK = 1. / ZAT * ALOG( PD(IVEG) * EXP ( POW1 ) &
+ ( 1. - PD(IVEG) ) * EXP ( POW2 ) )
!
!
POW = AMIN1( 50., ZK*AT )
EKAT = EXP ( POW )
!
AVFLUX = PAR(IVEG) * ( PD(IVEG) / SUNANG * ( AA + BB * SUNANG ) &
+ ( 1. - PD(IVEG) )*( BB / 3. + AA * 1.5 &
+ BB / 4. * PIE ))
!
RHO4 = GAMMA / AVFLUX
!
RST(IVEG) = RSTPAR(IVEG,2)/GAMMA * ALOG(( RHO4 * EKAT + 1. ) / &
( RHO4 + 1. ) )
RST(IVEG) = RST(IVEG) - ALOG (( RHO4 + 1. / EKAT ) / &
( RHO4 + 1. ) )
RST(IVEG) = RST(IVEG) / ( ZK * RSTPAR(IVEG,3) )
!
!----------------------------------------------------------------------
! MODIFICATIONS FOR GREEN FRACTION : RST UPRIGHT
!----------------------------------------------------------------------
!
1010 RST(IVEG) = 1. / ( RST(IVEG) * GREEN(IVEG) + 0.0000001)
1000 CONTINUE
!
RST(1) = RST(1) * CTLPA
!
!------------------------------------------------------
END SUBROUTINE STOMA1
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE VEGOUT(XTRAN,XREF,XGREEN,XVCOVER,XCHIL, & 2
XRSTPAR,XTOPT,XTL,XTU,XDEFAC,XPH1,XPH2, &
XZLT,XZ0,XDD,XZ2,XZ1,XRDC,XRBC,XROOTD,XSOREF, &
XBEE, XPHSAT, XPOROS, XSATCO,XSLOPE, &
XDEPTH,MONTH,ITYPE)
! 12 AUGUSTY 2000
!=======================================================================
!
! ASSIGN VEGETATION PHYSIOLOGY
!
! SURFACE PARAMETERS ARE READ IN SAME ORDER AS IN GCM
! SUBROUTINE SIBINP. ONLY EXCEPTION IS THAT 1-D VERSION READS IN
! SITE SPECIFIC PARAMETERS CORB1 ... ZMET .
!
! VARIABLES THAT ENTER THROUGH COMSIB:
! SUBSCRIPTS (IV, IW, IL) :
! IV = VEGETATION STORY; 1 = TOP AND 2 = BOTTOM
! IW = RADIATION WAVELENGTH; 1 = VISIBLE, 2 = NEAR
! INFRARED AND 3 = THERMAL INFRARED
! IL = VEGETATION STATE; 1 = LIVE (GREEN) AND
! 2 = DEAD (STEMS AND TRUNK)
!
! TRAN(IV,IW,IL): LEAF TRANSMITTANCE
! REF (IV,IW,IL): LEAF REFLECTANCE
! RSTPAR(IV,IW) : PAR-DEPENDENT LEAF STOMATAL RESISTANCE COEFFICIENTS
! A =(J/M**3) B = 2(W/M**2) C = 3(S/M)
! SOREF(IW) : SOIL REFLECTANCE
! CHIL(IV) : LEAF ANGLE DISTRIBUTION FACTOR
! TOPT(IV) : OPTIMUM TEMPERATURE FOR STOMATAL FUNCTIONING
! TL(IV) : LOWER TEMPERATURE LIMIT FOR STOMATAL FUNCTIONING
! TU(IV) : UPPER TEMPERATURE LIMIT FOR STOMATAL FUNCTIONING
! DEFAC(IV) : VAPOR PRESSURE DEFICIT PARAMETER
! PH1(IV) :
! PH2(IV) :
! ROOTD(IV) : ROOTING DEPTH
! BEE : SOIL WETNESS EXPONENT
! PHSAT : SOIL TENSION AT SATURATION
! SATCO : HYDRAULIC CONDUCTIVITY AT SATURATION
! POROS : SOIL POROSITY
! ZDEPTH : DEPTH OF 3 SOIL MOISTURE LAYERS
! Z0 : ROUGHNESS LENGTH
! XDD : ZERO PLANE DISPLACEMENT
! ZLT(IV) : LEAF AREA INDEX
! GREEN(IV) : GREEN LEAF FRACTION
! VCOVER(IV) : VEGETATION COVER FRACTION
!
! VARIABLES ( SPECIFIC TO SIB 1-D VERSION ONLY ) FROM COMSIB
!
! ZWIND : REFERENCE HEIGHT FOR WIND MEASUREMENT
! ZMET : REFERENCE HEIGHT FOR TEMPERATURE, HUMIDITY MEASUREMENT
! THE ABOVE ARE GENERATED FROM SIBX + MOMOPT OUTPUT
!
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! USE module_ssib_veg
!----------------------------------------------------------------------
!
REAL, DIMENSION (2) :: XGREEN, XVCOVER, XZLT, XCHIL, XTOPT, XTL, &
XTU, XDEFAC, XPH1, XPH2, XROOTD
REAL, DIMENSION (3) :: XSOREF, XDEPTH
REAL, DIMENSION (2,3) :: XRSTPAR
REAL, DIMENSION (2,3,2) :: XTRAN, XREF
!-----------------------------------------------------------------------
!
DO IW=1,3
XTRAN(1,IW,1)=TRAN0(ITYPE,1,IW,1)
XTRAN(1,IW,2)=TRAN0(ITYPE,1,IW,2)
XTRAN(2,IW,1)=TRAN0(ITYPE,2,IW,1)
XTRAN(2,IW,2)=TRAN0(ITYPE,2,IW,2)
XREF (1,IW,1)= REF0(ITYPE,1,IW,1)
XREF (1,IW,2)= REF0(ITYPE,1,IW,2)
XREF (2,IW,1)= REF0(ITYPE,2,IW,1)
XREF (2,IW,2)= REF0(ITYPE,2,IW,2)
XRSTPAR(1,IW)=RSTPAR0(ITYPE,1,IW)
XRSTPAR(2,IW)=RSTPAR0(ITYPE,2,IW)
XSOREF (IW) =SOREF0(ITYPE,IW)
END DO
DO IV=1,2
XCHIL(IV)=CHIL0(ITYPE,IV)
XTOPT(IV)=TOPT0(ITYPE,IV)
XTL(IV)=TL0(ITYPE,IV)
XTU(IV)=TU0(ITYPE,IV)
XDEFAC(IV)=DEFAC0(ITYPE,IV)
XPH1(IV)=PH10(ITYPE,IV)
XPH2(IV)=PH20(ITYPE,IV)
XROOTD(IV)=ROOTD0(ITYPE,IV)
XZLT(IV)=ZLT0(ITYPE,MONTH,IV)
XGREEN(IV)=GREEN0(ITYPE,MONTH,IV)
XVCOVER(IV)=VCOVER0(ITYPE,MONTH,IV)
END DO
DO IDEP=1,3
XDEPTH(IDEP)=DEPTH0(ITYPE,IDEP)
END DO
!
XBEE=BEE0(ITYPE)
XPHSAT=PHSAT0(ITYPE)
XSATCO=SATCO0(ITYPE)
XPOROS=POROS0(ITYPE)
XSLOPE=SLOPE0(ITYPE)
XZ2=Z20(ITYPE,MONTH)
XZ1=Z10(ITYPE,MONTH)
XZ0= Z000(ITYPE,MONTH)
XDD= D0(ITYPE,MONTH)
XRBC=RBC0 (ITYPE,MONTH)
XRDC=RDC0 (ITYPE,MONTH)
!
!------------------------------------------------------
END SUBROUTINE VEGOUT
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE COMBO (DDZ2,DZP,DZM,WP,WM,HP,HM,TP,TM,BWP,BWM,BIP, & 12,1
BIM,BLP,BLM,BTP,BTM,FIP,FIM,FLP,FLM,CTP,CTM, &
DLIQVOLP,DLIQVOLM,DICEVOLP,DICEVOLM)
!
!=======================================================================
!
RATIO= DDZ2/dzm
dzp=dzp + RATIO*dzm
wp = wp + RATIO*wm
hp = hp + RATIO*hm
bwp= wp*rhowater/dzp
btp= bwp
ctp= (1.9e6)*(bwp/920.0)
dmlt=wp*rhowater*dlm
if(hp.ge.(-1.0)*dmlt)then
tp=273.16
fip=(-1.0)*hp/dmlt
flp=1.0-fip
blp=bwp*flp
bip=bwp*fip
dliqvolp = blp/rhowater
dicevolp = bip/dice
else
flp=0.0
fip=1.0
tp=(hp+dmlt)/(ctp*dzp)+273.16
bip=bwp
blp=0.0
dliqvolp = 0.0
dicevolp = bip/dice
endif
!
dzm=dzm - RATIO*dzm
wm = wm - RATIO*wm
hm = hm - RATIO*hm
!
!------------------------------------------------------
END SUBROUTINE COMBO
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE COMPACT(BI,T,BL,OVERBURDEN,PDZDT,SS,DICE) 2
!
!=======================================================================
!clwp 12/11/2000, change the subroutine back to NO DATE form.
data c2,c3,c4,c5/23d-3,2.777d-6,0.04,2.0/
data dm/150/
data eta0/0.9d6/
if(bi .ge. dice .or. ss .ge. 1.) return
ddz1=-c3*exp(-c4*(273.15-t))
if(bi .gt. dm) ddz1=ddz1*exp(-46.0d-3*(bi-dm))
if(bl .gt. 0.01) ddz1=ddz1*c5
!cl compaction due to overburden
ddz2=-overburden*exp(-0.08*(273.15-t)-c2*bi)/eta0
!cl compaction occurring during melt has been taken into account in thermal.f
ddz3=0d0
pdzdt=ddz1+ddz2+ddz3
!
!------------------------------------------------------
END SUBROUTINE COMPACT
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE GETMET(IPTYPE,PRCP_TOTAL,TAIR, & 1
PRCP_S,PRCP_W,FI_FALL,FL_FALL,BI_FALL,BL_FALL)
!
!=======================================================================
IF (PRCP_TOTAL.gt.0.) THEN
IF(IPTYPE.EQ.2)THEN
PRCP_S=PRCP_TOTAL
PRCP_W=0.0
ELSE IF(IPTYPE.EQ.1)THEN
PRCP_W=PRCP_TOTAL
PRCP_S=0.0
FL_FALL=1.0
FI_FALL=0.
BL_FALL=1000.0
BI_FALL=0.0
ENDIF
ELSE
PRCP_W=0.0
PRCP_S=0.0
IPTYPE = 0
RETURN
END IF
IF (IPTYPE.NE.1) THEN
IF (TAIR .GT. 275.15) THEN
BI_FALL =189
ELSE IF (TAIR.GT.258.16)THEN
BI_FALL=50+1.7*(TAIR-258.16)**1.5d0
ELSE
BI_FALL=50
ENDIF
FL_FALL = 0
FI_FALL=1.0
BL_FALL=0.0
ENDIF
!
!------------------------------------------------------
END SUBROUTINE GETMET
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE INTERCS (DTT,VCOVER,ZLAI,TM,TC,TGS,CAPAC,WWW,PPC,PPL, & 1
ROFF,ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET, &
EXTK,ISNOW,P0,CSOIL,DZSOIL, &
CHISL,SMELT)
! 1 AUGUST 1988
!=======================================================================
!
! CALCULATION OF (1) INTERCEPTION AND DRAINAGE OF RAINFALL AND SNOW
! (2) SPECIFIC HEAT TERMS FIXED FOR TIME STEP
!
! MODIFICATION 30 DEC 1985 : NON-UNIFORM PRECIPITATION
! ------------ CONVECTIVE PPN. IS DESCRIBED BY AREA-INTENSITY
! RELATIONSHIP :-
!
! F(X) = A*EXP(-B*X)+C
!
! THROUGHFALL, INTERCEPTION AND INFILTRATION
! EXCESS ARE FUNCTIONAL ON THIS RELATIONSHIP
! AND PROPORTION OF LARGE-SCALE PPN.
!----------------------------------------------------------------------
!
DIMENSION CAPACP(2), SNOWP(2), PCOEFS(2,2)
DATA PCOEFS(1,1)/ 20. /, PCOEFS(1,2)/ .206E-8 /, &
PCOEFS(2,1)/ 0.0001 /, PCOEFS(2,2)/ 0.9999 /, BP /20. /
DIMENSION VCOVER(2),ZLAI(2),WWW(3),CAPAC(2),SATCAP(2),EXTK(2,3,2)
DIMENSION ZDEPTH(3),SNOWW(2)
!
AP = PCOEFS(2,1)
CP = PCOEFS(2,2)
TOTALP = PPC + PPL
IF(TOTALP.LT.1.E-8)GO TO 6000
AP = PPC/TOTALP * PCOEFS(1,1) + PPL/TOTALP * PCOEFS(2,1)
CP = PPC/TOTALP * PCOEFS(1,2) + PPL/TOTALP * PCOEFS(2,2)
6000 CONTINUE
ROFF = 0.
THRU = 0.
FPI = 0.
!
!----------------------------------------------------------------------
! THERMAL CONDUCTIVITY OF THE SOIL, TAKING INTO ACCOUNT POROSITY
!----------------------------------------------------------------------
!
THETA=WWW(1)*POROS
CHISL=( 9.8E-4+1.2E-3*THETA )/( 1.1-0.4*THETA )
CHISL=CHISL*4.186E2
!
!----------------------------------------------------------------------
! THERMAL DIFFUSIVITY AND HEAT CAPACITY OF THE SOIL
!----------------------------------------------------------------------
!
DIFSL=5.E-7
!
ROCS =CHISL/DIFSL
D1 =SQRT(DIFSL*86400.0)
CSOIL=ROCS*D1/SQRT(PIE)/2.0
! YX2002 (test2)
dzsoil=D1/SQRT(PIE)/2.0
THALAS=0.
OCEANS=0.
POLAR=0.
CSOIL=CSOIL*(1.0-THALAS)+10.E10*OCEANS+POLAR*3.6*4.2E4
!
P0 = TOTALP * 0.001
!
!----------------------------------------------------------------------
! INPUT PRECIPITATION IS GIVEN IN MM, CONVERTED TO M TO GIVE P0.
!----------------------------------------------------------------------
!
DO 1000 IVEG = 1, 2
!
SPWET1 = AMIN1 ( 0.05, CAPAC(IVEG))*CW
!
TS = TC
SPECHT = ZLAI(1) * CLAI
IF ( IVEG .EQ. 1 ) GO TO 1100
TS = TGS
SPECHT = CSOIL
1100 CONTINUE
!
XSC = AMAX1(0., CAPAC(IVEG) - SATCAP(IVEG) )
IF(IVEG.EQ.2 .AND. TS.LE.TF )GO TO 1170
CAPAC(IVEG) = CAPAC(IVEG) - XSC
ROFF = ROFF + XSC
1170 CONTINUE
CAPACP(IVEG) = 0.
SNOWP(IVEG) = 0.
!
IF( TS .GT. TF ) CAPACP(IVEG) = CAPAC(IVEG)
IF( TS .LE. TF ) SNOWP(IVEG) = CAPAC(IVEG)
CAPAC(IVEG) = CAPACP(IVEG)
SNOWW(IVEG) = SNOWP(IVEG)
ZLOAD = CAPAC(IVEG) + SNOWW(IVEG)
!
FPI = ( 1.-EXP( - EXTK(IVEG,3,1) * ZLAI(IVEG)/VCOVER(IVEG) ) ) &
* VCOVER(IVEG)
TTI = P0 * ( 1.-FPI )
!
!----------------------------------------------------------------------
! PROPORTIONAL SATURATED AREA (XS) AND LEAF DRAINAGE(TEX)
!----------------------------------------------------------------------
!
XS = 1.
IF ( P0 .LT. 1.E-9 ) GO TO 1150
ARG = ( SATCAP(IVEG)-ZLOAD )/( P0*FPI*AP ) -CP/AP
IF ( ARG .LT. 1.E-9 ) GO TO 1150
XS = -1./BP * ALOG( ARG )
XS = AMIN1( XS, 1. )
XS = AMAX1( XS, 0. )
1150 TEX = P0*FPI * ( AP/BP*( 1.- EXP( -BP*XS )) + CP*XS ) - &
( SATCAP(IVEG) - ZLOAD ) * XS
TEX = AMAX1( TEX, 0. )
!
!----------------------------------------------------------------------
! TOTAL THROUGHFALL (THRU) AND STORE AUGMENTATION
!----------------------------------------------------------------------
!
THRU = TTI + TEX
IF(IVEG.EQ.2.AND.TGS.LE.TF)THRU = 0.
!
PINF = P0 - THRU
IF( TM .GT. TF ) CAPAC(IVEG) = CAPAC(IVEG) + PINF
IF( TM .LE. TF ) SNOWW(IVEG) = SNOWW(IVEG) + PINF
!
IF( IVEG .EQ. 1 ) GO TO 1300
IF( TM .GT. TF ) GO TO 1200
SNOWW(IVEG) = SNOWP(IVEG) + P0
THRU = 0.
GO TO 1300
!
!----------------------------------------------------------------------
! INSTANTANEOUS OVERLAND FLOW CONTRIBUTION ( ROFF )
!----------------------------------------------------------------------
!
1200 EQUDEP = SATCO * DTT
!
XS = 1.
IF ( THRU .LT. 1.E-9 ) GO TO 1250
ARG = EQUDEP / ( THRU * AP ) -CP/AP
IF ( ARG .LT. 1.E-9 ) GO TO 1250
XS = -1./BP * ALOG( ARG )
XS = AMIN1( XS, 1. )
XS = AMAX1( XS, 0. )
1250 ROFFO = THRU * ( AP/BP * ( 1.-EXP( -BP*XS )) + CP*XS ) &
-EQUDEP*XS
ROFFO = AMAX1 ( ROFFO, 0. )
ROFF = ROFF + ROFFO
WWW(1) = WWW(1) + (THRU - ROFFO) / ( POROS*ZDEPTH(1) )
1300 CONTINUE
!
!----------------------------------------------------------------------
! TEMPERATURE CHANGE DUE TO ADDITION OF PRECIPITATION
!----------------------------------------------------------------------
!
DIFF = ( CAPAC(IVEG)+SNOWW(IVEG) - CAPACP(IVEG)-SNOWP(IVEG) )*CW
CCP = SPECHT + SPWET1
CCT = SPECHT + SPWET1 + DIFF
!
TSD = ( TS * CCP + TM * DIFF ) / CCT
!
FREEZE = 0.
IF ( TS .GT. TF .AND. TM .GT. TF ) GO TO 2000
IF ( TS .LE. TF .AND. TM .LE. TF ) GO TO 2000
!
TTA = TS
TTB = TM
CCA = CCP
CCB = DIFF
IF ( TSD .GT. TF ) GO TO 2100
!
!----------------------------------------------------------------------
! FREEZING OF WATER ON CANOPY OR GROUND
!----------------------------------------------------------------------
!
CCC = CAPACP(IVEG) * SNOMEL
IF ( TS .LT. TM ) CCC = DIFF * SNOMEL / CW
TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
!
FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
FREEZE = (AMIN1 ( CCC, FREEZE )) / SNOMEL
IF(TSD .GT. TF)TSD = TF - 0.1
!
GO TO 2000
!
2100 CONTINUE
!
!----------------------------------------------------------------------
! MELTING OF SNOW ON CANOPY OR GROUND
!----------------------------------------------------------------------
!
CCC = - SNOWW(IVEG) * SNOMEL
IF ( TS .GT. TM ) CCC = - DIFF * SNOMEL / CW
!
TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
!
FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
FREEZE = (AMAX1( CCC, FREEZE )) / SNOMEL
IF(TSD .LE. TF)TSD = TF - 0.1
!
2000 CONTINUE
!crr
SMELT = FREEZE
!crr
SNOWW(IVEG) = SNOWW(IVEG) + FREEZE
CAPAC(IVEG) = CAPAC(IVEG) - FREEZE
!
IF( IVEG .EQ. 1 ) TC = TSD
IF( IVEG .EQ. 2 ) TGS = TSD
IF( SNOWW(IVEG) .LT. 0.0000001 ) GO TO 3000
! modeified to force water into soil Xue Feb. 1994
! ZMELT = 0.
! IF ( TD .GT. TF ) ZMELT = CAPAC(IVEG)
! IF ( TD .LE. TF ) ROFF = ROFF + CAPAC(IVEG)
ZMELT = CAPAC(IVEG)
CAPAC(IVEG) = 0.
WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
!
3000 CONTINUE
!
CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
SNOWW(IVEG) = 0.
!
P0 = THRU
IF (ISNOW.eq.0) go to 1001
1000 CONTINUE
!
!----------------------------------------------------------------------
! CALCULATION OF CANOPY AND GROUND HEAT CAPACITIES.
! N.B. THIS SPECIFICATION DOES NOT NECESSARILY CONSERVE ENERGY WHEN
! DEALING WITH VERY LATGE SNOWPACKS.
!----------------------------------------------------------------------
!
1001 CCX = ZLAI(1) * CLAI + CAPAC(1) * CW
SPWET = AMIN1 ( 0.05, CAPAC(2)) * CW
CG = (CSOIL + SPWET)
!
!------------------------------------------------------
END SUBROUTINE INTERCS
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE INTERC(DTT,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL,ROFF, & 1
ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET,EXTK,RNOFFS,FILTR,SMELT)
! 12 AUGUST 2000
!=======================================================================
!
! CALCULATION OF (1) INTERCEPTION AND DRAINAGE OF RAINFALL AND SNOW
! (2) SPECIFIC HEAT TERMS FIXED FOR TIME STEP
!
! MODIFICATION 30 DEC 1985 : NON-UNIFORM PRECIPITATION
! ------------ CONVECTIVE PPN. IS DESCRIBED BY AREA-INTENSITY
! RELATIONSHIP :-
!
! F(X) = A*EXP(-B*X)+C
!
! THROUGHFALL, INTERCEPTION AND INFILTRATION
! EXCESS ARE FUNCTIONAL ON THIS RELATIONSHIP
! AND PROPORTION OF LARGE-SCALE PPN.
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!
REAL, DIMENSION (2) :: VCOVER, ZLT, CAPAC, SATCAP, SNOWW, CAPACP, SNOWP
REAL, DIMENSION (3) :: WWW, ZDEPTH
REAL, DIMENSION (2,2) :: PCOEFS
REAL, DIMENSION (2,3,2) :: EXTK
DATA PCOEFS(1,1)/ 20. /, PCOEFS(1,2)/ .206E-8 /, &
PCOEFS(2,1)/ 0.0001 /, PCOEFS(2,2)/ 0.9999 /, BP /20. /
!
AP = PCOEFS(2,1)
CP = PCOEFS(2,2)
TOTALP = PPC + PPL
IF(TOTALP.LT.1.E-8)GO TO 6000
AP = PPC/TOTALP * PCOEFS(1,1) + PPL/TOTALP * PCOEFS(2,1)
CP = PPC/TOTALP * PCOEFS(1,2) + PPL/TOTALP * PCOEFS(2,2)
6000 CONTINUE
!
ROFF = 0.
THRU = 0.
FPI = 0.
!
!----------------------------------------------------------------------
! THERMAL CONDUCTIVITY OF THE SOIL, TAKING INTO ACCOUNT POROSITY
!----------------------------------------------------------------------
!
THETA=WWW(1)*POROS
CHISL=( 9.8E-4+1.2E-3*THETA )/( 1.1-0.4*THETA )
CHISL=CHISL*4.186E2
!
!
!----------------------------------------------------------------------
! THERMAL DIFFUSIVITY AND HEAT CAPACITYOF THE SOIL
!----------------------------------------------------------------------
!
DIFSL=5.E-7
!
ROCS =CHISL/DIFSL
D1 =SQRT(DIFSL*86400.0)
CSOIL=ROCS*D1/SQRT(PIE)/2.0
THALAS=0.
OCEANS=0.
POLAR=0.
CSOIL=CSOIL*(1.0-THALAS)+10.E10*OCEANS+POLAR*3.6*4.2E4
!
P0 = TOTALP * 0.001
!
!----------------------------------------------------------------------
! INPUT PRECIPITATION IS GIVEN IN MM, CONVERTED TO M TO GIVE P0.
!----------------------------------------------------------------------
!
DO 1000 IVEG = 1, 2
!
SPWET1 = AMIN1 ( 0.05, CAPAC(IVEG))*CW
!
TS = TC
SPECHT = ZLT(1) * CLAI
IF ( IVEG .EQ. 1 ) GO TO 1100
TS = TGS
SPECHT = CSOIL
1100 CONTINUE
!
XSC = AMAX1(0., CAPAC(IVEG) - SATCAP(IVEG) )
IF(IVEG.EQ.2 .AND. TS.LE.TF )GO TO 1170
CAPAC(IVEG) = CAPAC(IVEG) - XSC
ROFF = ROFF + XSC
RNOFFS = XSC*1000. + RNOFFS
1170 CONTINUE
CAPACP(IVEG) = 0.
SNOWP(IVEG) = 0.
!
IF( TS .GT. TF ) CAPACP(IVEG) = CAPAC(IVEG)
IF( TS .LE. TF ) SNOWP(IVEG) = CAPAC(IVEG)
CAPAC(IVEG) = CAPACP(IVEG)
SNOWW(IVEG) = SNOWP(IVEG)
ZLOAD = CAPAC(IVEG) + SNOWW(IVEG)
!
FPI = ( 1.-EXP( - EXTK(IVEG,3,1) * ZLT(IVEG)/VCOVER(IVEG) ) ) &
* VCOVER(IVEG)
TTI = P0 * ( 1.-FPI )
!
!----------------------------------------------------------------------
! PROPORTIONAL SATURATED AREA (XS) AND LEAF DRAINAGE(TEX)
!----------------------------------------------------------------------
!
XS = 1.
IF ( P0 .LT. 1.E-9 ) GO TO 1150
ARG = ( SATCAP(IVEG)-ZLOAD )/( P0*FPI*AP ) -CP/AP
IF ( ARG .LT. 1.E-9 ) GO TO 1150
XS = -1./BP * ALOG( ARG )
XS = AMIN1( XS, 1. )
XS = AMAX1( XS, 0. )
1150 TEX = P0*FPI * ( AP/BP*( 1.- EXP( -BP*XS )) + CP*XS ) - &
( SATCAP(IVEG) - ZLOAD ) * XS
TEX = AMAX1( TEX, 0. )
!
!----------------------------------------------------------------------
! TOTAL THROUGHFALL (THRU) AND STORE AUGMENTATION
!----------------------------------------------------------------------
!
THRU = TTI + TEX
IF(IVEG.EQ.2.AND.TGS.LE.TF)THRU = 0.
!
PINF = P0 - THRU
IF( TM .GT. TF ) CAPAC(IVEG) = CAPAC(IVEG) + PINF
IF( TM .LE. TF ) SNOWW(IVEG) = SNOWW(IVEG) + PINF
!
IF( IVEG .EQ. 1 ) GO TO 1300
IF( TM .GT. TF ) GO TO 1200
SNOWW(IVEG) = SNOWP(IVEG) + P0
THRU = 0.
GO TO 1300
!
!----------------------------------------------------------------------
! INSTANTANEOUS OVERLAND FLOW CONTRIBUTION ( ROFF )
!----------------------------------------------------------------------
!
1200 EQUDEP = SATCO * DTT
!
XS = 1.
IF ( THRU .LT. 1.E-9 ) GO TO 1250
ARG = EQUDEP / ( THRU * AP ) -CP/AP
IF ( ARG .LT. 1.E-9 ) GO TO 1250
XS = -1./BP * ALOG( ARG )
XS = AMIN1( XS, 1. )
XS = AMAX1( XS, 0. )
1250 ROFFO = THRU * ( AP/BP * ( 1.-EXP( -BP*XS )) + CP*XS ) &
-EQUDEP*XS
ROFFO = AMAX1 ( ROFFO, 0. )
ROFF = ROFF + ROFFO
RNOFFS = RNOFFS + ROFFO*1000.
FILTR = FILTR + (THRU - ROFFO)
WWW(1) = WWW(1) + (THRU - ROFFO) / ( POROS*ZDEPTH(1) )
1300 CONTINUE
!
!----------------------------------------------------------------------
! TEMPERATURE CHANGE DUE TO ADDITION OF PRECIPITATION
!----------------------------------------------------------------------
!
DIFF = ( CAPAC(IVEG)+SNOWW(IVEG) - CAPACP(IVEG)-SNOWP(IVEG) )*CW
CCP = SPECHT + SPWET1
CCT = SPECHT + SPWET1 + DIFF
!
TSD = ( TS * CCP + TM * DIFF ) / CCT
!
FREEZE = 0.
IF ( TS .GT. TF .AND. TM .GT. TF ) GO TO 2000
IF ( TS .LE. TF .AND. TM .LE. TF ) GO TO 2000
!
TTA = TS
TTB = TM
CCA = CCP
CCB = DIFF
IF ( TSD .GT. TF ) GO TO 2100
!
!----------------------------------------------------------------------
! FREEZING OF WATER ON CANOPY OR GROUND
!----------------------------------------------------------------------
!
CCC = CAPACP(IVEG) * SNOMEL
IF ( TS .LT. TM ) CCC = DIFF * SNOMEL / CW
TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
!
FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
FREEZE = (AMIN1 ( CCC, FREEZE )) / SNOMEL
IF(TSD .GT. TF)TSD = TF - 0.1
!
GO TO 2000
!
2100 CONTINUE
!
!----------------------------------------------------------------------
! MELTING OF SNOW ON CANOPY OR GROUND
!----------------------------------------------------------------------
!
CCC = - SNOWW(IVEG) * SNOMEL
IF ( TS .GT. TM ) CCC = - DIFF * SNOMEL / CW
!
TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
!
FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
FREEZE = (AMAX1( CCC, FREEZE )) / SNOMEL
IF(TSD .LE. TF)TSD = TF - 0.1
!
2000 CONTINUE
SMELT = FREEZE
SNOWW(IVEG) = SNOWW(IVEG) + FREEZE
CAPAC(IVEG) = CAPAC(IVEG) - FREEZE
!
IF( IVEG .EQ. 1 ) TC = TSD
IF( IVEG .EQ. 2 ) TGS = TSD
IF( SNOWW(IVEG) .LT. 0.0000001 ) GO TO 3000
ZMELT = 0.
! modified to force water into soil. Xue Feb. 1994
ZMELT = CAPAC(IVEG)
! IF ( TD .GT. TF ) ZMELT = CAPAC(IVEG)
! IF ( TD .LE. TF ) ROFF = ROFF + CAPAC(IVEG)
CAPAC(IVEG) = 0.
WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
FILTR = FILTR + ZMELT
!
3000 CONTINUE
!
CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
SNOWW(IVEG) = 0.
!
! **** LOAD PILPS PARAMETER
!
! if (freeze.lt.0) snm(istat)=snm(istat)-freeze
freeze=0.0
!
P0 = THRU
!
1000 CONTINUE
!
!----------------------------------------------------------------------
! CALCULATION OF CANOPY AND GROUND HEAT CAPACITIES.
! N.B. THIS SPECIFICATION DOES NOT NECESSARILY CONSERVE ENERGY WHEN
! DEALING WITH VERY LATGE SNOWPACKS.
!----------------------------------------------------------------------
!
CCX = ZLT(1) * CLAI + CAPAC(1) * CW
SPWET = AMIN1 ( 0.05, CAPAC(2))*CW
CG = (CSOIL + SPWET)
!
!------------------------------------------------------
END SUBROUTINE INTERC
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE LAYER1 (CSOIL,TGS,DZSOIL,H,W,SNOWDEPTH,SWE,STEMP,ND) 1
!
!=======================================================================
parameter (dice=920.0, rhowater=1000.0,dlm=3.335d5)
dimension h(nd),w(nd)
swe=w(1)+w(2)+w(3)
! YX2002 (test2)
snh=h(1)+h(2)+h(3)+csoil*(tgs-273.16)
! snh=h(1)+h(2)+h(3)+csoil*(tgs-273.16)*dzsoil
dmlto=swe*dlm*rhowater
scv=1.9e+6*(swe/snowdepth)/dice
if (snh.gt.0.0) then
! YX2002 (test2)
stemp=snh/(swe*4.18*10**6.+csoil)+273.16
! stemp=snh/(swe*4.18*10**6.+csoil*dzsoil)+273.16
else if (snh.gt.-dmlto) then
stemp=273.16
else
! YX2002 (test2)
stemp=(snh+dmlto)/(scv*snowdepth+csoil)+273.16
! stemp=(snh+dmlto)/(scv*snowdepth+csoil*dzsoil)+273.16
end if
!
!------------------------------------------------------
END SUBROUTINE LAYER1
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE LAYERN (TG,SNOW_WE,SNOW_DEPTH, DZ0,BW0,W0,BT0,CT0, & 1
FL0,FI0,H0,BL0,BI0,DLIQV0,DICEV0,TSSN0,DMLT0)
!
!=======================================================================
DIMENSION DZ0(4),W0(4),BW0(4),BT0(4),CT0(4),FL0(4),FI0(4),H0(4), &
BL0(4),BI0(4),DLIQV0(4),DICEV0(4),TSSN0(4),DMLT0(4)
! ------------------------------------------------------------------7272
IF(SNOW_DEPTH.GT.0.05.AND.SNOW_DEPTH.LE.0.06) THEN
DZ0(1)=0.02
DZ0(2)=0.02
DZ0(3)=SNOW_DEPTH- DZ0(1)- DZ0(2)
ELSE IF ( SNOW_DEPTH.GT.0.06.AND.SNOW_DEPTH.LE.0.08) THEN
DZ0(3)=0.02
DZ0(2)=0.02
DZ0(1)=SNOW_DEPTH- DZ0(3)- DZ0(2)
ELSE IF ( SNOW_DEPTH.GT.0.08.AND.SNOW_DEPTH.LE.0.62) THEN
DZ0(3)=0.02
DZ0(2)=(SNOW_DEPTH- DZ0(3))*0.33333333
DZ0(1)=(SNOW_DEPTH- DZ0(3))*0.66666667
ELSE IF ( SNOW_DEPTH.GT.0.62) THEN
DZ0(3)=0.02
DZ0(2)=0.20
DZ0(1)=SNOW_DEPTH- DZ0(3)- DZ0(2)
End IF
do 777 i=1,N
TSSN0(I)=TG
BW0(I)=SNOW_WE*RHOWATER/SNOW_DEPTH
777 continue
!---------------------------------------------------------------------
! Next we will calculate the initial variables for time step going on
!---------------------------------------------------------------------
do 666 i=1,N
W0(I)=(BW0(I)*DZ0(I))/RHOWATER
BT0(I)=BW0(I)
CT0(I)=(BW0(I)/920.0)*1.9e+6
IF (TSSN0(I).EQ.273.16)THEN
FL0(I)= FLMIN
FI0(I)=1.0- FLMIN
H0(I)=(-1.0)*W0(I)*FI0(I)*DLM*RHOWATER
BL0(I)=BW0(I)*FL0(I)
BI0(I)=BW0(I)*FI0(I)
DLIQV0(I) = BL0(I)/RHOWATER
DICEV0(I) = BI0(I)/DICE
ELSE IF(TSSN0(I).LT.273.16) THEN
FL0(I)=0.0
FI0(I)=1.0
DMLT0(I)=W0(I)*DLM*RHOWATER
H0(I)=(TSSN0(I)-273.16)*CT0(I)*DZ0(I)-DMLT0(I)
BL0(I)=0.0
BI0(I)=BW0(I)
DLIQV0(I)=0.0
DICEV0(I) = BI0(I)/DICE
ENDIF
666 continue
!
!------------------------------------------------------
END SUBROUTINE LAYERN
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE MODNODE(SNOWDEPTH,DZO,WO,HO,TSSNO,BWO,BIO, & 1,4
BLO,BTO,FIO,FLO,CTO,DLIQVOL,DICEVOL)
!
!=======================================================================
DIMENSION DZO(N1),WO(N1),HO(N1),TSSNO(N1),BWO(N1),BIO(N1),BLO(N1), &
BTO(N1),FIO(N1),FLO(N1),CTO(N1),DLIQVOL(N1),DICEVOL(N1)
!clwp 10/30/2000, for the adjustment of layers 2,3
IF (SNOWDEPTH.le.0.06) then
DZ1=0.02
DZ2=0.02
DZ3=SNOWDEPTH-( DZ2+DZ1)
ELSE IF (SNOWDEPTH.gt.0.06) then
DZ3=0.02
ENDIF
! to get the expected change of top layer of snow
DDZ3=DZ3-dzo(3)
! to get the expected change of top layer of snow
IF (DDZ3.GT.0.0) THEN
DDZ3=MIN(DDZ3,dzo(2))
CALL COMBO (DDZ3,dzo(3),dzo(2),wo(3),wo(2),ho(3),ho(2), &
tssno(3),tssno(2),bwo(3),bwo(2),bio(3),bio(2),blo(3),blo(2), &
bto(3),bto(2),fio(3),fio(2),flo(3),flo(2),cto(3),cto(2), &
dliqvol(3),dliqvol(2),dicevol(3),dicevol(2))
ELSE
DDZ3=-DDZ3
CALL COMBO (DDZ3,dzo(2),dzo(3),wo(2),wo(3),ho(2),ho(3), &
tssno(2),tssno(3),bwo(2),bwo(3),bio(2),bio(3),blo(2),blo(3), &
bto(2),bto(3),fio(2),fio(3),flo(2),flo(3),cto(2),cto(3), &
dliqvol(2),dliqvol(3),dicevol(2),dicevol(3))
END IF
!clwp 10/30/2000, for the adjustment of layers 1,2
SUM12=dzo(1)+dzo(2)
IF (SNOWDEPTH.le.0.06) THEN
DZ2=0.5*SUM12
ELSE IF (SNOWDEPTH.gt.0.06.and.SNOWDEPTH.le.0.08) THEN
DZ2=0.02
ELSE IF (SNOWDEPTH.gt.0.08.and.SNOWDEPTH.le.0.62) THEN
DZ2=0.33333333*SUM12
ELSE IF (SNOWDEPTH.gt.0.62) THEN
DZ2=0.20
ENDIF
! to get the expected change of middle layer of snow
DDZ2=DZ2-dzo(2)
! to get the expected change of middle layer of snow
IF (DDZ2.GT.0.0) THEN
CALL COMBO (DDZ2,dzo(2),dzo(1),wo(2),wo(1),ho(2),ho(1), &
tssno(2),tssno(1),bwo(2),bwo(1),bio(2),bio(1),blo(2),blo(1), &
bto(2),bto(1),fio(2),fio(1),flo(2),flo(1),cto(2),cto(1), &
dliqvol(2),dliqvol(1),dicevol(2),dicevol(1))
ELSE
DDZ2=-DDZ2
CALL COMBO (DDZ2,dzo(1),dzo(2),wo(1),wo(2),ho(1),ho(2), &
tssno(1),tssno(2),bwo(1),bwo(2),bio(1),bio(2),blo(1),blo(2), &
bto(1),bto(2),fio(1),fio(2),flo(1),flo(2),cto(1),cto(2), &
dliqvol(1),dliqvol(2),dicevol(1),dicevol(2))
END IF
SNOWDEPTH=dzo(1)+dzo(2)+dzo(3)
!
!------------------------------------------------------
END SUBROUTINE MODNODE
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE NEWSNOW(PRCP,BIFALL,BLFALL,FLFALL,TKAIR, & 1
DZO,WO,BWO,CTO,HO,DMLTO,FIO,FLO,BIO,BLO,DLIQVOL,DICEVOL,TSSNO,WF)
!
!=======================================================================
! ------------------------------------------------------------------7272
!! calculate rate of change in element thickness due to snow falling
!! Precip has just started or previous top node is full. Initiate a
!! new node.
!clwp 12/08/2000, since this subroutine only deals with the top layer,
!clwp change the original AA(n) to AA, in other words replace arrays.
! ------------------------------------------------------------------7272
dzfall=prcp*rhowater/bifall
dzo=dzo+dzfall
wo=wo+prcp
bwo=(wo*rhowater)/dzo
cto=1.9e+6*(bwo/920.0)
dum=(tkair-273.16)*cto*dzfall &
-(1.0-flfall)*(blfall+bifall)*dlm*dzfall
ho=ho+dum
dmlto=wo*rhowater*dlm
if (ho.ge.-dmlto) then
tssno=273.16
fio=-ho/dmlto
flo=1.0-fio
blo=bwo*flo
bio=bwo*fio
dliqvol=blo/rhowater
dicevol=bio/dice
else
!!!!! when snow temperature is below 273.16
fio=1.0
flo=0.0
bio=bwo
blo=0.0
dliqvol=0.0
dicevol=bio/dice
wf=0.0
tssno=(ho+dmlto)/(cto*dzo)+273.16
end if
!
!------------------------------------------------------
END SUBROUTINE NEWSNOW
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE NEWTON(A1,Y,FINC,NOX,NONPOS,IWOLK,L,ZINC,A2,Y1,ITER) 2
!
!=======================================================================
!
!-----------------------------------------------------------------------
! ** VERSION ACQUIRED FROM EROS 2/19/86.
!
! ** THE NEWTON RAPHSON ITERATIVE ROUTINE WILL BE USED TO GENERATE NEW
! ** VALUES OF A1 IF DABSOLUTE VALUE OF Y IS GREATER THAN ERTOL;
! ** A1 IS ESTIMATE, Y IS RESULTANT ERROR
! ** NEX IS EXIT CONDITION (0=NO EXIT) OR (1 WHEN DABS(Y) LT ERTOL)
! ** ERTOL IS THE DABSOLUTE VALUE OF Y NECESSARY TO OBTAIN AN EXIT
! ** FINC IS INITIAL INCREMENT SIZE FOR SECOND ESTIMATE OF A1
! ** NONPOS=0 IF QUANTITY TO BE MINIMIZED CAN BE LESS THAN ZERO;
! ** NONPOS=1 IF QUANTITY CAN ONLY BE POSITIVE
! ** L IDENTIFIES WHICH QUANTITY IS BEING CALCULATED.
!
! ** CONTROL VALUES: FINC,ERTOL,NOX,NONPOS,L:MUST BE SET BY USER
!-----------------------------------------------------------------------
!
!cfds Changes according to Jack (Feb/2008)
REAL, DIMENSION (3) :: IWALK, NEX, ITER
REAL, DIMENSION (3) :: ZINC, A2, Y1
!cfds DIMENSION IWALK(3), NEX(3)
!cfds DIMENSION ZINC(3), A2(3), Y1(3),ITER3(3)
DATA CONS/1.0/
!
ERTOL = 0.05 * FINC
IWALK(L) = IWOLK
NEX(L)=NOX
!
IF ( ITER(L) .GE. 490 ) GO TO 160
IF (ERTOL .LT. 0.00000001) ERTOL=0.000001
IF (ABS(Y) .LE. ERTOL) GO TO 150
IF((ABS(Y-Y1(L))).LE.0.01*ERTOL .AND. IWALK(L).EQ.0 ) GO TO 8
!
IF(ABS(Y1(L)).GT.ERTOL) GO TO 1
A2(L)=A1
A1=A1-Y
NEX(L)=0
Y1(L)=Y
ITER(L)=1
IF (IWALK(L) .EQ. 3) GO TO 101
IWALK(L)=0
GO TO 101
1 ITER(L)=ITER(L)+1
IF(ITER(L) .EQ. 10) IWALK(L)=1
IF(IWALK(L) .NE. 0) GO TO 2
IF(ABS(Y) .GT. ERTOL) GO TO 3
NEX(L)=1
GO TO 150
3 A=A1-Y*(A1-A2(L))/(Y-Y1(L))
IF(ABS(A-A1).GT.(10.0*FINC)) &
A=A1+10.0*FINC*SIGN(CONS,(A-A1))
A2(L)=A1
A1=A
Y1(L)=Y
GO TO 101
2 IF(IWALK(L).EQ.2)GO TO 4
IF(IWALK(L).EQ.3) GO TO 6
IF(SIGN(CONS,Y).EQ.SIGN(CONS,Y1(L))) GO TO 3
ZINC(L)=(A1-A2(L))/4.0
A1=A2(L)+ZINC(L)
IWALK(L)=2
NEX(L)=0
GO TO 101
4 IF(SIGN(CONS,Y) .EQ.SIGN(CONS,Y1(L))) GO TO 5
ZINC(L)=-ZINC(L)/4.0
A2(L)=A1
A1=A1+ZINC(L)
NEX(L)=0
Y1(L)=Y
GO TO 101
5 A2(L)=A1
A1=A1+ZINC(L)
Y1(L)=Y
NEX(L)=0
GO TO 101
6 IF(SIGN(CONS,Y).EQ.SIGN(CONS,Y1(L))) GO TO 7
IWALK(L)=1
GO TO 2
7 A2(L) = A1
A1 = A1+FINC
Y1(L)=Y
NEX(L) = 0
GO TO 101
8 A1 = A1 + FINC*2.0
NEX(L)=0
GO TO 101
160 CONTINUE
900 FORMAT ( 3X,' FAILURE TO CONVERGE AFTER 490 ITERATIONS', &
/, 3X,' Y = ',2G12.5,2X,I14)
150 NEX(L) = 1
ZINC(L)=0.0
ITER(L) = 0
IWALK(L)=0
Y1(L)=0.0
Y=0.0
A2(L)=0.0
101 CONTINUE
IF(NONPOS.EQ.1.AND.A1.LT.0.0) A1=A2(L)/2.0
NOX = NEX(L)
IWOLK = IWALK(L)
!
!------------------------------------------------------
END SUBROUTINE NEWTON
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE OLD(TSSN,BW,BL,BI,H,FL,FI,W,DZ,SS,CT,BT,DMLT, & 1
TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO,SSO,CTO,BTO,DMLTO)
!
!=======================================================================
DIMENSION TSSN(N1),BW(N1),BL(N1),BI(N1),H(N1),FL(N1),FI(N1), &
W(N1),DZ(N1),SS(N1),CT(N1),BT(N1),DMLT(N1), TSSNO(N1), &
BWO(N1),BLO(N1),BIO(N1),HO(N1),FLO(N1),FIO(N1), &
WO(N1),DZO(N1),SSO(N1),CTO(N1),BTO(N1),DMLTO(N1)
DO 20 I=1,N
TSSNO(I)=TSSN(I)
BWO(I)=BW(I)
BLO(I)=BL(I)
BIO(I)=BI(I)
HO(I)=H(I)
FLO(I)=FL(I)
FIO(I)=FI(I)
WO(I)=W(I)
DZO(I)=DZ(I)
SSO(I)=SS(I)
CTO(I)=CT(I)
BTO(I)=BT(I)
DMLTO(I)=DMLT(I)
20 CONTINUE
!
!------------------------------------------------------
END SUBROUTINE OLD
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE RADAB (TRAN,REF,GREEN,VCOVER,CHIL,ZLAI,Z2,Z1,SOREF,TC, & 1
TGS,SATCAP,EXTK,RADFAC,THERMK,RADT,PAR,PD,ALBEDO,SALB, &
TGEFF,SUNANG,XADJ,CAPAC,RADN,ZLWUP,FRAC, &
ISNOW,SNOWDEN,SNOWDEPTH,SWDOWN,XALBEDO,SCOV2,ISICE, &
fsdown,fldown,fsup,flup)
! 1 AUGUST 1988
!=======================================================================
!
! CALCULATION OF ALBEDOS VIA TWO STREAM APPROXIMATION( DIRECT
! AND DIFFUSE ) AND PARTITION OF RADIANT ENERGY
!
!cl CLOSS=2.*VCOVER(1)*(1.-THERMK)*STEFAN*TC**4
!cl -VCOVER(1)*(1.-THERMK)*STEFAN*TGS**4
!cl GLOSS=STEFAN*TGS**4 - VCOVER(1)*(1.-THERMK)*STEFAN*TC**4
!-----------------------------------------------------------------------
DIMENSION TRANC1(2), TRANC2(2), TRANC3(2)
DIMENSION CAPAC(2), SATCAP(2), TRAN(2,3,2), REF(2,3,2), SOREF(3)
DIMENSION GREEN(2), VCOVER(2), ZLAI(2), CHIL(2), RADN(3,2),RADT(2)
DIMENSION RADFAC(2,2,2), RADSAV(12), PAR(2), PD(2), ALBEDO(2,3,2)
DIMENSION SALB(2,2), EXTK(2,3,2), FRAC(2,2)
DIMENSION sr(2)
data sr/0.85,0.65/
! dimension sibalbedo(12,31,24),sibswup(12,31,24)
!
!crr F = SUNANG
f=max(sunang,0.01746)
!crr ratko, 08/03/2004
!crr xref1=1.20
!crr xref2=0.40
xref1=1.05
xref2=0.20
!
!----------------------------------------------------------------------
! CALCULATION OF MAXIMUM WATER STORAGE VALUES.
!----------------------------------------------------------------------
!
FMELT = 1.
IF ( ABS(TF-TGS) .LT. 0.5 ) FMELT = 0.6
SATCAP(1) = ZLAI(1) * 0.0001
SATCAP(2) = ZLAI(2) * 0.0001
!CS------------------------- Sun change following DEPCOV 10/13/98
IF (ISNOW.eq.0) THEN
DEPCOV = AMAX1( 0., (SNOWDEPTH-Z1))
ELSE
DEPCOV = AMAX1( 0., (CAPAC(2)*SNOWDEN-Z1))
END IF
!CS-----------------------------------------------------------10/13/98
DEPCOV = AMIN1( DEPCOV, (Z2-Z1)*0.95 )
SATCAP(1) = SATCAP(1) * ( 1. - DEPCOV / ( Z2 - Z1 ) )
!crr - thermal part is in use in temrs1 & temrs2
do 202 iveg = 1, 2
do 202 iwave = 1, 3
do 202 irad = 1, 2
albedo(iveg,iwave,irad)=0.
202 continue
!crr
!----------------------------------------------------------------------
!
DO 1000 IWAVE = 1, 2
!
DO 2000 IVEG = 2, 1,-1
!----------------------------------------------------------------------
! MODIFICATION FOR EFFECT OF SNOW ON UPPER STOREY ALBEDO
! SNOW REFLECTANCE = 0.80, 0.40 . MULTIPLY BY 0.6 IF MELTING
! SNOW TRANSMITTANCE = 0.20, 0.54
!crr snow reflectance now 0.85, 0.65 (see xref1, xref2)
!
!----------------------------------------------------------------------
SCOV = 0.
IF( IVEG .EQ. 2 ) GO TO 100
IF( TC .LE. TF ) SCOV = AMIN1( 0.5, CAPAC(1) / SATCAP(1) )
100 CONTINUE
REFF1 = ( 1. - SCOV ) * REF(IVEG,IWAVE,1) + SCOV * ( xref1 - &
IWAVE * xref2 ) * FMELT
REFF2 = ( 1. - SCOV ) * REF(IVEG,IWAVE,2) + SCOV * ( xref1 - &
IWAVE * xref2 ) * FMELT
TRAN1 = TRAN(IVEG,IWAVE,1) * ( 1. - SCOV ) &
+ SCOV * ( 1.- ( xref1 - IWAVE * xref2 ) * FMELT ) &
* TRAN(IVEG,IWAVE,1)
TRAN2 = TRAN(IVEG,IWAVE,2) * ( 1. - SCOV ) &
+ SCOV * ( 1.- ( xref1 - IWAVE * xref2 ) * FMELT ) * 0.9 &
* TRAN(IVEG,IWAVE,2)
!
!----------------------------------------------------------------------
!
SCAT = GREEN(IVEG)*( TRAN1 + REFF1 ) +( 1. - GREEN(IVEG) ) * &
( TRAN2 + REFF2)
CHIV = CHIL(IVEG)
!
IF ( ABS(CHIV) .LE. 0.01 ) CHIV = 0.01
AA = 0.5 - 0.633 * CHIV - 0.33 * CHIV * CHIV
BB = 0.877 * ( 1. - 2. * AA )
!
PROJ = AA + BB * F
EXTKB = ( AA + BB * F ) / F
ZMEW = 1. / BB * ( 1. - AA / BB * ALOG ( ( AA + BB ) / AA ) )
ACSS = SCAT / 2. * PROJ / ( PROJ + F * BB )
ACSS = ACSS * ( 1. - F * AA / ( PROJ + F * BB ) * ALOG ( ( PROJ &
+ F * BB + F * AA ) / ( F * AA ) ) )
!
EXTK( IVEG, IWAVE, 1 ) = PROJ / F * SQRT( 1.-SCAT )
EXTK( IVEG, IWAVE, 2 ) = 1. / ZMEW * SQRT( 1.-SCAT )
EXTK( IVEG, 3, 1 ) = AA + BB
EXTK( IVEG, 3, 2 ) = 1./ZMEW
!
UPSCAT = GREEN(IVEG) * TRAN1 + ( 1. - GREEN(IVEG) ) * TRAN2
UPSCAT = 0.5 * ( SCAT + ( SCAT - 2. * UPSCAT ) * &
(( 1. - CHIV ) / 2. ) ** 2 )
!
BETAO = ( 1. + ZMEW * EXTKB ) / ( SCAT * ZMEW * EXTKB ) * ACSS
!
!----------------------------------------------------------------------
!
! DICKINSON'S VALUES
!
BE = 1. - SCAT + UPSCAT
CE = UPSCAT
BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
IF ( ABS(BOT) .GT. 1.E-10) GO TO 200
SCAT = SCAT* 0.98
BE = 1. - SCAT + UPSCAT
BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
200 CONTINUE
DE = SCAT * ZMEW * EXTKB * BETAO
FE = SCAT * ZMEW * EXTKB * ( 1. - BETAO )
!----------------------------------------------------------------------
!
CCE = DE * BE - ZMEW * DE * EXTKB + CE * FE
FFE = BE * FE + ZMEW * FE * EXTKB + CE * DE
!
TORE = -CCE / BOT
SIGE = -FFE / BOT
!
PSI = SQRT(BE**2 - CE**2)/ZMEW
!
!----------------------------------------------------------------------
! REDUCTION IN EXPOSED HEIGHT OF UPPER STOREY AS SNOW ACCUMULATES
!
!CS Sun Change following SDEP to SDEP=snowdepth on 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
SDEP=SNOWDEPTH
ELSE
SDEP = CAPAC(2) *SNOWDEN
END IF
!CS
FAC = ( SDEP - Z1 ) / ( Z2 - Z1 )
FAC = AMAX1( 0., FAC )
FAC = AMIN1( 0.99, FAC )
!
ZAT = ZLAI(IVEG) / VCOVER(IVEG)
IF ( IVEG .EQ. 1 ) ZAT = ZAT * (1.-FAC)
!
POWER1 = AMIN1( PSI*ZAT, 50. )
POWER2 = AMIN1( EXTKB*ZAT, 50. )
EPSI = EXP( - POWER1 )
EK = EXP ( - POWER2 )
!
ROSB = SOREF(IWAVE)
ROSD = SOREF(IWAVE)
IF ( IVEG .EQ. 2 ) GO TO 300
ROSB = ALBEDO(2,IWAVE,1)
ROSD = ALBEDO(2,IWAVE,2)
300 CONTINUE
!
GE = ROSB / ROSD
!
!-----------------------------------------------------------------------
! CALCULATION OF DIFFUSE ALBEDOS
!-----------------------------------------------------------------------
!
F1 = BE - CE / ROSD
ZP = ZMEW * PSI
!
DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
( BE - ZP ) * ( F1 + ZP ) * EPSI
ALPHA = CE * ( F1 - ZP ) / EPSI / DEN
BETA = -CE * ( F1 + ZP ) * EPSI / DEN
F1 = BE - CE * ROSD
DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
!
GAMMA = ( F1 + ZP ) / EPSI / DEN
DELTA = - ( F1 - ZP ) * EPSI / DEN
!
ALBEDO(IVEG,IWAVE,2) = ALPHA + BETA
! XQQ(IVEG,IWAVE,2) = ALBEDO(IVEG, IWAVE, 2)
!
IF ( IVEG .EQ. 1 ) GO TO 400
SCOV2 = 0.
IF ( TGS .LE. TF ) SCOV2 = AMIN1( 1., CAPAC(2) / 0.004 )
!crr CORRECTION FOR KEEPING ALBEDO HIGH OVER SNOW
IF (ISICE.EQ.1) SCOV2=1.
!crr
ALBEDO(2,IWAVE,2) = &
ROSD * ( 1. - VCOVER(2) ) + ALBEDO(2,IWAVE,2) * VCOVER(2)
ALBEDO(2,IWAVE,2) = &
( 1. - SCOV2 ) * ALBEDO(2,IWAVE,2) + SCOV2 * &
( xref1-IWAVE*xref2 ) * &
FMELT
400 CONTINUE
!
TRANC2(IWAVE) = GAMMA * EPSI + DELTA / EPSI
!
!-----------------------------------------------------------------------
! CALCULATION OF DIRECT ALBEDOS
!-----------------------------------------------------------------------
!
F1 = BE - CE / ROSD
ZMK = ZMEW * EXTKB
!
DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
( BE - ZP ) * ( F1 + ZP ) * EPSI
ALPHA = ( DE - TORE * ( BE + ZMK ) ) * ( F1 - ZP ) / EPSI - &
( BE - ZP ) * ( DE - CE*GE - TORE * ( F1 + ZMK ) ) * EK
ALPHA = ALPHA / DEN
BETA = ( BE + ZP ) * (DE - CE*GE - TORE * ( F1 + ZMK ))* EK - &
( DE - TORE * ( BE + ZMK ) ) * ( F1 + ZP ) * EPSI
BETA = BETA / DEN
F1 = BE - CE * ROSD
DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
GAMMA = - SIGE * ( F1 + ZP ) / EPSI - &
( FE + CE * GE * ROSD + SIGE * ( ZMK - F1 ) ) * EK
GAMMA = GAMMA / DEN
DELTA = ( CE * GE * ROSD + FE + SIGE * ( ZMK - F1 ) ) * EK &
+ SIGE * ( F1 - ZP ) * EPSI
DELTA = DELTA / DEN
!
ALBEDO(IVEG,IWAVE,1) = TORE + ALPHA + BETA
! XQQ(IVEG,IWAVE,1) = ALBEDO(IVEG, IWAVE, 1)
!----------------------------------------------------------------------
!
IF( IVEG .EQ. 1 ) GO TO 500
ALBEDO(2,IWAVE,1) = ROSB * ( 1. - VCOVER(2) ) &
+ ALBEDO(2,IWAVE,1) * VCOVER(2)
ALBEDO(2,IWAVE,1) = ( 1. - SCOV2 ) * ALBEDO(2,IWAVE,1) + &
SCOV2 * ( xref1-IWAVE*xref2 ) * FMELT
!
500 CONTINUE
!
TRANC1(IWAVE) = EK
TRANC3(IWAVE) = SIGE * EK + GAMMA * EPSI + DELTA / EPSI
!
2000 CONTINUE
!----------------------------------------------------------------------
! CALCULATION OF TERMS WHICH MULTIPLY INCOMING SHORT WAVE FLUXES
! TO GIVE ABSORPTION OF RADIATION BY CANOPY AND GROUND
!----------------------------------------------------------------------
!
RADFAC(2,IWAVE,1) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,1) ) &
+ VCOVER(1) * ( TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
+ TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
!
RADFAC(2,IWAVE,2) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,2) ) &
+ VCOVER(1) * TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) )
!
RADFAC(1,IWAVE,1) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,1) ) &
- TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
- TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
!
RADFAC(1,IWAVE,2) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,2) ) &
- TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
!
! XQQ(1,IWAVE,1) = RADFAC(1,IWAVE,1)
! XQQ(1,IWAVE,2) = RADFAC(1,IWAVE,2)
! XQQ(2,IWAVE,1) = RADFAC(2,IWAVE,1)
! XQQ(2,IWAVE,2) = RADFAC(2,IWAVE,2)
!----------------------------------------------------------------------
! CALCULATION OF TOTAL SURFACE ALBEDOS ( SALB )
!----------------------------------------------------------------------
!
DO 3000 IRAD = 1, 2
SALB(IWAVE,IRAD) = ( 1.-VCOVER(1) ) * ALBEDO(2,IWAVE,IRAD) + &
VCOVER(1) * ALBEDO(1,IWAVE,IRAD)
3000 CONTINUE
!----------------------------------------------------------------------
! SAVING OF EXTINCTION COEFFICIENTS ( PAR ) FOR STOMAT CALCULATION
!----------------------------------------------------------------------
IF ( IWAVE .EQ. 2 ) GO TO 600
RADSAV(1) = 1. - VCOVER(1) &
+ VCOVER(1) * ( TRANC1(IWAVE) + TRANC3(IWAVE) )
RADSAV(2) = 1. - VCOVER(1) + VCOVER(1) * TRANC2(IWAVE)
! XQQ(1,1,1) = RADSAV(1)
! XQQ(1,2,1) = RADSAV(2)
600 CONTINUE
!
1000 CONTINUE
!
! albedo adjustment ==============================================
if (xadj.eq.0.) go to 730
xx = radfac(1,1,2) + radsav(2)
xy = radfac(1,1,1) + radsav(1)
ssum = salb(1,1)*frac(1,1) + salb(1,2)*frac(1,2)+ &
salb(2,1)*frac(2,1) + salb(2,2)*frac(2,2)
! for diffuse albedo
do 650 iwave = 1, 2
salb(iwave,2) = salb(iwave,2) + xadj * salb(iwave,2) / ssum
x0 = 1. - salb(iwave,2)
x1 = radfac(1,iwave,2) + radfac(2,iwave,2)
x2 = radfac(1,iwave,2) / x1
x3 = radfac(2,iwave,2) / x1
radfac(1,iwave,2) = x0 * x2
radfac(2,iwave,2) = x0 * x3
650 continue
640 format(1x,'unrealistic value, dif',2i12,4e11.4)
! for direct albedo
do 750 iwave = 1, 2
salb(iwave,1) = salb(iwave,1) + xadj * salb(iwave,1) / ssum
x0 = 1. - salb(iwave,1)
x1 = radfac(1,iwave,1) + radfac(2,iwave,1)
x2 = radfac(1,iwave,1) / x1
x3 = radfac(2,iwave,1) / x1
radfac(1,iwave,1) = x0 * x2
radfac(2,iwave,1) = x0 * x3
radsav(1) = xy - radfac(1,1,1)
radsav(2) = xx - radfac(1,1,2)
750 continue
740 format(1x,'unrealistic value',2i12,4e11.4)
730 continue
!--------------- end adjustment ------------------------------
!cl 2001,1,26 remove the following lines
! sibswup(nmm,ndd,nhh) = radn(1,1)*salb(1,1) + radn(1,2)*salb(1,2)
! & + radn(2,1)*salb(2,1) + radn(2,2)*salb(2,2)
! if ((swdown.gt.0.1).and.(sibswup(nmm,ndd,nhh).gt.0.1)) then
! sibalbedo(nmm,ndd,nhh) = sibswup(nmm,ndd,nhh) / swdown
! if (sibalbedo(nmm,ndd,nhh).gt.1.) then
! sibswup(nmm,ndd,nhh) = 0.
! sibalbedo(nmm,ndd,nhh) = 999.
! write (6, *) 'albebo incorrect',nymdh,sibalbedo(nmm,ndd,nhh)
! endif
! else
! sibswup(nmm,ndd,nhh) = 0.0
! sibalbedo(nmm,ndd,nhh) = 999.
! endif
swup = radn(1,1)*salb(1,1) + radn(1,2)*salb(1,2) &
+ radn(2,1)*salb(2,1) + radn(2,2)*salb(2,2)
if ((swdown.gt.0.01).and.(swup.gt.0.01)) then
xalbedo = swup / swdown
if (xalbedo.gt.1.) then
swup = 0.
xalbedo = 999.
write (6, *) 'albebo incorrect',xalbedo
endif
else
swup = 0.0
xalbedo = .1
endif
!----------------------------------------------------------------------
! CALCULATION OF LONG-WAVE FLUX TERMS FROM CANOPY AND GROUND
!----------------------------------------------------------------------
!
TC4 = TC * TC * TC * TC
TG4 = TGS * TGS * TGS * TGS
!
ZKAT = EXTK(1,3,2) * ZLAI(1) / VCOVER(1)
ZKAT = AMIN1( 50. , ZKAT )
ZKAT = AMAX1( 1.E-5, ZKAT )
THERMK = EXP(-ZKAT)
!
FAC1 = VCOVER(1) * ( 1.-THERMK )
FAC2 = 1.
CLOSS = 2. * FAC1 * STEFAN * TC4
CLOSS = CLOSS - FAC2 * FAC1 * STEFAN * TG4
GLOSS = FAC2 * STEFAN * TG4
GLOSS = GLOSS - FAC1 * FAC2 * STEFAN * TC4
!
ZLWUP = FAC1 * STEFAN * TC4 + (1. - FAC1 ) * FAC2 * STEFAN * TG4
TGEFF = SQRT( SQRT ( ( ZLWUP / STEFAN ) ) )
!
RADSAV(3) = EXTK(1,1,1)
RADSAV(4) = EXTK(1,1,2)
RADSAV(5) = EXTK(2,1,1)
RADSAV(6) = EXTK(2,1,2)
RADSAV(7) = THERMK
RADSAV(8) = EXTK(1,3,1)
RADSAV(9) = EXTK(2,3,1)
RADSAV(10)= CLOSS
RADSAV(11)= GLOSS
RADSAV(12)= TGEFF
!-----------------------------------------------------------------------
!
!cl CALL LONGRN( TRANC1, TRANC2, TRANC3)
!-----------------------------------------------------------------------
!
!cl CALL RADUSE
!---------------------------- subroutine RADUSE -----------------------
!
! CALCULATION OF ABSORPTION OF RADIATION BY SURFACE
!-----------------------------------------------------------------------
P1F = RADSAV(1)
P2F = RADSAV(2)
!cl 2001,1,26, redundant to the above lines
!cl EXTK(1,1,1) = RADSAV(3)
! EXTK(1,1,2) = RADSAV(4)
! EXTK(2,1,1) = RADSAV(5)
! EXTK(2,1,2) = RADSAV(6)
! THERMK = RADSAV(7)
! EXTK(1,3,1) = RADSAV(8)
! EXTK(2,3,1) = RADSAV(9)
! CLOSS = RADSAV(10)
! GLOSS = RADSAV(11)
!cl TGEFF = RADSAV(12)
!----------------------------------------------------------------------
!
! SUMMATION OF SHORT-WAVE RADIATION ABSORBED BY CANOPY AND GROUND
!----------------------------------------------------------------------
RADT(1) = 0.
RADT(2) = 0.
!
DO 7000 IVEG = 1, 2
DO 7000 IWAVE = 1, 2
DO 7000 IRAD = 1, 2
!
RADT(IVEG) = RADT(IVEG)+RADFAC(IVEG,IWAVE,IRAD)*RADN(IWAVE,IRAD)
!
7000 CONTINUE
!=========================================================================
fsdown = radn(1,1)+radn(1,2)+radn(2,1)+radn(2,2)
fsup = fsdown-radt(1)-radt(2)
!=========================================================================
!
SWCAN=RADT(1)
SWGND=RADT(2)
RADT(1) = RADT(1) + RADN(3,2)*VCOVER(1)*(1.- THERMK) &
- CLOSS
RADT(2) = RADT(2) + RADN(3,2)*( 1.-VCOVER(1)*(1-THERMK) ) &
- GLOSS
!=========================================================================
fldown = radn(3,2)
flup = closs+gloss
!=========================================================================
!
PAR(1) = RADN(1,1) + RADN(1,2) + 0.001
PD(1) = ( RADN(1,1) + 0.001 ) / PAR(1)
P1 = P1F * RADN(1,1) + 0.001
P2 = P2F * RADN(1,2)
PAR(2) = P1 + P2
PD(2) = P1 / PAR(2)
!
!------------------------------------------------------
END SUBROUTINE RADAB
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE RADAB_ICE(TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF, & 1
TC,TGS,SATCAP,EXTK,CLOSS,GLOSS,THERMK,P1F,P2F, &
RADT,PAR,PD,SALB,ALBEDO,TGEFF,SUNANG,XADJ,CAPAC, &
RADN,bedo,ZLWUP,RADFRAC,SWDOWN,SCOV2,ISICE, &
fsdown,fldown,fsup,flup)
! 11 AUGUST 2000
!=======================================================================
!
! CALCULATION OF ALBEDOS VIA TWO STREAM APPROXIMATION( DIRECT
! AND DIFFUSE ) AND PARTITION OF RADIANT ENERGY
!
!-----------------------------------------------------------------------
!----------------------------------------------------------------------
REAL, DIMENSION (2) :: TRANC1, TRANC2, TRANC3, CAPAC, SATCAP, &
GREEN, VCOVER, ZLT, CHIL, RADT, PAR, PD
REAL, DIMENSION (3) :: SOREF
REAL, DIMENSION (2,2) :: RADFRAC, SALB
REAL, DIMENSION (3,2) :: RADN
REAL, DIMENSION (2,2,2) :: RADFAC
REAL, DIMENSION (2,3,2) :: TRAN, REF, ALBEDO, EXTK
REAL, DIMENSION (12) :: RADSAV
!
f=max(sunang,0.01746)
!
!----------------------------------------------------------------------
! CALCULATION OF MAXIMUM WATER STORAGE VALUES.
!----------------------------------------------------------------------
!
FMELT = 1.
IF ( ABS(TF-TGS) .LT. 0.5 ) FMELT = 0.6
SATCAP(1) = ZLT(1) * 0.0001
SATCAP(2) = ZLT(2) * 0.0001
DEPCOV = AMAX1( 0., (CAPAC(2)*5.-Z1) )
DEPCOV = AMIN1( DEPCOV, (Z2-Z1)*0.95 )
SATCAP(1) = SATCAP(1) * ( 1. - DEPCOV / ( Z2 - Z1 ) )
!----------------------------------------------------------------------
do 202 iveg = 1, 2
do 202 iwave = 1, 3
do 202 irad = 1, 2
albedo(iveg,iwave,irad)=0.
202 continue
!----------------------------------------------------------------------
DO 1000 IWAVE = 1,2
!
DO 2000 IVDUM = 1,2
IF ( IVDUM .EQ. 1 ) IVEG = 2
IF ( IVDUM .EQ. 2 ) IVEG = 1
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! MODIFICATION FOR EFFECT OF SNOW ON UPPER STOREY ALBEDO
! SNOW REFLECTANCE = 0.80, 0.40 . MULTIPLY BY 0.6 IF MELTING
! SNOW TRANSMITTANCE = 0.20, 0.54
! SNOW REFLECTANCE = 0.85, 0.65 . MULTIPLY BY 0.6 IF MELTING
!
!----------------------------------------------------------------------
SCOV = 0.
IF( IVEG .EQ. 2 ) GO TO 100
IF( TC .LE. TF ) SCOV = AMIN1( 0.5, CAPAC(1) / SATCAP(1) )
100 CONTINUE
REFF1 = ( 1. - SCOV ) * REF(IVEG,IWAVE,1) + SCOV * ( 1.2 - &
IWAVE * 0.4 ) * FMELT
REFF2 = ( 1. - SCOV ) * REF(IVEG,IWAVE,2) + SCOV * ( 1.2 - &
IWAVE * 0.4 ) * FMELT
TRAN1 = TRAN(IVEG,IWAVE,1) * ( 1. - SCOV ) &
+ SCOV * ( 1.- ( 1.2 - IWAVE * 0.4 ) * FMELT ) &
* TRAN(IVEG,IWAVE,1)
TRAN2 = TRAN(IVEG,IWAVE,2) * ( 1. - SCOV ) &
+ SCOV * ( 1.- ( 1.2 - IWAVE * 0.4 ) * FMELT ) * 0.9 &
* TRAN(IVEG,IWAVE,2)
!----------------------------------------------------------------------
!
SCAT = GREEN(IVEG)*( TRAN1 + REFF1 ) +( 1. - GREEN(IVEG) ) * &
( TRAN2 + REFF2)
CHIV = CHIL(IVEG)
!
IF ( ABS(CHIV) .LE. 0.01 ) CHIV = 0.01
AA = 0.5 - 0.633 * CHIV - 0.33 * CHIV * CHIV
BB = 0.877 * ( 1. - 2. * AA )
!
PROJ = AA + BB * F
EXTKB = ( AA + BB * F ) / F
ZMEW = 1. / BB * ( 1. - AA / BB * ALOG ( ( AA + BB ) / AA ) )
ACSS = SCAT / 2. * PROJ / ( PROJ + F * BB )
ACSS = ACSS * ( 1. - F * AA / ( PROJ + F * BB ) * ALOG ( ( PROJ &
+ F * BB + F * AA ) / ( F * AA ) ) )
!
EXTK( IVEG, IWAVE, 1 ) = PROJ / F * SQRT( 1.-SCAT )
EXTK( IVEG, IWAVE, 2 ) = 1. / ZMEW * SQRT( 1.-SCAT )
EXTK( IVEG, 3, 1 ) = AA + BB
EXTK( IVEG, 3, 2 ) = 1./ZMEW
!
UPSCAT = GREEN(IVEG) * TRAN1 + ( 1. - GREEN(IVEG) ) * TRAN2
UPSCAT = 0.5 * ( SCAT + ( SCAT - 2. * UPSCAT ) * &
(( 1. - CHIV ) / 2. ) ** 2 )
!
BETAO = ( 1. + ZMEW * EXTKB ) / ( SCAT * ZMEW * EXTKB ) * ACSS
!
!----------------------------------------------------------------------
!
! DICKINSON'S VALUES
!
BE = 1. - SCAT + UPSCAT
CE = UPSCAT
BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
IF ( ABS(BOT) .GT. 1.E-10) GO TO 200
SCAT = SCAT* 0.98
BE = 1. - SCAT + UPSCAT
BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
200 CONTINUE
DE = SCAT * ZMEW * EXTKB * BETAO
FE = SCAT * ZMEW * EXTKB * ( 1. - BETAO )
!----------------------------------------------------------------------
!
CCE = DE * BE - ZMEW * DE * EXTKB + CE * FE
FFE = BE * FE + ZMEW * FE * EXTKB + CE * DE
!
TORE = -CCE / BOT
SIGE = -FFE / BOT
!
PSI = SQRT(BE**2 - CE**2)/ZMEW
!
!----------------------------------------------------------------------
! REDUCTION IN EXPOSED HEIGHT OF UPPER STOREY AS SNOW ACCUMULATES
!
SDEP = CAPAC(2) * 5.
FAC = ( SDEP - Z1 ) / ( Z2 - Z1 )
FAC = AMAX1( 0., FAC )
FAC = AMIN1( 0.99, FAC )
!
ZAT = ZLT(IVEG) / VCOVER(IVEG)
IF ( IVEG .EQ. 1 ) ZAT = ZAT * (1.-FAC)
!
POWER1 = AMIN1( PSI*ZAT, 50. )
POWER2 = AMIN1( EXTKB*ZAT, 50. )
EPSI = EXP( - POWER1 )
EK = EXP ( - POWER2 )
!
ROSB = SOREF(IWAVE)
ROSD = SOREF(IWAVE)
IF ( IVEG .EQ. 2 ) GO TO 300
ROSB = ALBEDO(2,IWAVE,1)
ROSD = ALBEDO(2,IWAVE,2)
300 CONTINUE
!
GE = ROSB / ROSD
!
!-----------------------------------------------------------------------
! CALCULATION OF DIFFUSE ALBEDOS
!-----------------------------------------------------------------------
!
F1 = BE - CE / ROSD
ZP = ZMEW * PSI
!
DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
( BE - ZP ) * ( F1 + ZP ) * EPSI
ALPHA = CE * ( F1 - ZP ) / EPSI / DEN
BETA = -CE * ( F1 + ZP ) * EPSI / DEN
F1 = BE - CE * ROSD
DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
!
GAMMA = ( F1 + ZP ) / EPSI / DEN
DELTA = - ( F1 - ZP ) * EPSI / DEN
!
ALBEDO(IVEG,IWAVE,2) = ALPHA + BETA
!
IF ( IVEG .EQ. 1 ) GO TO 400
SCOV2 = 0.
!crr CORRECTION FOR KEEPING ALBEDO HIGH OVER SNOW
IF (ISICE.EQ.1) SCOV2=1.
!
IF ( TGS .LE. TF ) SCOV2 = AMIN1( 1., CAPAC(2) / 0.004 )
ALBEDO(2,IWAVE,2)= ROSD * ( 1. - VCOVER(2) ) + ALBEDO(2,IWAVE,2) * VCOVER(2)
ALBEDO(2,IWAVE,2) = &
( 1. - SCOV2 ) * ALBEDO(2,IWAVE,2) + SCOV2 * &
( 1.2-IWAVE*0.4 ) * FMELT
400 CONTINUE
!
TRANC2(IWAVE) = GAMMA * EPSI + DELTA / EPSI
!
!-----------------------------------------------------------------------
! CALCULATION OF DIRECT ALBEDOS
!-----------------------------------------------------------------------
!
F1 = BE - CE / ROSD
ZMK = ZMEW * EXTKB
!
DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
( BE - ZP ) * ( F1 + ZP ) * EPSI
ALPHA = ( DE - TORE * ( BE + ZMK ) ) * ( F1 - ZP ) / EPSI - &
( BE - ZP ) * ( DE - CE*GE - TORE * ( F1 + ZMK ) ) * EK
ALPHA = ALPHA / DEN
BETA = ( BE + ZP ) * (DE - CE*GE - TORE * ( F1 + ZMK ))* EK - &
( DE - TORE * ( BE + ZMK ) ) * ( F1 + ZP ) * EPSI
BETA = BETA / DEN
F1 = BE - CE * ROSD
DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
GAMMA = - SIGE * ( F1 + ZP ) / EPSI - &
( FE + CE * GE * ROSD + SIGE * ( ZMK - F1 ) ) * EK
GAMMA = GAMMA / DEN
DELTA = ( CE * GE * ROSD + FE + SIGE * ( ZMK - F1 ) ) * EK &
+ SIGE * ( F1 - ZP ) * EPSI
DELTA = DELTA / DEN
!
ALBEDO(IVEG,IWAVE,1) = TORE + ALPHA + BETA
!
!----------------------------------------------------------------------
!
IF( IVEG .EQ. 1 ) GO TO 500
ALBEDO(2,IWAVE,1) = ROSB * ( 1. - VCOVER(2) ) &
+ ALBEDO(2,IWAVE,1) * VCOVER(2)
ALBEDO(2,IWAVE,1) = ( 1. - SCOV2 ) * ALBEDO(2,IWAVE,1) + &
SCOV2 * ( 1.2-IWAVE*0.4 ) * FMELT
!
500 CONTINUE
!
TRANC1(IWAVE) = EK
TRANC3(IWAVE) = SIGE * EK + GAMMA * EPSI + DELTA / EPSI
!
2000 CONTINUE
!
!----------------------------------------------------------------------
! CALCULATION OF TERMS WHICH MULTIPLY INCOMING SHORT WAVE FLUXES
! TO GIVE ABSORPTION OF RADIATION BY CANOPY AND GROUND
!----------------------------------------------------------------------
!
RADFAC(2,IWAVE,1) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,1) ) &
+ VCOVER(1) * ( TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
+ TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
!
RADFAC(2,IWAVE,2) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,2) ) &
+ VCOVER(1) * TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) )
!
RADFAC(1,IWAVE,1) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,1) ) &
- TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
- TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
!
RADFAC(1,IWAVE,2) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,2) ) &
- TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
!
! XQQ(1,IWAVE,1) = RADFAC(1,IWAVE,1)
! XQQ(1,IWAVE,2) = RADFAC(1,IWAVE,2)
! XQQ(2,IWAVE,1) = RADFAC(2,IWAVE,1)
! XQQ(2,IWAVE,2) = RADFAC(2,IWAVE,2)
!
!----------------------------------------------------------------------
! CALCULATION OF TOTAL SURFACE ALBEDOS ( SALB )
!
DO 3000 IRAD = 1, 2
SALB(IWAVE,IRAD) = ( 1.-VCOVER(1) ) * ALBEDO(2,IWAVE,IRAD) + &
VCOVER(1) * ALBEDO(1,IWAVE,IRAD)
3000 CONTINUE
!
!----------------------------------------------------------------------
! SAVING OF EXTINCTION COEFFICIENTS ( PAR ) FOR STOMAT CALCULATION
!----------------------------------------------------------------------
IF ( IWAVE .EQ. 2 ) GO TO 600
RADSAV(1) = 1. - VCOVER(1) &
+ VCOVER(1) * ( TRANC1(IWAVE) + TRANC3(IWAVE) )
RADSAV(2) = 1. - VCOVER(1) + VCOVER(1) * TRANC2(IWAVE)
600 CONTINUE
!
1000 CONTINUE
!
! albedo adjustment ==============================================
!
if (xadj.eq.0.) go to 730
xx = radfac(1,1,2) + radsav(2)
xy = radfac(1,1,1) + radsav(1)
ssum = salb(1,1)*radfrac(1,1) + salb(1,2)*radfrac(1,2)+ &
salb(2,1)*radfrac(2,1) + salb(2,2)*radfrac(2,2)
! for diffuse albedo
do 650 iwave = 1, 2
salb(iwave,2) = salb(iwave,2) + xadj * salb(iwave,2) / ssum
x0 = 1. - salb(iwave,2)
x1 = radfac(1,iwave,2) + radfac(2,iwave,2)
x2 = radfac(1,iwave,2) / x1
x3 = radfac(2,iwave,2) / x1
radfac(1,iwave,2) = x0 * x2
radfac(2,iwave,2) = x0 * x3
if (salb(iwave,2).gt.1..or.radfac(1,iwave,2).gt.1..or. &
radfac(2,iwave,2).gt.1..or.salb(iwave,2).lt.0..or. &
radfac(1,iwave,2).lt.0..or.radfac(2,iwave,2).lt.0.) then
stop 999
end if
650 continue
640 format(1x,'unrealistic value, dif',2i12,4e11.4)
! for direct albedo
do 750 iwave = 1, 2
salb(iwave,1) = salb(iwave,1) + xadj * salb(iwave,1) / ssum
x0 = 1. - salb(iwave,1)
x1 = radfac(1,iwave,1) + radfac(2,iwave,1)
x2 = radfac(1,iwave,1) / x1
x3 = radfac(2,iwave,1) / x1
radfac(1,iwave,1) = x0 * x2
radfac(2,iwave,1) = x0 * x3
radsav(1) = xy - radfac(1,1,1)
radsav(2) = xx - radfac(1,1,2)
if (salb(iwave,1).gt.1..or.radfac(1,iwave,1).gt.1..or. &
radfac(2,iwave,1).gt.1..or.salb(iwave,1).lt.0..or. &
radfac(1,iwave,1).lt.0..or.radfac(2,iwave,1).lt.0.) then
write(7,740) nymdh,iwave,salb(iwave,1),radfac(1,iwave,1), &
radfac(2,iwave,1)
stop 999
end if
750 continue
740 format(1x,'unrealistic value',2i12,4e11.4)
730 continue
!***************** end adjustment *******************************
sibsu = radn(1,1)*salb(1,1) + radn(1,2)*salb(1,2) &
+ radn(2,1)*salb(2,1) + radn(2,2)*salb(2,2)
if ((swdown.gt.0.01).and.(sibsu.gt.0.01)) then
bedo = sibsu / swdown
if (bedo.gt.1.) then
sibsu = 0.
bedo = .1
print*,'albebo incorrect',ii,jj,bedo,sibsu,swdown, &
radn(1,1),radn(1,2),radn(2,1),radn(2,2)
endif
else
sibsu = 0.0
bedo = .1
endif
!--------------------------------------------------------------------
! bedo = sibsu/swdown
! bedo = min(max(bedo,0.001),1.0)
!--------------------------------------------------------------------
!
! CALCULATION OF LONG-WAVE FLUX TERMS FROM CANOPY AND GROUND
!
!----------------------------------------------------------------------
!
TC4 = TC * TC * TC * TC
TG4 = TGS * TGS * TGS * TGS
!
ZKAT = EXTK(1,3,2) * ZLT(1) / VCOVER(1)
ZKAT = AMIN1( 50. , ZKAT )
ZKAT = AMAX1( 1.E-5, ZKAT )
THERMK = EXP(-ZKAT)
!
FAC1 = VCOVER(1) * ( 1.-THERMK )
FAC2 = 1.
CLOSS = 2. * FAC1 * STEFAN * TC4
CLOSS = CLOSS - FAC2 * FAC1 * STEFAN * TG4
GLOSS = FAC2 * STEFAN * TG4
GLOSS = GLOSS - FAC1 * FAC2 * STEFAN * TC4
!
ZLWUP = FAC1 * STEFAN * TC4 + (1. - FAC1 ) * FAC2 * STEFAN * TG4
TGEFF = SQRT( SQRT ( ( ZLWUP / STEFAN ) ) )
!
RADSAV(3) = EXTK(1,1,1)
RADSAV(4) = EXTK(1,1,2)
RADSAV(5) = EXTK(2,1,1)
RADSAV(6) = EXTK(2,1,2)
RADSAV(7) = THERMK
RADSAV(8) = EXTK(1,3,1)
RADSAV(9) = EXTK(2,3,1)
RADSAV(10)= CLOSS
RADSAV(11)= GLOSS
RADSAV(12)= TGEFF
!
!-----------------------------------------------------------------------
!
! CALCULATION OF ABSORPTION OF RADIATION BY SURFACE
!
!-----------------------------------------------------------------------
!
P1F = RADSAV(1)
P2F = RADSAV(2)
EXTK(1,1,1) = RADSAV(3)
EXTK(1,1,2) = RADSAV(4)
EXTK(2,1,1) = RADSAV(5)
EXTK(2,1,2) = RADSAV(6)
THERMK = RADSAV(7)
EXTK(1,3,1) = RADSAV(8)
EXTK(2,3,1) = RADSAV(9)
CLOSS = RADSAV(10)
GLOSS = RADSAV(11)
TGEFF = RADSAV(12)
!
!----------------------------------------------------------------------
! SUMMATION OF SHORT-WAVE RADIATION ABSORBED BY CANOPY AND GROUND
!----------------------------------------------------------------------
!
RADT(1) = 0.
RADT(2) = 0.
!
DO 7000 IVEG = 1, 2
DO 7000 IWAVE = 1, 2
DO 7000 IRAD = 1, 2
!
RADT(IVEG) = RADT(IVEG)+RADFAC(IVEG,IWAVE,IRAD)*RADN(IWAVE,IRAD)
!
7000 CONTINUE
!=========================================================================
fsdown = radn(1,1)+radn(1,2)+radn(2,1)+radn(2,2)
fsup = fsdown-radt(1)-radt(2)
!=========================================================================
!
SWCAN=RADT(1)
SWGND=RADT(2)
!
RADT(1) = RADT(1) + RADN(3,2)*VCOVER(1)*(1.- THERMK) &
- CLOSS
RADT(2) = RADT(2) + RADN(3,2)*( 1.-VCOVER(1)*(1-THERMK) ) &
- GLOSS
!=========================================================================
fldown = radn(3,2)
flup = closs+gloss
!=========================================================================
!
PAR(1) = RADN(1,1) + RADN(1,2) + 0.001
PD(1) = ( RADN(1,1) + 0.001 ) / PAR(1)
P1 = P1F * RADN(1,1) + 0.001
P2 = P2F * RADN(1,2)
PAR(2) = P1 + P2
PD(2) = P1 / PAR(2)
!
!------------------------------------------------------
END SUBROUTINE RADAB_ICE
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZZWIND,UMM1, & 4
RHOA,TMM,U2,USTAR,DRAG,TA,bps,rib,CU,CT,iii,jjj)
!cxx RHOA,TMM,U2,USTAR,DRAG,TA,bps0,bps1,rib,CU,CT)
! 2001,1,11
!=======================================================================
!
! CUU AND CTT ARE LINEAR (A SIMPLIFIED VERSION, XUE ET AL. 1991)
!
FS(X) = 66.85 * X
FT(X) = 0.904 * X
FV(X) = 0.315 * X
!
! CU AND CT ARE THE FRICTION AND HEAT TRANSFER COEFFICIENTS.
! CUN AND CTN ARE THE NEUTRAL FRICTION AND HEAT TRANSFER
! COEFFICIENTS.
!
G2= 0.75
G3= 0.75
Z22 = Z2
ZL = Z2 + 11.785 * Z0
!crr
ZWIND = ZZWIND
TM = TMM
UMM = UMM1
!cxx IF(ZWIND.LE.Z2) THEN
!cxx ZWIND=Z2+20.0 ! if trees are higher than model level
!cxx ! increase model level by 10m
!cxx TM = TMM - (ZWIND - ZZWIND)*0.0065 ! adjust temp (lin.)
!cxx UMM = UMM1 + USTAR/VKC * ALOG(ZWIND/ZZWIND) ! adjust wind (log.)
!cxx ENDIF
!------------------------------------------------------------------------
if(zwind.le.d.or.zl.le.d) d=min(zwind,zl)-0.1
!crr
Z2 = D + Z0
CUNI = ALOG((ZWIND-D)/Z0)/VKC
IF (ZL.LT.ZWIND) THEN
XCT1 = ALOG((ZWIND-D)/(ZL-D))
XCT2 = ALOG((ZL-D)/(Z2-D))
XCTU2 = ALOG((ZL-D)/(Z22-D))
CTNI = (XCT1 + G3 * XCT2) / VKC
ELSE
XCT2 = ALOG((ZWIND-D)/(Z2-D))
XCTU2 = ALOG((ZWIND-D)/(Z22-D))
CTNI = G3 * XCT2 /VKC
END IF
! --------------- NEUTRAL VALUES OF USTAR AND VENTMF ------------
!
UM=AMAX1(UMM,2.)
USTARN=UM/CUNI
VENTN =RHOA /CTNI*USTARN
IF (ZL.LT.ZWIND) THEN
U2 = UM - 1. / VKC * USTARN * (XCT1 + G2 * XCTU2)
ELSE
U2 = UM - 1. / VKC * USTARN * G2 * XCTU2
END IF
!crr
if(u2.lt.0.01) u2=0.01
!crr
!
! STABILITY BRANCH BASED ON BULK RICHARDSON NUMBER.
!
! THM=TM*bps1
! THVGM= TRIB*bps0-THM
THM=TM*bps !fds (06/2010)
THVGM=TRIB-THM
IF (TA.EQ.0.) THVGM = 0.
RIB = -THVGM*GRAV*(ZWIND-D) / (THM*(UM-U2)**2)
RIB = MAX(-10.E0,RIB)
RIB = MIN(0.1643E0,RIB)
!
! NON-NEUTRON CORRECTION (SEE XUE ET AL(1991))
IF(RIB.LT.0.0)THEN
GRIB = +RIB
GRZL = +RIB*(ZL-D)/(ZWIND-D)
GRZ2 = +RIB*(Z2-D)/(ZWIND-D)
FVV = FV(GRIB)
IF (ZL.LT.ZWIND) THEN
FTT = FT(GRIB) + (G3-1.) * FT(GRZL) - G3 * FT(GRZ2)
ELSE
FTT = G3*(FT(GRIB) - FT(GRZ2))
END IF
CUI = CUNI + FVV
CTI = CTNI + FTT
ELSE
RZL = RIB/(ZWIND-D)*(ZL-D)
RZ2 = RIB/(ZWIND-D)*(Z2-D)
FVV = FS(RIB)
IF (ZL.LT.ZWIND) THEN
FTT = FS(RIB) + (G3-1) * FS(RZL) - G3 * FS(RZ2)
ELSE
FTT = G3 * (FS(RIB) - FS(RZ2))
END IF
312 CUI = CUNI + FVV
CTI = CTNI + FTT
ENDIF
310 CONTINUE
!
CU=1./CUI
CT=1./CTI
USTAR =UM*CU
RAF = CTI / USTAR
IF (RAF.LT.0.80) RAF = 0.80
!
RA = RAF
!
UEST = USTAR
DRAG = RHOA * UEST*UEST
Z2 = Z22
!
!------------------------------------------------------
END SUBROUTINE RASIT5
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE SDSOL(DSOL,DMASS,N,SOLAR,SOLSOIL) 1
!
!=======================================================================
parameter(nd = 4)
!clwp 12/08/2000, to change nd=20 to nd=4 to keep consistent
!cl parameter(nd = 20)
integer n
real dsol(nd),dmass(nd),fext(nd)
!
gsize = 5.d-4
bext = 400.0
cv = 3.795d-3
depth = 30
do i=1,n
fext(i) = 0.0
enddo
!
tmass = 0.0
do 10 i=1,n
j=n+1-i
tmass=tmass+dmass(j)
if(tmass.gt.depth) goto 30
fext(j)=exp(-cv*dmass(j)/sqrt(gsize))
if(j .eq. n) fext(n)=exp(-bext*2d-3)*fext(n)
10 continue
30 tsolt = solar
do 20 i=1,n
j=n+1-i
if(tsolt .le. 0d0)then
dsol(j)=0d0
tsolb=0.0
else
tsolb=tsolt*fext(j)
dsol(j)=tsolt-tsolb
tsolt=tsolb
end if
20 continue
solsoil = tsolb
!
!------------------------------------------------------
END SUBROUTINE SDSOL
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE SET0(TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO, & 1
SSO,CTO,BTO,DMLTO,WF,DHP)
!
!=======================================================================
!cl
DIMENSION WF(N1),DHP(N1),TSSNO(N1),BWO(N1),BLO(N1),BIO(N1),HO(N1), &
FLO(N1),FIO(N1),WO(N1),DZO(N1),SSO(N1),CTO(N1),BTO(N1),DMLTO(N1)
!clwp do 100 i=n+1,nd
DO 100 I=N+1,N1
TSSNO(I)=0.0
BWO(I)=0.0
BLO(I)=0.0
BIO(I)=0.0
HO(I)=0.0
FLO(I)=0.0
FIO(I)=0.0
WO(I)=0.0
DZO(I)=0.0
SSO(I)=0.0
CTO(I)=0.0
BTO(I)=0.0
DMLTO(I)=0.0
100 CONTINUE
!clwp DO 200 I=1,Nd
DO 200 I=1,N1
WF(I)=0.0
DHP(I)=0.0
200 CONTINUE
!------------------------------------------------------
END SUBROUTINE SET0
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE SNOW_1ST (DTT,TM,SOLAR,PRCPW,PRCPS,BIO,BLO,DICEVOL, & 1,3
DLIQVOL,TSSNO,PDZDTC,POROSITY,SO,SSO,WF,DHP,DZO,WO, &
BWO,BTO,CTO,DMASS,DSOL,SNROFF,HROFF,SNOWDEPTH,SOLSOIL, &
FLO,FIO,DMLTO,HO,BIFALL,BLFALL,FLFALL)
!
!=======================================================================
!cl
DIMENSION BIO(N1),BLO(N1),DICEVOL(N1),DLIQVOL(N1),TSSNO(N1), &
PDZDTC(N1),POROSITY(N1),SO(N1),SSO(N1),WF(N1),DHP(N1), &
DZO(N1),WO(N1),BWO(N1),BTO(N1),CTO(N1),DMASS(N1), &
DSOL(N1),FLO(N1),FIO(N1),DMLTO(N1),HO(N1)
! ------------------------------------------------------------------7272
tkair = TM
prcp = prcpw+prcps
snroff = 0.0
hroff = 0.0
! dksatsnow=0.01
!....................... rain
if(prcpw.gt.0.0)then
wf(n+1)=amin1(prcpw, dksatsnow*dtt)
dhp(n+1)=(wf(n+1)/dtt)*cl*rhowater*(tkair-273.16)
snroff =snroff+(prcpw-wf(n+1))
hroff=hroff+(prcpw-wf(n+1))*cl*rhowater*(tkair-273.16)
else if(prcps.gt.0.0)then
!...................... snow, add new nodes
wf(n+1)=0.0
dhp(n+1)=0.0
!cl 12/08/2000, the following subroutine just deals with top snow layer.
CALL NEWSNOW(PRCP,BIFALL,BLFALL,FLFALL,TKAIR, &
DZO(N),WO(N),BWO(N),CTO(N),HO(N),DMLTO(N),FIO(N),FLO(N), &
BIO(N),BLO(N),DLIQVOL(N),DICEVOL(N),TSSNO(N),WF(N))
endif
!---------------------------------
! Compaction rate for snow
!---------------------------------
do 277 i=n,1,-1
dicevol(i) = bio(i)/dice
dliqvol(i) = blo(i)/rhowater
porosity(i)=1.0-dicevol(i)
porosity(i)=amin1(porosity(i),1.0)
porosity(i)=amax1(porosity(i),0.0)
so(i)=ssisnow
if(porosity(i).ne.0.0) so(i)=dliqvol(i)/porosity(i)
sso(i)=(so(i)-ssisnow)/(1.0-ssisnow)
277 continue
overburden=0.0
do 377 i=n,1,-1
overburden=overburden+ wo(i)*rhowater
call COMPACT(BIO(I),TSSNO(I),BLO(I),OVERBURDEN,PDZDTC(I), &
SSO(I),DICE)
377 continue
!
!---------------------------------------------**
! Calculate some variables after new snowfall
!---------------------------------------------**
do 390 i = 1,n
if((sso(i).lt.1.0.and.porosity(i).gt.0.0))then
dzot=dzo(i)*(1d0+pdzdtc(i)*dtt)
dzo(i)=amax1(dzot,dzmin)
!
if(wo(i).gt.womin)then
bwo(i)=(wo(i)*rhowater)/dzo(i)
if (bwo(i).gt.920.0) then
bwo(i)=920.0
dzo(i)=(wo(i)*rhowater)/bwo(i)
end if
endif
!
blo(i)=bwo(i)*flo(i)
bio(i)=bwo(i)*fio(i)
bto(i)=bwo(i)
end if
!
dicevol(i) = bio(i)/dice
dliqvol(i) = blo(i)/rhowater
dummy = dliqvol(i) + dicevol(i)
if(dummy.gt.1.0)then
dliqvol(i) = 1.0 - dicevol(i)
blo(i) = dliqvol(i)*rhowater
bwo(i) = blo(i) + bio(i)
dzo(i)=(wo(i)*rhowater)/bwo(i)
endif
cto(i)=(bwo(i)/920.0)*1.9e+6
!
porosity(i)=1.0-dicevol(i)
if(porosity(i) .gt. 1.0)porosity(i)=1.0
if(porosity(i) .lt. 0.0)porosity(i)=0.0
!
if(porosity(i).gt.0.0)then
so(i)=dliqvol(i)/porosity(i)
else
so(i)=ssisnow
endif
!
if(so(i).gt.ssisnow)then
sso(i)=(so(i)-ssisnow)/(1.0-ssisnow)
else
sso(i)=0.0
endif
!!!!!! dmass is for using to calculate dsol in sdsol.f
dmass(i)=bto(i)*dzo(i)
390 continue
SNOWDEPTH=dzo(1)+dzo(2)+dzo(3)
!---------------------------------------------
! Optical parameters and solar extinction
!---------------------------------------------
IF (solar .gt. 0d0 ) THEN
call sdsol(dsol,dmass,n,solar,solsoil)
ELSE
do 112 i=1,n
dsol(i)=0d0
112 continue
solsoil=0.0
END IF
!
!------------------------------------------------------
END SUBROUTINE SNOW_1ST
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE SNRESULT(DTT,I,ICASE,WFSOIL,TSOIL,B1,B2,FFF,DELTH,WWW, & 1,1
ZDEPTH,POROS,BI,BIO,DZ,DZO,W,BW,BWO,H,HO,QK,BL,BT,CT, &
FI,FL,WF,TSSN,DLIQVOL,DICEVOL,SNROFF,HROFF,QSOIL)
!
!=======================================================================
!cl
DIMENSION BIO(N1),DZO(N1),W(N1),BWO(N1),HO(N1), &
DZ(N1),BI(N1),BW(N1),BL(N1),BT(N1),CT(N1),FI(N1),FL(N1), &
WF(N1),H(N1),TSSN(N1),DLIQVOL(N1),DICEVOL(N1),QK(N1), &
WWW(3),ZDEPTH(3)
DIMENSION DELTH(20)
DATA BWE/200.0/
hx=0.0
IF (ICASE.EQ.1) THEN
fi(i)=1.0
fl(i)=0.0
dz(i)=dzo(i)
bw(i)=(w(i)*rhowater)/dz(i)
if((w(i)/dz(i)).lt.0.05.or.(w(i)/dz(i)) &
.gt.(dice/1000.0))then
bw(i) = bwo(i)
dz(i) = (w(i)*rhowater)/bw(i)
endif
bi(i)=bw(i)
bl(i)=0.0
bt(i)=bw(i)
wf(i)=0.0
if (i.eq.1) wfsoil=0.0
dliqvol(i)=0.0
dicevol(i)=bi(i)/dice
ct(i)=(bw(i)/920.0)*1.9e+6
if (i.eq.n) then
h(i)=ct(i)*dz(i)*(tssn(i)-273.16)-rhowater*dlm*w(n)*fi(n)
else
tssn(i) = ( ho(i) + ct(i)*dz(i)*273.16 + b1*dtt &
+ rhowater*dlm*w(i) ) &
/ ( ct(i)*dz(i) - b2*dtt )
h(i) = ho(i) + (b1+b2*tssn(i))*dtt
end if
if(tssn(i).gt.273.16) then
WRITE( message,* ) 'Warning: Snow Temp above freezing',i,tssn(i)
tssn(i)=273.16
CALL wrf_message ( message )
endif
! ------------------------------------------------------------------7272
ELSE IF (ICASE.EQ.2) THEN
! when snow temperature equals 273.16
fl(i)=1.0-fi(i)
tssn(i)=273.16
wf(i)=0.0
If(bwo(i).ge.bwe) Then
if(fl(i).gt.flmin)then
wf(i) = w(i)-(fi(i)/(1.0-flmin))*w(i)
w(i) = (fi(i)/(1.0-flmin))*w(i)
dum = wf(i)
fl(i)=flmin
fi(i)=1.0-fl(i)
endif
Else
!.................................................
flm = flmin+(flmax-flmin)*((bwe-bwo(i))/bwe)
if(fl(i).gt.flm)then
wf(i) = w(i)-(fi(i)/(1.0-flm))*w(i)
w(i) = (fi(i)/(1.0-flm))*w(i)
dum = wf(i)
fl(i)=flm
fi(i)=1.0-fl(i)
endif
Endif
!.................................................
If( wf(i).gt.0.0) Then
if(i.ne.1)then
wf(i)=amin1(dum, dksatsnow*dtt)
snroff = snroff + (dum - wf(i))
hroff=hroff+(dum-wf(i))*cl*rhowater*(tssn(i)-273.16)
else
!ctest2
if(www(1).ge.1.0) then
snroff = snroff + wf(i)
wfsoil=0.0
else
slwet=www(1)*poros*zdepth(1)
www(1)=(slwet+wf(i))/(poros*zdepth(1))
if(www(1).gt.1.0) then
snroff = snroff + (www(1)-1.0)*poros*zdepth(1)
www(1)=1.0
endif
wfsoil=0.0
endif
hroff=hroff + wf(i)*cl*rhowater*(tssn(i)-273.16)
endif
Endif
!cccccc next concerning compaction occurring during melt
xnodalmelt=bio(i)*dzo(i)-w(i)*rhowater*fi(i)
If(xnodalmelt.gt.0.0.and.bio(i)*dzo(i).gt.0.0 &
.and.(bio(i).lt.250.0.or.(i.eq.n.and. &
bio(i).lt.400.0))) Then
ddz3=-xnodalmelt/(bio(i)*dzo(i))
dz(i)=dzo(i)*(1.0+ddz3)
Else
dz(i)=dzo(i)
Endif
bw(i)=(w(i)*rhowater)/dz(i)
!.............................................
If((w(i)/dz(i)).lt.0.05.or.(w(i)/dz(i)) &
.gt.(dice/1000.0)) Then
bw(i) = bwo(i)
dz(i) = (w(i)*rhowater)/bw(i)
Endif
bi(i)=bw(i)*fi(i)
bl(i)=bw(i)-bi(i)
bt(i)=bw(i)
ct(i)=(bw(i)/920.0)*1.9e+6
dliqvol(i)=bl(i)/rhowater
dicevol(i)=bi(i)/dice
h(i)=(-1.0)*w(i)*fi(i)*dlm*rhowater
!cc---------------------------------------------**
ELSE IF (ICASE.EQ.3) THEN
! i=n
! else if(fff.le.0.0) then
!cccccc next calculate ponding condition.
fl(i) = 1.0
fi(i) = 0.0
! dz(i) = w(i)
wf(i) = w(i)
dum= wf(i)
dz(i) = 10e-15
w(i) = 10e-15
bw(i) =rhowater
bl(i)=bw(i)
bi(i)=0.0
dliqvol(i) = 1.0
dicevol(i) = 0.0
ct(i)=(bw(i)/920.0)*1.9e+6
tssn(i) = 273.16
h(i) = 0.0
!
If (i.eq.n) Then
if (i.eq.1) then
hx=(-1.0)*w(i)*fff*dlm*rhowater/dtt
snroff=wf(1)+snroff
wfsoil=0.0
else
wf(i)=amin1(dum, dksatsnow*dtt)
snroff = snroff + (dum - wf(i))
hroff=hroff+(dum-wf(i))*cl*rhowater*(tssn(i)-273.16)
delth(n-1) = (-1.0)*w(i)*fff*dlm*rhowater/dtt
end if
Else
if(i.eq.1)then
hx = ho(i)/dtt + b1+b2*tssn(i)
!ctest2
if(www(1).ge.1.0) then
snroff = snroff + wf(i)
wfsoil=0.0
else
slwet=www(1)*poros*zdepth(1)
www(1)=(slwet+wf(i))/(poros*zdepth(1))
if(www(1).gt.1.0) then
snroff = snroff + (www(1)-1.0)*poros*zdepth(1)
www(1)=1.0
endif
wfsoil=0.0
endif
else
wf(i)=amin1(dum, dksatsnow*dtt)
snroff = snroff + (dum - wf(i))
hroff=hroff+(dum-wf(i))*cl*rhowater*(tssn(i)-273.16)
delth(i-1) = ho(i)/dtt + b1+b2*tssn(i)
endif
End if
END IF
!cS Calculate the heat flux into the soil: qsoil on 10/13/98.
!cS qsoil : downward is positive [ W/m**2]
if (i.eq.1) qsoil = qk(1)*(tssn(1) - tsoil) + hx
!cs 10/13/98
!
!------------------------------------------------------
END SUBROUTINE SNRESULT
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE STRES1 (IFIRST,RSTM,ROOTP, & 2
RSTFAC,RST,TC,ETC,RB,TGS,ETGS,RD,TU,TL,TOPT,EA, &
DEFAC,PH1,PH2,NROOT,ZDEPTH,PHSOIL,ROOTD,VCOVER,DROP)
!
!=======================================================================
!
!======================================================================
!
! CALCULATION OF ADJUSTMENT TO LIGHT DEPENDENT STOMATAL RESISTANCE
! BY TEMPERATURE, HUMIDITY AND STRESS FACTORS
! SIMPLIFIED SEE XUE ET AL(1991)
!
! RSTFAC(IVEG,1) = FD
! RSTFAC(IVEG,2) = FP
! RSTFAC(IVEG,3) = FT
! RSTFAC(IVEG,4) = FTPD
!
!----------------------------------------------------------------------
DIMENSION TOPT(2), TL(2), TU(2), DEFAC(2), VCOVER(2)
DIMENSION PH1(2), PH2(2), RST(2), RSTFAC(2,4),XDRR(3)
DIMENSION ROOTD(2),ROOTP(3),ZDEPTH(3),PHSOIL(3), RSTM(2), DEP(3)
!----------------------------------------------------------------------
! HUMIDITY, TEMPERATURE AND TRANSPIRATION FACTORS
!----------------------------------------------------------------------
!
DO 1000 IVEG = 1, 2
!
TV = TC
ETV = ETC
RAIR = RB * 2.
IF ( IVEG .EQ. 1 ) GO TO 100
TV = TGS
ETV = ETGS
RAIR = RD
100 CONTINUE
!
TV = AMIN1 ( ( TU(IVEG) - 0.1 ), TV )
TV = AMAX1 ( ( TL(IVEG) + 0.1 ), TV )
!
IF( IFIRST .EQ. 0 ) GO TO 200
RSTM(IVEG) = RST(IVEG)
D2 = ( TU(IVEG) - TOPT(IVEG) ) / ( TOPT(IVEG) - TL(IVEG) )
D1 = 1. /(( TOPT(IVEG) - TL(IVEG) )* &
EXP( ALOG( TU(IVEG) - TOPT(IVEG))*D2))
RSTFAC(IVEG,3) = D1*( TV-TL(IVEG)) * EXP(ALOG(TU(IVEG)-TV)*D2)
!
IF (RSTFAC(IVEG,3).LT.0.) RSTFAC(IVEG,3) = 0.
IF (RSTFAC(IVEG,3).GT.1.) RSTFAC(IVEG,3) = 1.
!
!----------------------------------------------------------------------
! SIMPLIFIED CALCULATION OF LEAF WATER POTENTIAL FACTOR , FP
!----------------------------------------------------------------------
!
!---------new add------------
XDRR(1)=-PHSOIL(1)
XDRR(2)=-PHSOIL(2)
XDRR(3)=-PHSOIL(3)
IF(XDRR(1).le.0.001) XDRR(1)=0.001
IF(XDRR(2).le.0.001) XDRR(2)=0.001
IF(XDRR(3).le.0.001) XDRR(3)=0.001
XDRR(1)=ALOG(XDRR(1))
XDRR(2)=ALOG(XDRR(2))
XDRR(3)=ALOG(XDRR(3))
!------------------------------
IF (NROOT.EQ.1) THEN
XROT = ROOTD(1)
DO 7400 I = 1, 3
7400 DEP(I) = 0.
DO 7500 I = 1, 3
DEP(I) = AMIN1(ZDEPTH(I), XROT)
XROT = XROT - ZDEPTH(I)
IF (XROT.LE.0.) GO TO 7410
7500 CONTINUE
7410 CONTINUE
! XDR = (PHSOIL(1) * DEP(1) + PHSOIL(2) * DEP(2) &
! +PHSOIL(3) * DEP(3)) /ROOTD(1)
XDR=(XDRR(1)*DEP(1)+XDRR(2)*DEP(2)+XDRR(3)*DEP(3))/ROOTD(1)
ELSE
! XDR = PHSOIL(1) * ROOTP(1) + PHSOIL(2) * ROOTP(2) &
! +PHSOIL(3) * ROOTP(3)
XDR=XDRR(1)*ROOTP(1)+XDRR(2)*ROOTP(2)+XDRR(3)*ROOTP(3)
END IF
! XDR = - XDR
! IF (XDR .LE. 0.001) XDR = 0.001
! XDR = ALOG (XDR)
!cl 2001,1,09 changed the following two lines back to the original ones.
!cl EXPONENT = AMAX1(-86.0, (- PH1(IVEG) * (PH2(IVEG) - XDR)) )
!cl RSTFAC(IVEG,2) = 1. - EXP(EXPONENT)
RSTFAC(IVEG,2) = 1. - EXP(- PH1(IVEG) * (PH2(IVEG) - XDR))
IF (RSTFAC(IVEG,2).GT.1.) RSTFAC(IVEG,2) = 1.
IF (RSTFAC(IVEG,2).LT.0.) RSTFAC(IVEG,2) = 0.
!
200 RST(IVEG) = RSTM(IVEG)
!
EPOT = ETV - EA
EPOT = AMAX1(0.0001,(ETV-EA))
!
! ---** PJS mod 10/9/92 ---**
! ---** based on Verma FIFE-87 function for C4 grasses ---**
!
RSTFAC(IVEG,1) = 1./ ( 1 + DEFAC(IVEG)*DROP )
!
IF (RSTFAC(IVEG,1).LT.0.) RSTFAC(IVEG,1) = 0.
IF (RSTFAC(IVEG,1).GT.1.) RSTFAC(IVEG,1) = 1.
!----------------------------------------------------------------------
! VALUE OF FP FOUND
!----------------------------------------------------------------------
!
300 FTPD = RSTFAC(IVEG,1) * RSTFAC(IVEG,2) * RSTFAC(IVEG,3)
RSTFAC(IVEG,4) = AMAX1( FTPD, 0.00001 )
!----------------------------------------------------------------------
!
RST(IVEG) = RST(IVEG) / RSTFAC(IVEG,4) / VCOVER(IVEG)
!
RST(IVEG) = AMIN1( RST(IVEG), 100000. )
1000 CONTINUE
!
!------------------------------------------------------
END SUBROUTINE STRES1
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE TEMRS1 & 2,4
(DTT,TC,TGS,TD,TA,TM,QM,EM,PSURF,WWW,CAPAC,SATCAP, &
DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,D,Z0,RDC,RBC,VCOVER,Z2, &
ZLAI,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP, &
THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN, &
BPS,rib,CU,XCT,flup,iii,jjj)
!cxx BPS,BPS0,BPS1,rib,CU,XCT,flup)
!
!=======================================================================
! ------------------------------------------------------------------7272
! A SIMPLIFIED VERSION (XUE ET AL. 1991)
! CORE ROUTINE: CALCULATION OF CANOPY AND GROUND TEMPERATURE
! INCREMENTS OVER TIME STEP, FLUXES DERIVED.
!-----------------------------------------------------------------------
! SUBROUTINES IN THIS BLOCK : TEMRS1,DELRN,DELHF,DELEF,STRES1
!-----------------------------------------------------------------------
REAL ZINC(3), A2(3), Y1(3), ITEX(3),RSTM(2)
!cl add the following arrays after common block "comsib3" was removed
DIMENSION WWW(3), CAPAC(2), SATCAP(2), ZDEPTH(3)
DIMENSION VCOVER(2), ZLAI(2), RADT(2),ALBEDO(2,3,2)
DIMENSION TOPT(2), TL(2), TU(2), DEFAC(2)
DIMENSION PH1(2), PH2(2), RST(2), RSTFAC(2,4)
DIMENSION ROOTD(2), ROOTP(3), PHSOIL(3)
!
!----------------------------------------------------------------------
! E(X) IS VAPOUR PRESSURE IN MBARS AS A FUNCTION OF TEMPERATURE
! GE(X) IS D E(X) / D ( TEMP )
!----------------------------------------------------------------------
!
E(X) = EXP( 21.18123 - 5418. / X ) / .622
GE(X) = EXP( 21.18123 - 5418. / X ) * 5418. &
/ (X*X) / .622
!
ETC = E(TC)
ETGS = E(TGS)
GETC = GE(TC)
GETGS = GE(TGS)
!crr HLAT = ( 3150.19 - 2.378 * TM ) * 1000.
!crr PSY = CPAIR / HLAT * PSUR / .622
PSY = CPAIR / HLAT * PSURF/100. / .622
RCP = RHOAIR * CPAIR
! RADD = 44.
WC = AMIN1( 1., CAPAC(1)/SATCAP(1) )
WG = AMIN1( 1., CAPAC(2)/SATCAP(2) )
!----------------------------------------------------------------------
! RSOIL FUNCTION FROM FIT TO CAMILLO AND GURNEY (1984) DATA.
! WETNESS OF UPPER 0.5 CM OF SOIL CALCULATED FROM APPROXIMATION
! TO MILLY FLOW EQUATION WITH REDUCED (1/50 ) CONDUCTIVITY IN
! TOP LAYER.
!----------------------------------------------------------------------
!
! WT = WWW(1) + 0.75 * ZDEPTH(1) / ( ZDEPTH(1) + ZDEPTH(2) )
! & * (WWW(1) - (WWW(2)**2)/WWW(1) ) / 2. * 50.
! FAC = AMIN1( WT, 0.99 )
! FAC = AMAX1( FAC, WWW(1) * 0.1 )
!
!------------------------------------------------------------
! --- soil resistance calculation alteration Y.K. Xue Feb. 1994**
!------------------------------------------------------------
FAC = AMIN1( www(1), 0.99 )
FAC = AMAX1( FAC, 0.02 )
RSOIL = 101840. * (1. - FAC ** 0.0027)
!
PSIT = PHSAT * FAC ** (- BEE )
ARGG = AMAX1(-10.,(PSIT*GRAV/461.5/TGS))
HR = EXP(ARGG)
!cl 2001,1,10 added the following line according to Xue, 2000 August
PILPHR = HR
!----------------------------------------------------------------------
! ALTERATION OF AERODYNAMIC TRANSFER PROPERTIES IN CASE OF SNOW
! ACCUMULATION.
!----------------------------------------------------------------------
!
RESD = D
RESZ0 = Z0
RESRDC = RDC
RESRBC = RBC
RESV2 = VCOVER(2)
!
IF ( TGS .GT. TF ) GO TO 100
!
SDEP = CAPAC(2) *SNOWDEN
SDEP = AMIN1( SDEP, (Z2*0.95) )
D = Z2 - ( Z2-D ) / Z2 * ( Z2 - SDEP )
Z0 = Z0 / ( Z2-RESD ) * ( Z2-D )
RDC = RDC * ( Z2-SDEP ) / Z2
RBC = RBC * Z2 / ( Z2-SDEP )
VCOVER(2) = 1.
WG = AMIN1( 1., CAPAC(2) / 0.004 )
RST(2) = RSOIL
100 CONTINUE
!----------------------------------------------------------------------
!
! CALCULATION OF EA, TA, RA, RB, RD AND SOIL MOISTURE STRESS
! FOR THE BEGINNING OF THE TIME STEP
!
!----------------------------------------------------------------------
IFIRST = 1
ICOUNT = 0
TGEN = TGS
TCEN = TC
FC = 1.
FG = 1.
!-- 2001,1,11 changed the following line according to Xue,August,2000(TA=TM)
!cl TA = TM
TRIB = TA
EA = EM
HT = 0.
IONCE = 0
1000 CONTINUE
ICOUNT = ICOUNT + 1
CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
!cl ------------IF ( IFIRST .EQ. 1 ) CALL RBRD1 ------------
IF ( IFIRST .EQ. 1 ) THEN
!cl TCTA = TC - TA
RB = 1.0/(SQRT(U2)/RBC+ZLAI(1)*.004)
!cl X1 = TEMDIF
TGTA = TGS- TA
TEMDIF = ( TGTA + SQRT(TGTA*TGTA) ) / 2. + 0.1
FIH = SQRT( 1. + 9. * GRAV *TEMDIF * Z2 / TGS / ( U2*U2) )
RD = RDC / U2 / FIH
ENDIF
!cl ------------ END OF RBRD1 ---------------
D1 = 1./RA + 1./RB + 1./RD
TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
HT = ( TA - TM ) * RCP / RA
RCC = RST(1)*FC + 2. * RB
COC = (1.-WC)/RCC + WC/(2.*RB)
RG = RST(2)*FG
RSURF = RSOIL*FG
COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HR &
+ VCOVER(2)/(RSURF+RD+44.)*HR
COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
+ VCOVER(2)/(RSURF+RD+44.)
COG1 = COG1 + WG/RD * VCOVER(2)
COG2 = COG2 + WG/RD * VCOVER(2)
D2 = 1./RA + COC + COG2
TOP = COC * ETC + COG1 * ETGS + EM / RA
EA = TOP / D2
DROP = AMAX1( 0., (E(TA)-EA) )
!----------------------------------------------------------------------
!cl CALL STRES1 ( IFIRST , RSTM)
CALL STRES1 (IFIRST, RSTM,ROOTP, &
RSTFAC,RST,TC,ETC,RB,TGS,ETGS,RD,TU,TL,TOPT,EA, &
DEFAC,PH1,PH2,NROOT,ZDEPTH,PHSOIL,ROOTD,VCOVER,DROP)
!----------------------------------------------------------------------
IFIRST = 0
ERIB = EA
TRIB = TA
!!!
IF ( ICOUNT .LE. 4 ) GO TO 1000
!======================================================================
!cl CALL DELRN ( RNCDTC, RNCDTG, RNGDTG, RNGDTC )
! PARTIAL DERIVATIVES OF RADIATIVE AND SENSIBLE HEAT FLUXES
TC3 = TC * TC * TC
TG3 = TGS * TGS * TGS
FAC1 = ( 1. - ALBEDO(1,3,2) ) * ( 1.-THERMK ) * VCOVER(1)
FAC2 = 1. - ALBEDO(2,3,2)
RNCDTC = - 2. * 4. * FAC1 * STEFAN * TC3
RNCDTG = 4. * FAC1 * FAC2 * STEFAN * TG3
RNGDTG = - 4. * FAC2 * STEFAN * TG3
RNGDTC = 4. * FAC1 * FAC2 * STEFAN * TC3
!----------------------------------------------------------------------
!
! DEW CALCULATION : DEW CONDITION IS SET AT BEGINNING OF TIME STEP.
! IF SURFACE CHANGES STATE DURING TIME STEP, LATENT HEAT FLUX IS
! SET TO ZERO.
!
!----------------------------------------------------------------------
IF ( EA .GT. ETC ) FC = 0.
IF ( EA .GT. ETGS) FG = 0.
!
!----------------------------------------------------------------------
!
! WET FRACTION EXHAUSTION TEST : IF CAPAC(X) IS EXHAUSTED IN
! A TIME STEP, INTERCEPTION LOSS IS LIMITED TO CAPAC(X).
!
!----------------------------------------------------------------------
! START OF NON-NEUTRAL RESISTANCE CALCULATION LOOP
!----------------------------------------------------------------------
I = 0
! ----- INITIALIZE NEWTON-RAPHSON ITERATIVE ROUTINE FOR RASIT 3,5,8
NOX = 0
NONPOS = 1
IWALK = 0
LX = 2
FINC = 1.
ITEX(LX) = 0.
ZINC(LX) = 0.
A2(LX) = 0.
Y1(LX) = 0.
2000 CONTINUE
CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
!======================================================================
!cl CALL DELHF ( HCDTC, HCDTG, HGDTG, HGDTC )
! PARTIAL DERIVATIVES OF SENSIBLE HEAT FLUXES
!
RCP = RHOAIR * CPAIR
D1 = 1./RA + 1./RB + 1./RD
TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
!
HC = RCP * ( TC - TA ) / RB * DTT
HG = RCP * ( TGS - TA ) / RD * DTT
!----------------------------------------------------------------------
! N.B. FLUXES EXPRESSED IN JOULES M-2
!----------------------------------------------------------------------
!
HCDTC = RCP / RB * ( 1./RA + 1./RD ) / D1
HCDTG = - RCP / ( RB * RD ) / D1
! FOR TM
HCDTM = - RCP / ( RB * RA ) / D1 * BPS
!
HGDTG = RCP / RD * ( 1./RA + 1./RB ) / D1
HGDTC = - RCP / ( RD * RB ) / D1
! FOR TM
HGDTM = - RCP / ( RD * RA ) / D1 *BPS
!======================================================================
! CALL DELEF ( ECDTC, ECDTG, EGDTG, EGDTC, DEADTC, DEADTG, EC, EG ,
! & WC, WG, FC, FG, HR,MDLSNO,ISNOW )
!======================================================================
! PARTIAL DERIVATIVES OF LATENT HEAT FLUXES
! MODIFICATION FOR SOIL DRYNESS : HR = REL. HUMIDITY IN TOP LAYER
!----------------------------------------------------------------------
!
HRR = HR
IF ( FG .LT. .5 ) HRR = 1.
!
RCC = RST(1)*FC + 2. * RB
COC = (1.-WC)/RCC + WC/(2.*RB)
RG = RST(2)*FG
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
RSURF=RSOIL
ELSE
RSURF = RSOIL*FG
END IF
COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HRR &
+ VCOVER(2)/(RSURF+RD+44.)*HRR
COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
+ VCOVER(2)/(RSURF+RD+44.)
COG1 = COG1 + WG/RD * VCOVER(2)
COG2 = COG2 + WG/RD * VCOVER(2)
!
D2 = 1./RA + COC + COG2
TOP = COC * ETC + COG1 * ETGS + EM/RA
EA = TOP / D2
EC = ( ETC - EA ) * COC * RCP/PSY * DTT
EG = ( ETGS*COG1 - EA*COG2 ) * RCP/PSY * DTT
DEADTC = GETC * COC / D2
DEADTG = GETGS * COG1 / D2
!
ECDTC = ( GETC - DEADTC ) * COC * RCP / PSY
ECDTG = - DEADTG * COC * RCP / PSY
!
EGDTG = ( GETGS*COG1 - DEADTG*COG2 ) * RCP / PSY
EGDTC = - DEADTC * COG2 * RCP / PSY
!crr
! FOR QM
DEADQM = 0.622 * PSURF /( (0.622+QM)**2 * RA * D2 )
ECDQM = -DEADQM * COC * RCP / PSY
EGDQM = -DEADQM * COG2 * RCP / PSY
! FOR YPDATING TM AND QM
AK = 1/ RCP / BPS
AH = 1/ (HLAT*RHOAIR)
!crr
!----------------------------------------------------------------------
! CALCULATION OF COEFFICIENTS OF TEMPERATURE TENDENCY EQUATIONS
! C - CANOPY
! G - GROUND
!----------------------------------------------------------------------
!
CCODTC = CCX / DTT - RNCDTC + HCDTC + ECDTC
CCODTG = - RNCDTG + HCDTG + ECDTG
CCORHS = RADT(1) - ( HC + EC ) / DTT
!----------------------------------------------------------------------
!
GCODTG = CG / DTT + TIMCON*CG*2. - RNGDTG + HGDTG + EGDTG
GCODTC = - RNGDTC + HGDTC + EGDTC
GCORHS = RADT(2) - TIMCON*CG*2. * ( TGS -TD ) - ( HG + EG ) / DTT
!
DENOM = CCODTC * GCODTG - CCODTG * GCODTC
DTC = ( CCORHS * GCODTG - CCODTG * GCORHS ) / DENOM
DTG = ( CCODTC * GCORHS - CCORHS * GCODTC ) / DENOM
!----------------------------------------------------------------------
! CHECK IF INTERCEPTION LOSS TERM HAS EXCEEDED CANOPY STORAGE
!----------------------------------------------------------------------
!
ECPOT = ( (ETC - EA) + (GETC - DEADTC)*DTC - DEADTG*DTG )
ECI = ECPOT * WC /(2.*RB) * RCP/PSY * DTT
ECIDIF=AMAX1(0.0,(ECI-CAPAC(1)*1.E3*HLAT))
ECI =AMIN1(ECI,( CAPAC(1)*1.E3*HLAT))
!
EGPOT = ( (ETGS - EA) + (GETGS - DEADTG)*DTG - DEADTC*DTC )
EGI = EGPOT * VCOVER(2) * WG/RD * RCP/PSY * DTT
EGIDIF=AMAX1(0.0,(EGI-CAPAC(2)*1.E3*HLAT))
EGI =AMIN1(EGI,( CAPAC(2)*1.E3*HLAT))
!----------------------------------------------------------------------
TGEN = TGS + DTG
TCEN = TC + DTC
D1 = 1./RA + 1./RB + 1./RD
TAEN = ( TGEN / RD + TCEN / RB + TM / RA *bps) / D1
!
HEND = ( TAEN - TM ) * RCP / RA + (ECIDIF + EGIDIF)/DTT
Y= TRIB - TAEN
I = I + 1
HT = HEND
IF ( I .GT. 20 ) GO TO 200
!cl IF ( I .GT. ITRUNK ) GO TO 200
!
CALL NEWTON(TRIB,Y,FINC,NOX,NONPOS,IWALK,LX,ZINC,A2,Y1,ITEX)
IF(NOX.NE.1)GO TO 2000
200 CONTINUE
! IQIN = IQIN + I
! IF (I.GT.10) IQIN1 = IQIN1 + 1
!
!----------------------------------------------------------------------
! EXIT FROM NON-NEUTRAL CALCULATION
! EVAPOTRANSPIRATION FLUXES CALCULATED FIRST ( J M-2 )
!----------------------------------------------------------------------
HRR = HR
IF ( FG .LT. .5 ) HRR = 1.
RSURF = RSOIL*FG
!
COCT = (1.-WC)/RCC
COGT = VCOVER(2) * (1.-WG)/( RG + RD )
COGS1 = (1.-VCOVER(2)) / ( RD + RSURF ) * HRR &
+ VCOVER(2) / ( RD + RSURF + 44.) * HRR
COGS2 = COGS1 / HRR
!
ECT = ECPOT * COCT * RCP/PSY * DTT
!
EGT = EGPOT * COGT * RCP/PSY * DTT
EGS = (ETGS + GETGS*DTG ) * COGS1 &
- ( EA + DEADTG*DTG + DEADTC*DTC ) * COGS2
EGS = EGS * RCP/PSY * DTT
EGSMAX = WWW(1) / 2. * ZDEPTH(1) * POROS * HLAT * 1000.
EGIADD = AMAX1( 0., EGS - EGSMAX )
EGS = AMIN1 ( EGS, EGSMAX )
EGIDIF = EGIDIF + EGIADD
!
!----------------------------------------------------------------------
! SENSIBLE HEAT FLUX CALCULATED WITH LATENT HEAT FLUX CORRECTION
!----------------------------------------------------------------------
HC = HC + (HCDTC*DTC + HCDTG*DTG)*DTT + ECIDIF
HG = HG + (HGDTC*DTC + HGDTG*DTG)*DTT + EGIDIF
!----------------------------------------------------------------------
! TEST OF DEW CONDITION. LATENT HEAT FLUXES SET TO ZERO IF SIGN
! OF FLUX CHANGES OVER TIME STEP.EXCESS ENERGY DONATED TO SENSIBLE
! HEAT FLUX.
!----------------------------------------------------------------------
ECF = SIGN( 1., ECPOT )
EGF = SIGN( 1., EGPOT )
DEWC = FC * 2. - 1.
DEWG = FG * 2. - 1.
!
IF(DEWC*ECF.GT.0.0) GO TO 300
HC = HC + ECI + ECT
ECI = 0.
ECT = 0.
300 IF(DEWG*EGF.GT.0.0) GO TO 400
HG = HG + EGS + EGI + EGT
EGS = 0.
EGI = 0.
EGT = 0.
400 CONTINUE
!
EC = ECI + ECT
EG = EGT + EGS + EGI
!
!----------------------------------------------------------------------
! ADJUSTMENT OF TEMPERATURES AND VAPOR PRESSURE , CALCULATION OF
! SENSIBLE HEAT FLUXES.
!----------------------------------------------------------------------
!
TC = TCEN
TGS = TGEN
TA = TAEN
EA = EA + DEADTC*DTC + DEADTG*DTG
!
RADT(1) = RADT(1) + RNCDTC*DTC + RNCDTG*DTG
RADT(2) = RADT(2) + RNGDTC*DTC + RNGDTG*DTG
!========================================================================
FLUP = FLUP - (RNCDTC+RNGDTC)*DTC - (RNCDTG+RNGDTG)*DTG
!========================================================================
!
! ** simulated net all-wave radiation **
! sibnet(nmm,ndd,nhh) = RADT(1) + RADT(2)
!
CHF = CCX / DTT * DTC
SHF = CG / DTT * DTG + TIMCON*CG*2. * ( TGS - TD )
!
ZLWUP = ZLWUP - RNCDTC * DTC / 2. &
- RNGDTG * DTG * (1.-VCOVER(1)*(1.-THERMK) )
!
IF ( TGS .GT. TF ) GO TO 500
EGS = EG - EGI
EGT = 0.
500 CONTINUE
VCOVER(2) = RESV2
D = RESD
Z0 = RESZ0
RDC = RESRDC
RBC = RESRBC
!------------------------------------------------------
END SUBROUTINE TEMRS1
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE TEMRS2 & 1,6
(DTT,TC,TGS,TD,TA,TM,QM,EM,PSURF,WWW,CAPAC,SATCAP, &
DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,D,Z0,RDC,RBC,VCOVER, &
Z2,ZLAI,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP, &
PH1,PH2,ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF, &
ALBEDO,ZLWUP,THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, &
ISNOW,CHISL,TSOIL,SOLSOIL,CSOIL,WFSOIL,POROSITY, &
DZ,DZO,W,WO,WF,TSSN,TSSNO,BW,BWO,CT,CTO,FI,FIO,FL,FLO, &
BL,BLO,BI,BIO,BT,BTO,DMLT,DMLTO,H,HO,S,SO,SS,SSO,DSOL,DHP, &
DICEVOL,DLIQVOL,THK,QK,SWE,SNOWDEN,SNOWDEPTH,TKAIR,SNROFF, &
DZSOIL,BPS,rib,CU,XCT,flup,iii,jjj)
!
!=======================================================================
! ------------------------------------------------------------------7272
! SUBROUTINES IN THIS BLOCK : RASIT5(RBRD1), STRES1,DELRN,TPROPTY,
! ------------------------- DELHF,DELEF,NEWTON,SNRESULT
!CS------------------ sun Adds Local variables 10/13/98 ----------------
!clwp 12/13/2000, change the dimensions of delth to a certain number > N
REAL WORK(N1),WORK1(N1),DELTH(20)
data DELTH/20*0.0/
REAL ZINC(3), A2(3), Y1(3), ITEX(3),RSTM(2)
DIMENSION SSO(N1),POROSITY(N1),H(N1),HO(N1),DZ(N1),DZO(N1),CT(N1), &
BI(N1),BIO(N1),BW(N1),BWO(N1),BL(N1),BLO(N1),CTO(N1), &
TSSN(N1),TSSNO(N1),DLIQVOL(N1),DICEVOL(N1),DSOL(N1), &
W(N1),WO(N1),WF(N1),FI(N1),FIO(N1),FL(N1),FLO(N1), &
DMLT(N1),DMLTO(N1),BT(N1),BTO(N1),S(N1),SO(N1),SS(N1), &
PDZDTC(N1),DMASS(N1),THK(N1),DHP(N1),QK(N1)
DIMENSION WWW(3),CAPAC(2),SATCAP(2),ZDEPTH(3),VCOVER(2),ZLAI(2), &
RADT(2),ALBEDO(2,3,2),TOPT(2),TL(2),TU(2),DEFAC(2), &
PH1(2),PH2(2),RST(2),RSTFAC(2,4), &
ROOTD(2),ROOTP(3),PHSOIL(3)
! ------------------------------------------------------------------7272
! E(X) IS VAPOUR PRESSURE IN MBARS AS A FUNCTION OF TEMPERATURE
! GE(X) IS D E(X) / D ( TEMP )
! ------------------------------------------------------------------7272
!
E(X) = EXP( 21.18123 - 5418. / X ) / .622
GE(X) = EXP( 21.18123 - 5418. / X ) * 5418. &
/ (X*X) / .622
!
ETC = E(TC)
ETGS = E(TGS)
GETC = GE(TC)
GETGS = GE(TGS)
!crr HLAT = ( 3150.19 - 2.378 * TM ) * 1000.
PSY = CPAIR / HLAT * PSURF/ 100. / .622
RCP = RHOAIR * CPAIR
! RADD = 44.
WC = AMIN1( 1., CAPAC(1)/SATCAP(1) )
!CS SUN CHANGE foolowing statement to one new 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
WG=1.0
ELSE
WG = AMIN1( 1., CAPAC(2)/SATCAP(2) )
END IF
!CS on 10/13/98
!----------------------------------------------------------------------
! RSOIL FUNCTION FROM FIT TO CAMILLO AND GURNEY (1984) DATA.
! WETNESS OF UPPER 0.5 CM OF SOIL CALCULATED FROM APPROXIMATION
! TO MILLY FLOW EQUATION WITH REDUCED (1/50 ) CONDUCTIVITY IN
! TOP LAYER.
!----------------------------------------------------------------------
!
! WT = WWW(1) + 0.75 * ZDEPTH(1) / ( ZDEPTH(1) + ZDEPTH(2) )
! & * (WWW(1) - (WWW(2)**2)/WWW(1) ) / 2. * 50.
! FAC = AMIN1( WT, 0.99 )
! FAC = AMAX1( FAC, WWW(1) * 0.1 )
!
!------------------------------------------------------------
! --- soil resistance calculation alteration Y.K. Xue Feb. 1994**
!------------------------------------------------------------
FAC = AMIN1( www(1), 0.99 )
FAC = AMAX1( FAC, 0.02 )
!CS Sun fixed following RSOIL equation as equal to 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
RSOIL=10000000000.
ELSE
RSOIL = 101840. * (1. - FAC ** 0.0027)
END IF
!CS 10/13/98
!------------------------------------------------------------
!
PSIT = PHSAT * FAC ** (- BEE )
ARGG = AMAX1(-10.,(PSIT*GRAV/461.5/TGS))
HR = EXP(ARGG)
!CL 2001,1,10 added the following line according to Xue, August 2000
PILPHR = HR
!----------------------------------------------------------------------
! ALTERATION OF AERODYNAMIC TRANSFER PROPERTIES IN CASE OF SNOW
! ACCUMULATION.
!----------------------------------------------------------------------
RESD = D
RESZ0 = Z0
RESRDC = RDC
RESRBC = RBC
RESV2 = VCOVER(2)
!
IF ( TGS .GT. TF ) GO TO 100
!CS Sun Change following statement into another one: SDEP=snowdepth 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
SDEP = SNOWDEPTH
ELSE
SDEP = CAPAC(2) * SNOWDEN
END IF
!CS 10/13/98
SDEP = AMIN1( SDEP, (Z2*0.95) )
D = Z2 - ( Z2-D ) / Z2 * ( Z2 - SDEP )
Z0 = Z0 / ( Z2-RESD ) * ( Z2-D )
RDC = RDC * ( Z2-SDEP ) / Z2
RBC = RBC * Z2 / ( Z2-SDEP )
VCOVER(2) = 1.
!CS Sun added the following IF,change the WG to WG=1.0 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
WG=1.0
ELSE
WG = AMIN1( 1., CAPAC(2) / 0.004 )
END IF
RST(2) = RSOIL
100 CONTINUE
!----------------------------------------------------------------------
!
! CALCULATION OF EA, TA, RA, RB, RD AND SOIL MOISTURE STRESS
! FOR THE BEGINNING OF THE TIME STEP
!
!----------------------------------------------------------------------
IFIRST = 1
ICOUNT = 0
TGEN = TGS
TCEN = TC
FC = 1.
FG = 1.
TRIB = TA
EA = EM
!cl TA = TM
HT = 0.
IONCE = 0
1000 CONTINUE
ICOUNT = ICOUNT + 1
CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
!cl ------------IF ( IFIRST .EQ. 1 ) CALL RBRD1 ------------
IF ( IFIRST .EQ. 1 ) THEN
!cl TCTA = TC - TA
RB = 1.0/(SQRT(U2)/RBC+ZLAI(1)*.004)
!cl X1 = TEMDIF
TGTA = TGS- TA
TEMDIF = ( TGTA + SQRT(TGTA*TGTA) ) / 2. + 0.1
FIH = SQRT( 1. + 9. * GRAV *TEMDIF * Z2 / TGS / ( U2*U2) )
RD = RDC / U2 / FIH
ENDIF
!cl ------------ END OF RBRD1 ---------------
D1 = 1./RA + 1./RB + 1./RD
TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
HT = ( TA - TM ) * RCP / RA
RCC = RST(1)*FC + 2. * RB
COC = (1.-WC)/RCC + WC/(2.*RB)
RG = RST(2)*FG
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
RSURF = RSOIL
ELSE
RSURF = RSOIL*FG
END IF
COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HR &
+ VCOVER(2)/(RSURF+RD+44.)*HR
COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
+ VCOVER(2)/(RSURF+RD+44.)
COG1 = COG1 + WG/RD * VCOVER(2)
COG2 = COG2 + WG/RD * VCOVER(2)
D2 = 1./RA + COC + COG2
TOP = COC * ETC + COG1 * ETGS + EM / RA
EA = TOP / D2
DROP = AMAX1( 0., (E(TA)-EA) )
!
!----------------------------------------------------------------------
CALL STRES1 (IFIRST, RSTM,ROOTP, &
RSTFAC,RST,TC,ETC,RB,TGS,ETGS,RD,TU,TL,TOPT,EA, &
DEFAC,PH1,PH2,NROOT,ZDEPTH,PHSOIL,ROOTD,VCOVER,DROP)
!----------------------------------------------------------------------
!
IFIRST = 0
ERIB = EA
TRIB = TA
!!!
IF ( ICOUNT .LE. 4 ) GO TO 1000
!======================================================================
!cl CALL DELRN ( RNCDTC, RNCDTG, RNGDTG, RNGDTC )
! PARTIAL DERIVATIVES OF RADIATIVE AND SENSIBLE HEAT FLUXES
TC3 = TC * TC * TC
TG3 = TGS * TGS * TGS
FAC1 = ( 1. - ALBEDO(1,3,2) ) * ( 1.-THERMK ) * VCOVER(1)
FAC2 = 1. - ALBEDO(2,3,2)
RNCDTC = - 2. * 4. * FAC1 * STEFAN * TC3
RNCDTG = 4. * FAC1 * FAC2 * STEFAN * TG3
RNGDTG = - 4. * FAC2 * STEFAN * TG3
RNGDTC = 4. * FAC1 * FAC2 * STEFAN * TC3
!----------------------------------------------------------------------
!
! DEW CALCULATION : DEW CONDITION IS SET AT BEGINNING OF TIME STEP.
! IF SURFACE CHANGES STATE DURING TIME STEP, LATENT HEAT FLUX IS
! SET TO ZERO.
!
!----------------------------------------------------------------------
!
IF ( EA .GT. ETC ) FC = 0.
IF ( EA .GT. ETGS) FG = 0.
!
!----------------------------------------------------------------------
!
! WET FRACTION EXHAUSTION TEST : IF CAPAC(X) IS EXHAUSTED IN
! A TIME STEP, INTERCEPTION LOSS IS LIMITED TO CAPAC(X).
!
!----------------------------------------------------------------------
! START OF NON-NEUTRAL RESISTANCE CALCULATION LOOP
!----------------------------------------------------------------------
!
II = 0
!
! ----- INITIALIZE NEWTON-RAPHSON ITERATIVE ROUTINE FOR RASIT 3,5,8
NOX = 0
NONPOS = 1
IWALK = 0
LX = 2
FINC = 1.
ITEX(LX) = 0.
ZINC(LX) = 0.
A2(LX) = 0.
Y1(LX) = 0.
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
!---------------------------------------------------------
! Next loop, we calculate the thermal conductivities
! and specific heat
!---------------------------------------------------------
CALL TPROPTY(CHISL,BWO,DZO,TKAIR,DZSOIL, THK,QK)
!------------------------------------------------------------
! Next we calculate the balances of energy and water
!------------------------------------------------------------
tssn(n+1) = tkair
!------------------------------------------------------------
icount = 0
do i=1,n
work(i) = tssno(i)
work1(i) = dliqvol(i)
end do
hx = 0.0
NK=n
ELSE
NK=1
END IF
RADDWN=solsoil
RADDWN=RADDWN+dsol(1)+dsol(2)
RNG = RADT(2) - RADDWN
RADT(2)=RNG
do 57 ik = NK , 1 , -1
!cccc Next calculate snow layers temperatures and densities
IF (ISNOW.ne.0) go to 2000
If((sso(ik).lt.1d0.and.porosity(ik).gt.0d0))then
udum0 = dzo(ik)*(porosity(ik) -work1(ik))
if(udum0.lt.0.0) then
print*,' udum0 is WRONG in thermal.f'
STOP
endif
if(wf(ik+1).gt.udum0)then
uuu=udum0
snroff = snroff + (wf(ik+1)-udum0)
hroff=hroff+(wf(ik+1)-udum0)*cl*rhowater*(tssn(ik+1)-273.16)
else
uuu=wf(ik+1)
endif
dhp(ik+1)=(uuu*cl*rhowater*(tssn(ik+1)-273.16))/dtt
w(ik)=wo(ik)+ uuu
bwo(ik)=rhowater*w(ik)/dzo(ik)
cto(ik)=(bwo(ik)/920.0)*1.9e+6
dmlto(ik)=w(ik)*dlm*rhowater
if (ho(ik).lt.-dmlto(ik)) then
fio(ik)=1.0
flo(ik)=0.0
tssno(ik)=( ho(ik)+dmlto(ik))/(cto(ik)*dzo(ik))+273.16
! ------------------------------------------------------------------7272
else
tssno(ik)=273.16
fio(ik)=-ho(ik)/dmlto(ik)
flo(ik)=1.0-fio(ik)
end if
blo(ik)=bwo(ik)*flo(ik)
bio(ik)=bwo(ik)*fio(ik)
dliqvol(ik)=blo(ik)/rhowater
dicevol(ik)=bio(ik)/dice
Else
w(ik)=wo(ik)
snroff = snroff +wf(ik+1)
hroff=hroff+wf(ik+1)*cl*rhowater*(tssn(ik+1)-273.16)
dhp(ik+1) = 0.0
End if
!cs Sun add. It is important because tssno(n) is changed here on 1/25/99 .
TGS=tssno(NK)
!cs 0n 1/25/99
!------------------------------------------------------------*
If (ik.lt.Nk) Then
! Next: ik < n
if(ik.ne.1) then
b1 = dsol(ik) + delth(ik) &
+ qk(ik+1)*(tssn(ik+1)-tssno(ik)) + qk(ik)*work(ik-1)
else
b1 = dsol(ik) + delth(ik) &
+ qk(ik+1)*(tssn(ik+1)-tssno(ik)) + qk(ik)*tsoil
endif
!
b2 = - qk(ik)
! Important: delth(ik) must be initialized after using.
delth(ik) = 0.0
End if
dmlt(ik)=w(ik)*dlm*rhowater
If (ik.lt.NK.and.ik.ge.1) Then
fff = -( ho(ik) + (b1+b2*273.16)*dtt ) &
/ ( rhowater*dlm*w(ik) )
! when snow temperature equals 273.16
!!
if(fff.gt.0.0.and.fff.le.1.0) then
ICASE=2
fi(ik)=fff
else if (fff.gt.1.0) then
ICASE=1
else if (fff.le.0.0) then
ICASE=3
end if
End if
If (ik.lt.NK) go to 3000
!
!CS Sun add above paragraph on 10/13/98
2000 CONTINUE
!
CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
!----------------------------------------------------------------------
!cl CALL DELHF ( HCDTC, HCDTG, HGDTG, HGDTC )
! PARTIAL DERIVATIVES OF SENSIBLE HEAT FLUXES
!
RCP = RHOAIR * CPAIR
D1 = 1./RA + 1./RB + 1./RD
TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
!
HC = RCP * ( TC - TA ) / RB * DTT
HG = RCP * ( TGS - TA ) / RD * DTT
!----------------------------------------------------------------------
! N.B. FLUXES EXPRESSED IN JOULES M-2
!----------------------------------------------------------------------
!
HCDTC = RCP / RB * ( 1./RA + 1./RD ) / D1
HCDTG = - RCP / ( RB * RD ) / D1
! FOR TM
HCDTM = - RCP / ( RB * RA ) / D1 * BPS
!
HGDTG = RCP / RD * ( 1./RA + 1./RB ) / D1
HGDTC = - RCP / ( RD * RB ) / D1
! FOR TM
HGDTM = - RCP / ( RD * RA ) / D1 *BPS
!======================================================================
! CALL DELEF ( ECDTC, ECDTG, EGDTG, EGDTC, DEADTC, DEADTG, EC, EG ,
! & WC, WG, FC, FG, HR,MDLSNO,ISNOW )
!
! PARTIAL DERIVATIVES OF LATENT HEAT FLUXES
! MODIFICATION FOR SOIL DRYNESS : HR = REL. HUMIDITY IN TOP LAYER
!----------------------------------------------------------------------
!
HRR = HR
IF ( FG .LT. .5 ) HRR = 1.
!
RCC = RST(1)*FC + 2. * RB
COC = (1.-WC)/RCC + WC/(2.*RB)
RG = RST(2)*FG
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
RSURF=RSOIL
ELSE
RSURF = RSOIL*FG
END IF
COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HRR &
+ VCOVER(2)/(RSURF+RD+44.)*HRR
COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
+ VCOVER(2)/(RSURF+RD+44.)
COG1 = COG1 + WG/RD * VCOVER(2)
COG2 = COG2 + WG/RD * VCOVER(2)
!
D2 = 1./RA + COC + COG2
TOP = COC * ETC + COG1 * ETGS + EM/RA
EA = TOP / D2
EC = ( ETC - EA ) * COC * RCP/PSY * DTT
EG = ( ETGS*COG1 - EA*COG2 ) * RCP/PSY * DTT
DEADTC = GETC * COC / D2
DEADTG = GETGS * COG1 / D2
!
ECDTC = ( GETC - DEADTC ) * COC * RCP / PSY
ECDTG = - DEADTG * COC * RCP / PSY
!
EGDTG = ( GETGS*COG1 - DEADTG*COG2 ) * RCP / PSY
EGDTC = - DEADTC * COG2 * RCP / PSY
!crr
! FOR QM
DEADQM = 0.622 * PSURF /( (0.622+QM)**2 * RA * D2 )
ECDQM = -DEADQM * COC * RCP / PSY
EGDQM = -DEADQM * COG2 * RCP / PSY
! FOR YPDATING TM AND QM
AK = 1/ RCP / BPS
AH = 1/ (HLAT*RHOAIR)
!crr
!----------------------------------------------------------------------
!
! CALCULATION OF COEFFICIENTS OF TEMPERATURE TENDENCY EQUATIONS
! C - CANOPY, G - GROUND
!
!----------------------------------------------------------------------
!
CCODTC = CCX / DTT - RNCDTC + HCDTC + ECDTC
CCODTG = - RNCDTG + HCDTG + ECDTG
CCORHS = RADT(1) - ( HC + EC ) / DTT
!
!----------------------------------------------------------------------
!CS Sun Change following original GCODCG into new one 10/13/98
IF (ISNOW.eq.0) THEN
GCODTG= cto(n)*dzo(n)/DTT - RNGDTG + HGDTG + EGDTG + qk(n)
ELSE
GCODTG = CG / DTT + TIMCON*CG*2. - RNGDTG + HGDTG + EGDTG
END IF
GCODTC = - RNGDTC + HGDTC + EGDTC
!CS From NOW ON WE REALLY GET INTO SNOW PART !!!!. ON 10/13/98
!cl IF (MDLSNO.ne.0.or.ISNOW.ne.0) THEN
IF (ISNOW.ne.0) THEN
GCORHS = RADT(2)-TIMCON*CG*2.*( TGS -TD )-( HG + EG )/ DTT
ELSE
fi(n)=1.0
GCORHS1 = ho(n)/DTT+RNG - ( HG + EG ) / DTT +dhp(n+1) &
- qk(n)*(TGS -tssno(n-1))-cto(n)*dzo(n)*(tssno(n)-273.16)/DTT
GCORHS = GCORHS1+ rhowater*dlm*w(n)*fi(n)/DTT
END IF
!
DENOM = CCODTC * GCODTG - CCODTG * GCODTC
!
DTC = ( CCORHS * GCODTG - CCODTG * GCORHS ) / DENOM
DTG = ( CCODTC * GCORHS - CCORHS * GCODTC ) / DENOM
!CS Sun add following part here for inserting snow routing on 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
If ((TGS+DTG).le.273.16) Then
TGSNEW=(TGS+DTG)
ICASE=1
!cs Sun debug on 1998/12/14 end
! ------------------------------------------------------------------7272
h(NK)=( TGSNEW-273.16)*cto(n)*dzo(n)-fi(NK)*w(NK)*dlm*rhowater
Dh_DTT_DTG=(h(NK)-ho(NK))/DTT
tonm1=tssno(NK-1)
qkn=qk(n)
Else
DTG=273.16-TGS
DTC= (CCORHS - CCODTG*DTG)/CCODTC
fi(NK)=(GCODTC*DTC+GCODTG*DTG-GCORHS1)/(rhowater*dlm*w(n))*DTT
if (fi(NK).ge.0.0.and.fi(NK).le.1.0) then
h(NK)=-fi(n)*w(n)*dlm*rhowater
Dh_DTT_DTG=(h(NK)-ho(NK))/DTT
ICASE=2
tonm1=tssno(NK-1)
qkn=qk(n)
else if (fi(NK).lt.0.)then
h(NK)= -fi(NK)*w(NK)*dlm*rhowater
Dh_DTT_DTG=(h(NK)-ho(NK))/DTT
ICASE=3
tonm1=tssno(NK-1)
qkn=qk(n)
fff=fi(NK)
fi(NK)=0.0
end if
End if
END IF
!----------------------------------------------------------------------
! CHECK IF INTERCEPTION LOSS TERM HAS EXCEEDED CANOPY STORAGE
!----------------------------------------------------------------------
!
ECPOT = ( (ETC - EA) + (GETC - DEADTC)*DTC - DEADTG*DTG )
ECI = ECPOT * WC /(2.*RB) * RCP/PSY * DTT
ECIDIF=AMAX1(0.0,(ECI-CAPAC(1)*1.E3*HLAT))
ECI =AMIN1(ECI,( CAPAC(1)*1.E3*HLAT))
!
EGPOT = ( (ETGS - EA) + (GETGS - DEADTG)*DTG - DEADTC*DTC )
EGI = EGPOT * VCOVER(2) * WG/RD * RCP/PSY * DTT
EGIDIF=AMAX1(0.0,(EGI-CAPAC(2)*1.E3*HLAT))
EGI =AMIN1(EGI,( CAPAC(2)*1.E3*HLAT))
!
!----------------------------------------------------------------------
TGEN = TGS + DTG
TCEN = TC + DTC
D1 = 1./RA + 1./RB + 1./RD
TAEN = ( TGEN / RD + TCEN / RB + TM / RA *bps) / D1
!
HEND = ( TAEN - TM ) * RCP / RA + (ECIDIF + EGIDIF)/DTT
Y= TRIB - TAEN
II = II + 1
HT = HEND
IF ( II .GT. 20 ) GO TO 200
!CL IF ( II .GT. ITRUNK ) GO TO 200
!
!CL CALL NEWTON(TRIB,Y,FINC,NOX,NONPOS,IWALK,LX)
CALL NEWTON(TRIB,Y,FINC,NOX,NONPOS,IWALK,LX,ZINC,A2,Y1,ITEX)
!
IF(NOX.NE.1)GO TO 2000
200 CONTINUE
!CS Sun add following part here for inserting snow routing on 10/13/98
!cl 3000 IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
3000 IF (ISNOW.eq.0) THEN
IF (ICASE.eq.1.and.ik.eq.NK) THEN
tssn(NK)=TGS+DTG
END IF
If (ik.eq.NK) then
SNOFAC = HLAT / (HLAT + SNOMEL /1000.)
egidw = EGI*SNOFAC /HLAT/1000.
! egidw= EGI/HLAT/1000.
w(n)=w(n)-egidw
swe=swe-egidw
dzold=dzo(n)
dzo(n)=dzo(n)-egidw*rhowater/bwo(n)
!cs sun: following way to correct h(n) may lead to unballance of energy.
ho(n)=ho(n)*dzo(n)/dzold
capac(2)=swe
End if
CALL SNRESULT(DTT,IK,ICASE,WFSOIL,TSOIL,B1,B2,FFF,DELTH,WWW, &
ZDEPTH,POROS,BI,BIO,DZ,DZO,W,BW,BWO,H,HO,QK,BL,BT,CT, &
FI,FL,WF,TSSN,DLIQVOL,DICEVOL,SNROFF,HROFF,QSOIL)
END IF
57 CONTINUE
! ------------------------------------------------------------------7272
!clwp 11/17/2000, Li add following sentence to recalculate the snowdepth
SNOWDEPTH=DZO(1)+DZO(2)+DZO(3)
!clwp 11/17/2000, Li add above sentence to recalculate the snowdepth
!CS sun add following parts on 12/5/98 start
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
SWE=W(1)+W(2)+W(3)
CAPAC(2)=SWE
IF((DZ(1)+DZ(2)+DZ(3)).NE.0.0) THEN
SNOWDEN=(BW(1)*DZ(1)+BW(2)*DZ(2)+BW(3)*DZ(3)) &
/(DZ(1)+DZ(2)+DZ(3))
SNOWDEN=1000./SNOWDEN
ENDIF
ENDIF
!CS sun add above parts on 12/5/98 end
!----------------------------------------------------------------------
! EXIT FROM NON-NEUTRAL CALCULATION
!
! EVAPOTRANSPIRATION FLUXES CALCULATED FIRST ( J M-2 )
!----------------------------------------------------------------------
HRR = HR
IF ( FG .LT. .5 ) HRR = 1.
!cs SUn change RSURF = RSOIL*FG into followings: 02/03/99 start
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
RSURF = RSOIL
ELSE
RSURF = RSOIL*FG
END IF
!cs sun 03/02/99 end
!
COCT = (1.-WC)/RCC
COGT = VCOVER(2) * (1.-WG)/( RG + RD )
COGS1 = (1.-VCOVER(2)) / ( RD + RSURF ) * HRR &
+ VCOVER(2) / ( RD + RSURF + 44.) * HRR
COGS2 = COGS1 / HRR
!
ECT = ECPOT * COCT * RCP/PSY * DTT
!
EGT = EGPOT * COGT * RCP/PSY * DTT
EGS = (ETGS + GETGS*DTG ) * COGS1 &
- ( EA + DEADTG*DTG + DEADTC*DTC ) * COGS2
EGS = EGS * RCP/PSY * DTT
!CS Sun add following IF statement on 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) EGS=0.0
IF (ISNOW.eq.0) EGS=0.0
EGSMAX = WWW(1) / 2. * ZDEPTH(1) * POROS * HLAT * 1000.
EGIADD = AMAX1( 0., EGS - EGSMAX )
EGS = AMIN1 ( EGS, EGSMAX )
EGIDIF = EGIDIF + EGIADD
!
!----------------------------------------------------------------------
! SENSIBLE HEAT FLUX CALCULATED WITH LATENT HEAT FLUX CORRECTION
!----------------------------------------------------------------------
HC = HC + (HCDTC*DTC + HCDTG*DTG)*DTT + ECIDIF
HG = HG + (HGDTC*DTC + HGDTG*DTG)*DTT + EGIDIF
!----------------------------------------------------------------------
!
! TEST OF DEW CONDITION. LATENT HEAT FLUXES SET TO ZERO IF SIGN
! OF FLUX CHANGES OVER TIME STEP.EXCESS ENERGY DONATED TO SENSIBLE
! HEAT FLUX.
!----------------------------------------------------------------------
!
!cs Sun add following one statement IF (ISNOW.eq.0.and.MDLSNO.eq.0) go to
!cs 401 CONTINUE to skip folloing statements from
!CS ECF = SIGN( 1., ECPOT ) to 400 CONTINUE
!cl IF (ISNOW.eq.0.and.MDLSNO.eq.0) go to 401
IF (ISNOW.eq.0) go to 401
ECF = SIGN( 1., ECPOT )
EGF = SIGN( 1., EGPOT )
DEWC = FC * 2. - 1.
DEWG = FG * 2. - 1.
!
IF(DEWC*ECF.GT.0.0) GO TO 300
HC = HC + ECI + ECT
ECI = 0.
ECT = 0.
300 IF(DEWG*EGF.GT.0.0) GO TO 400
HG = HG + EGS + EGI + EGT
EGS = 0.
EGI = 0.
EGT = 0.
400 CONTINUE
401 CONTINUE
!
EC = ECI + ECT
EG = EGT + EGS + EGI
!
!----------------------------------------------------------------------
! ADJUSTMENT OF TEMPERATURES AND VAPOR PRESSURE , CALCULATION OF
! SENSIBLE HEAT FLUXES.
!----------------------------------------------------------------------
!
!cs sun add following new statement 02/04/99
TGSOLD=TGS
!cs sun end
TC = TCEN
TGS = TGEN
!CS Sun add following statement: 10/13/98
IF (ISNOW.eq.0) tssn(n)=TGS
!CS 10/13/98
TA = TAEN
EA = EA + DEADTC*DTC + DEADTG*DTG
!
RADT(1) = RADT(1) + RNCDTC*DTC + RNCDTG*DTG
RADT(2) = RADT(2) + RNGDTC*DTC + RNGDTG*DTG
!========================================================================
FLUP = FLUP - (RNCDTC+RNGDTC)*DTC - (RNCDTG+RNGDTG)*DTG
!========================================================================
!
! ** simulated net all-wave radiation **
! sibnet(nmm,ndd,nhh) = RADT(1) + RADT(2)
!
CHF = CCX / DTT * DTC
!cs sun change the original statement: on 12/14/98
!cs SHF = CG / DTT * DTG + TIMCON*CG*2. * ( TGS - TD)
!cs into following part where CG / DTT * DTG is replaced by Dh_DTT_DTG
IF (ISNOW.eq.0) THEN
SHF= Dh_DTT_DTG - dhp(n+1)+ qkn*(TGSOLD-tonm1) &
+qkn*DTG
ELSE
SHF = CG / DTT * DTG + TIMCON*CG*2. * ( TGS - TD )
END IF
!
ZLWUP = ZLWUP - RNCDTC * DTC / 2. &
- RNGDTG * DTG * (1.-VCOVER(1)*(1.-THERMK) )
!
IF ( TGS .GT. TF ) GO TO 500
EGS = EG - EGI
EGT = 0.
500 CONTINUE
!
VCOVER(2) = RESV2
D = RESD
Z0 = RESZ0
RDC = RESRDC
RBC = RESRBC
!CS Sun add next paragrapg to get soil surface temperature TGS 10/13/98
!cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
IF (ISNOW.eq.0) THEN
TGS=TSOIL
ATMP= (QSOIL+SOLSOIL)/CSOIL
BTMP=2.*3.1416/86400.
CTMP=CSOIL*BTMP/CSOIL/(365.*3.1416)**0.5
TGS=(TSOIL+ATMP*DTT+BTMP*DTT*TD/(1.+CTMP*DTT))/ &
(1.+BTMP*DTT*(1.-CTMP*DTT/(1.+CTMP*DTT)))
TD=(CTMP*DTT*TGS+TD)/(1.+CTMP*DTT)
END IF
!------------------------------------------------------
END SUBROUTINE TEMRS2
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE TPROPTY(THKSOIL,BWO,DZO,TKAIR,DZSOIL, THK,QK) 1
!
!=======================================================================
DIMENSION BWO(N1),DZO(N1),THK(N1),QK(N1)
!!!!! this is thermal conductivity for snow from R.Jordan(1991)(2.4)
do 37 i=1,n
thkice=2.290d0
thkair=2.30d-2
thk(i) = thkair+(7.75d-5 *bwo(i)+ 1.105d-6* &
bwo(i)*bwo(i))*(thkice -thkair)+0.1
37 continue
!!!!! calculate the ratio of thermal conductivity
!!!!! at the ineterface between two layers(2.7)
do 47 i=2,n
qk(i)=2.0*thk(i)*thk(i-1)/(thk(i)*dzo(i-1)+thk(i-1)*dzo(i))
47 continue
! YX2002 (test2) but do nothing at this stage
qk(1)= 2.0*thk(1)*thksoil/(thk(1)*dzsoil+thksoil*dzo(1))
!
!------------------------------------------------------
END SUBROUTINE TPROPTY
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE UPDAT1(DTT,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, & 1
EGS,EG,HC,HG,HFLUX,ETMASS,ROFF, &
NROOT,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF,ISNOW,WFSOIL,SWE,SNROFF,smelt)
!
!=======================================================================
!CS ------------------------------------------------------------------**
!
! UPDATING OF SOIL MOISTURE STORES AND INTERCEPTION CAPACITY
!-----------------------------------------------------------------------
DIMENSION EF(3)
!cl 2001,1,09 the following array were added after common blocks removed
DIMENSION WWW(3), CAPAC(2),SNOWW(2),ROOTD(2), ZDEPTH(3), ROOTP(3)
DIMENSION TEMW(3),TEMWP(3),TEMWPP(3),AAA(2),BBB(2),CCC(2),QQQ(2)
!
!----------------------------------------------------------------------
! EVAPORATION LOSSES ARE EXPRESSED IN J M-2 : WHEN DIVIDED BY
! ( HLAT*1000.) LOSS IS IN M M-2
! MASS TERMS ARE IN KG M-2 DT-1
!----------------------------------------------------------------------
!
SNOFAC = HLAT / ( HLAT + SNOMEL /1000. )
FACKS = 1.
IF ( (TC-DTC) .LE. TF ) FACKS = SNOFAC
IF ( (ECT+ECI) .GT. 0.) GO TO 100
ECI = ECT + ECI
ECT = 0.
FACKS = 1. / FACKS
100 CAPAC(1)=CAPAC(1) - ECI*FACKS/HLAT/1000.
!
ECMASS = ( ECT + ECI * FACKS ) / HLAT
!
!cs Sun add following statement IF (ISNOW.EQ.0) go to 201 on 12/5/98
IF (ISNOW.eq.0) FACKS = SNOFAC
IF (ISNOW.EQ.0) go to 201
FACKS = 1.
IF ( (TGS-DTG) .LE. TF ) FACKS = SNOFAC
IF ( (EGT+EGI) .GT. 0. ) GO TO 200
EGI = EGT + EGI
EGT = 0.
FACKS = 1. / FACKS
200 CAPAC(2)=CAPAC(2) - EGI*FACKS/HLAT/1000.
!
201 EGMASS = ( EGT + EGS + EGI * FACKS ) / HLAT
!
ETMASS = ECMASS + EGMASS
!
HFLUX = ( HC + HG ) / DTT
!----------------------------------------------------------------------
! DUMPING OF SMALL CAPAC VALUES ONTO SOIL SURFACE STORE
!----------------------------------------------------------------------
!
DO 1000 IVEG = 1, 2
IF ( CAPAC(IVEG) .GT. 0.000001 ) GO TO 1000
!cl Xue added the following line in August,2000
!cl FILTR = FILTR + CAPAC(IVEG)
WWW(1) = WWW(1) + CAPAC(IVEG) / ( POROS*ZDEPTH(1) )
CAPAC(IVEG) = 0.
1000 CONTINUE
!----------------------------------------------------------------------
! SNOWMELT / REFREEZE CALCULATION
!----------------------------------------------------------------------
!CS Sun Change following CALL SNOWM to SNOWM (ISNOW,wfsoil,swe)
!CS 10/13/98
!cl CALL SNOWM (MDLSNO,ISNOW,WFSOIL,SWE)
!CS 10/13/98
!=======================================================================
!
! CALCULATION OF SNOWMELT AND MODIFICATION OF TEMPERATURES
! N.B. THIS VERSION DEALS WITH REFREEZING OF WATER
!
!-----------------------------------------------------------------------
!
DO 6000 IVEG = 1, 2
!
!CS Sun Add following part for snow melting and water flux to soil(wfsoil)
!CS is greater zero 10/13/98
IF (ISNOW.EQ.0.and.IVEG.EQ.2) THEN
ZMELT= WFSOIL
WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
CAPAC(2)= SWE
GO TO 6000
END IF
!CS 10/13/98
CCT = CCX
TS = TC
DTS = DTC
FLUX = CHF
IF ( IVEG .EQ. 1 ) GO TO 110
CCT = CG
TS = TGS
DTS = DTG
FLUX = CCT * DTG / DTT
110 CONTINUE
!
TTA = TS - DTS
TTB = TS
SNOWW(IVEG) = 0.
IF ( TTA .LE. TF ) SNOWW(IVEG) = CAPAC(IVEG)
CAPAC(IVEG) = CAPAC(IVEG) - SNOWW(IVEG)
IF ( TTA .GT. TF .AND. TTB .GT. TF ) GO TO 120
IF ( TTA .LE. TF .AND. TTB .LE. TF ) GO TO 120
!
DTF = TF - TTA
DTIME1 = CCT * DTF / FLUX
HF = FLUX*(DTT-DTIME1)
FCAP = - CAPAC(IVEG) * SNOMEL
SPWET = AMIN1( 5. , SNOWW(IVEG) )
IF ( DTS .GT. 0. ) FCAP = SPWET * SNOMEL
DTIME2 = FCAP / FLUX
DTF2 = FLUX * (DTT-DTIME1-DTIME2)/CCT
TN = TF + DTF2
TS = TF - 0.1
IF (ABS(HF) .GE.ABS(FCAP) ) TS = TN
CHANGE = HF
IF (ABS(CHANGE) .GE.ABS(FCAP) ) CHANGE = FCAP
!
CHANGE = CHANGE / SNOMEL
!crr
IF (CHANGE.GT.0.0) SMELT=CHANGE+SMELT
!crr
SNOWW(IVEG) = SNOWW(IVEG) - CHANGE
CAPAC(IVEG) = CAPAC(IVEG) + CHANGE
!
IF ( IVEG .EQ. 1 ) TC = TS
IF ( IVEG .EQ. 2 ) TGS = TS
IF ( SNOWW(IVEG) .LT. 0.00001 ) GO TO 120
!cl ZMELT = 0.
! modified to force water into soil. Xue Feb. 1994
ZMELT = CAPAC(IVEG)
! IF ( TD .GT. TF ) ZMELT = CAPAC(IVEG)
!crr FILTR = FILTR+ ZMELT
WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
! IF ( TD .LE. TF ) ROFF = ROFF + CAPAC(IVEG)
CAPAC(IVEG) = 0.
120 CONTINUE
!
CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
6000 CONTINUE
! ------------------------------------------------------------
!CS Sun changes following statatement which is alwayes functioned
!CS in Xue's code 10/13/98
IF (ISNOW.NE.0) THEN
FLUXEF = SHF - CCT*DTG/DTT
TD = TD + FLUXEF / ( CG * 2. * SQRT ( PIE*365. ) ) * DTT
END IF
!CS ------------------------------------------------------------
!
! --- LOAD PILPS DATA
!
! if (change .gt. 0) snm(istat)=snm(istat)+(change*1000.)
change=0.0
!----------------------------------------------------------------------
! BARE SOIL EVAPORATION LOSS
!----------------------------------------------------------------------
!cl 2001,1,11 added the following line according to Xue, August 2000
!cl FILTR = FILTR - EGS / HLAT / 1000.
WWW(1) = WWW(1) - EGS / HLAT / 1000. / ( POROS * ZDEPTH(1) )
!
!----------------------------------------------------------------------
! EXTRACTION OF TRANSPIRATION LOSS FROM ROOT ZONE
!----------------------------------------------------------------------
!
DO 2000 IVEG = 1, 2
!
IF ( IVEG .EQ. 1 ) ABSOIL = ECT / HLAT / 1000.
IF ( IVEG .EQ. 2 ) ABSOIL = EGT / HLAT / 1000.
!cl 2001,1,09 added the following IF according to Xue, Aug 2000
IF (NROOT.EQ.1) THEN
EF(2) = 0.
EF(3) = 0.
TOTDEP = ZDEPTH(1)
!
DO 3000 IL = 2, 3
TOTDEP = TOTDEP + ZDEPTH(IL)
!
! DIV = AMAX1 ( 1., ( PHSOIL(IL) - PHL(IVEG) ) )
!
IF ( ROOTD(IVEG) .LT. TOTDEP ) GO TO 400
!
EF(IL) = ZDEPTH(IL) / ROOTD(IVEG)
GO TO 500
!
400 CONTINUE
EF(IL) = ROOTD(IVEG) - TOTDEP + ZDEPTH(IL)
EF(IL) = EF(IL) / ROOTD(IVEG)
GO TO 600
500 CONTINUE
3000 CONTINUE
!
600 EFT = EF(2) + EF(3)
EFT = MAX(EFT,0.1E-5)
EF(2) = EF(2) / EFT
EF(3) = EF(3) / EFT
DO 4000 IL = 2, 3
WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
4000 CONTINUE
ELSE
EF(1) = ROOTP(1)
EF(2) = ROOTP(2)
EF(3) = ROOTP(3)
DO 4004 IL = 1, 3
WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
4004 CONTINUE
END IF
2000 CONTINUE
!
!----------------------------------------------------------------------
!
! CALCULATION OF INTERFLOW, INFILTRATION EXCESS AND LOSS TO
! GROUNDWATER . ALL LOSSES ARE ASSIGNED TO VARIABLE 'ROFF' .
!
!----------------------------------------------------------------------
!
DO 5000 IL = 1, 2
IF ( WWW(IL) .GT. 0. ) GO TO 5000
WWW(IL+1) = WWW(IL+1) + WWW(IL) * ZDEPTH(IL)/ZDEPTH(IL+1)
WWW(IL) = 0.
5000 CONTINUE
! IF ( TD .LT. TF ) GO TO 800
!=======================================================================
!cl CALL RUN2
!cl 2001,1,09 substitute subroutine RUN2 by its full code
! calculation of interflow, infiltration excess and loss to
! groundwater . all losses are assigned to variable 'roff' .
!=======================================================================
do 8000 i = 1, 3
TEMW(I) = AMAX1( 0.03, WWW(I) )
TEMWP(I) = TEMW(I) ** ( -BEE )
TEMWPP(I) = AMIN1( 1., TEMW(I)) ** ( 2.*BEE+ 3. )
8000 CONTINUE
!-----------------------------------------------------------------------
!
! calculation of gravitationally driven drainage from w(3) : taken
! as an integral of time varying conductivity.addition of liston
! baseflow term to original q3g to insure flow in
! dry season. modified liston baseflow constant scaled
! by available water.
!
! q3g (q3) : equation (62) , SE-86
!
!-----------------------------------------------------------------------
POWS = 2.*BEE+2.
Q3G = TEMW(3)**(-POWS) + SATCO/ZDEPTH(3)/POROS*SLOPE*POWS*DTT
Q3G = Q3G ** ( 1. / POWS )
Q3G = - ( 1. / Q3G - WWW(3) ) * POROS * ZDEPTH(3) / DTT
Q3G = AMAX1( 0., Q3G )
Q3G = AMIN1( Q3G, WWW(3)*POROS*ZDEPTH(3)/DTT )
!
Q3G = Q3G + 0.002*POROS*ZDEPTH(3)*0.5 / 86400. * WWW(3)
!
!----------------------------------------------------------------------
!
! calculation of inter-layer exchanges of water due to gravitation
! and hydraulic gradient. the values of w(x) + dw(x) are used to
! calculate the potential gradients between layers.
! modified calculation of mean conductivities follows ME-82 ),
! reduces recharge flux to top layer.
!
! dpdw : estimated derivative of soil moisture potential
! with respect to soil wetness. assumption of
! gravitational drainage used to estimate likely
! minimum wetness over the time step.
!
! qqq (q ) : equation (61) , SE-86
! i,i+1
! -
! avk (k ) : equation (4.14) , ME-82
! i,i+1
!
!----------------------------------------------------------------------
!
WMAX = AMAX1( WWW(1), WWW(2), WWW(3), 0.05 )
WMAX = AMIN1( WMAX, 1. )
PMAX = WMAX**(-BEE)
WMIN = (PMAX-2./( PHSAT*(ZDEPTH(1)+2.*ZDEPTH(2)+ZDEPTH(3)))) &
**(-1./BEE)
WMIN = AMIN1( WWW(1), WWW(2), WWW(3), WMIN )
WMIN = AMAX1( WMIN, 0.02 )
PMIN = WMIN**(-BEE)
DPDW = PHSAT*( PMAX-PMIN )/( WMAX-WMIN )
!
do 8200 i = 1, 2
!
RSAME = 0.
AVK = TEMWP(I)*TEMWPP(I) - TEMWP(I+1)*TEMWPP(I+1)
DIV = TEMWP(I+1) - TEMWP(I)
IF ( ABS(DIV) .LT. 1.E-6 ) RSAME = 1.
AVK = SATCO*AVK / ( ( 1. + 3./BEE ) * DIV + RSAME )
AVKMIN = SATCO * AMIN1( TEMWPP(I), TEMWPP(I+1) )
AVKMAX = SATCO * AMAX1( TEMWPP(I), TEMWPP(I+1) )*1.01
AVK = AMAX1( AVK, AVKMIN )
AVK = AMIN1( AVK, AVKMAX )
!-----------------------------------------------------------------------
! conductivities and base flow reduced when temperature drops below
! freezing.
!-----------------------------------------------------------------------
!
TSNOW = AMIN1 ( TF-0.01, TGS )
AREAS = AMIN1 (0.999,13.2*SNOWW(2))
TGG = TSNOW*AREAS + TGS*(1.-AREAS)
TS = TGG*(2-I) + TD*(I-1)
PROPS = ( TS-(TF-10.) ) / 10.
! props = 1.+5*(ts-tf)
PROPS = AMAX1( 0.05, AMIN1( 1.0, PROPS ) )
AVK = AVK * PROPS
Q3G = Q3G * PROPS
!
!-----------------------------------------------------------------------
! backward implicit calculation of flows between soil layers.
!-----------------------------------------------------------------------
!
DPDWDZ = DPDW * 2./( ZDEPTH(I) + ZDEPTH(I+1) )
AAA(I) = 1. + AVK*DPDWDZ*( 1./ZDEPTH(I)+1./ZDEPTH(I+1) ) &
*DTT/POROS
BBB(I) =-AVK * DPDWDZ * 1./ZDEPTH(2)*DTT/POROS
CCC(I) = AVK * ( DPDWDZ * ( WWW(I)-WWW(I+1) ) + 1. + &
(I-1)*DPDWDZ*Q3G*1./ZDEPTH(3)*DTT/POROS )
8200 CONTINUE
!
DENOM = ( AAA(1)*AAA(2) - BBB(1)*BBB(2) )
RDENOM = 0.
IF ( ABS(DENOM) .LT. 1.E-6 ) RDENOM = 1.
RDENOM = ( 1.-RDENOM)/( DENOM + RDENOM )
QQQ(1) = ( AAA(2)*CCC(1) - BBB(1)*CCC(2) ) * RDENOM
QQQ(2) = ( AAA(1)*CCC(2) - BBB(2)*CCC(1) ) * RDENOM
!
!-----------------------------------------------------------------------
! update wetness of each soil moisture layer due to layer interflow
! and base flow.
!-----------------------------------------------------------------------
!
WWW(3) = WWW(3) - Q3G*DTT/(POROS*ZDEPTH(3))
ROFF = ROFF + Q3G * DTT
!
do 8300 i = 1, 2
!
QMAX = WWW(I) * (POROS*ZDEPTH(I) /DTT)
QMIN = -WWW(I+1) * (POROS*ZDEPTH(I+1)/DTT)
QQQ(I) = AMIN1( QQQ(I),QMAX)
QQQ(I) = AMAX1( QQQ(I),QMIN)
WWW(I) = WWW(I) - QQQ(I)/(POROS*ZDEPTH(I) /DTT)
WWW(I+1) = WWW(I+1) + QQQ(I)/(POROS*ZDEPTH(I+1)/DTT)
8300 continue
!
! --- LOAD water flow & root-zone drainage PILPS DATA
!crr SOILDIF=SOILDIF+ QQQ(1)* DTT *1000.
!crr SOILDRA=SOILDRA+ Q3G* DTT *1000.
!
do 8400 i = 1, 3
EXCESS = AMAX1(0.,(WWW(I) - 1.))
WWW(I) = WWW(I) - EXCESS
ROFF = ROFF + EXCESS * POROS*ZDEPTH(I)
!
! --- LOAD IN as root-drainage for PILPS
!crr IF (I.LT.2) THEN
!crr RNOFFS= RNOFFS+ 1000.*EXCESS*POROS*ZDEPTH(I)
!crr ELSE
!crr RNOFFB= RNOFFB+ 1000.*EXCESS*POROS*ZDEPTH(I)
!crr ENDIF
8400 continue
!-----------------------------------------------------------------------
! prevent negative values of www(i)
!-----------------------------------------------------------------------
!
do 8402 i = 1,2
DEFICIT = AMAX1 (0.,(1.E-12 - WWW(I)))
!crr IF (I.EQ.1) SOILDIF=SOILDIF-DEFICIT * ZDEPTH(1) * POROS
WWW (I) = WWW(I) + DEFICIT
WWW (I+1) = WWW(I+1) - DEFICIT * ZDEPTH(I) / ZDEPTH (I+1)
8402 CONTINUE
WWW(3) = AMAX1 (WWW(3),1.E-12)
! --------------------------------- end of subroutine RUN2 ------
800 CONTINUE
!
IF (WWW(1) .GT.1.) THEN
WWW(2) = WWW(2) + (WWW(1)-1.) * ZDEPTH(1) / ZDEPTH(2)
!crr SOILDIF=SOILDIF+(WWW(1)-1.)* ZDEPTH(1) * POROS *1000.
WWW(1) = 1.
END IF
If (WWW(2) .GT.1.) THEN
WWW(3) = WWW(3) + (WWW(2)-1.) * ZDEPTH(2) / ZDEPTH(3)
!
! --- LOAD IN AS PILP ROOT DRAINAGE
WWW(2) = 1.
END IF
IF (WWW(3) .GT.1.) THEN
ROFF = ROFF + (WWW(3)-1.)* ZDEPTH(3) * POROS
!crr RNOFFB=RNOFFB + (WWW(3)-1.)* ZDEPTH(3) * POROS *1000.
WWW(3) = 1.
END IF
!
!------------------------------------------------------
END SUBROUTINE UPDAT1
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE UPDAT1_ICE(DTT,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, & 1
EGS,EG,HC,HG,HFLUX,ETMASS,FILTR,SOILDIF,SOILDRA,ROFF, &
RNOFFB,RNOFFS,NROOT,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF,SMELT)
! 12 AUGUST 2000
!=======================================================================
!
! UPDATING OF SOIL MOISTURE STORES AND INTERCEPTION CAPACITY
!
!-----------------------------------------------------------------------
!----------------------------------------------------------------------
REAL, DIMENSION (2) :: CAPAC, SNOWW, ROOTD, aaa, bbb, ccc, qqq
REAL, DIMENSION (3) :: WWW, EF, ZDEPTH, ROOTP, temw, temwp, temwpp
!
!----------------------------------------------------------------------
! EVAPORATION LOSSES ARE EXPRESSED IN J M-2 : WHEN DIVIDED BY
! ( HLAT*1000.) LOSS IS IN M M-2
! MASS TERMS ARE IN KG M-2 DT-1
!----------------------------------------------------------------------
!
SNOFAC = HLAT / ( HLAT + SNOMEL /1000. )
FACKS = 1.
IF ( (TC-DTC) .LE. TF ) FACKS = SNOFAC
IF ( (ECT+ECI) .GT. 0.) GO TO 100
ECI = ECT + ECI
ECT = 0.
FACKS = 1. / FACKS
100 CAPAC(1)=CAPAC(1) - ECI*FACKS/HLAT/1000.
!
ECMASS = ( ECT + ECI * FACKS ) / HLAT
!
FACKS = 1.
IF ( (TGS-DTG) .LE. TF ) FACKS = SNOFAC
IF ( (EGT+EGI) .GT. 0. ) GO TO 200
EGI = EGT + EGI
EGT = 0.
FACKS = 1. / FACKS
200 CAPAC(2)=CAPAC(2) - EGI*FACKS/HLAT/1000.
!
EGMASS = ( EGT + EGS + EGI * FACKS ) / HLAT
!
ETMASS = ECMASS + EGMASS
!
HFLUX = ( HC + HG )
!
!----------------------------------------------------------------------
! DUMPING OF SMALL CAPAC VALUES ONTO SOIL SURFACE STORE
!----------------------------------------------------------------------
!
DO 1000 IVEG = 1, 2
IF ( CAPAC(IVEG) .GT. 0.000001 ) GO TO 300
FILTR = FILTR + CAPAC(IVEG)
WWW(1) = WWW(1) + CAPAC(IVEG) / ( POROS*ZDEPTH(1) )
CAPAC(IVEG) = 0.
300 CONTINUE
1000 CONTINUE
!----------------------------------------------------------------------
! SNOWMELT / REFREEZE CALCULATION
!----------------------------------------------------------------------
!
! CALCULATION OF SNOWMELT AND MODIFICATION OF TEMPERATURES
! N.B. THIS VERSION DEALS WITH REFREEZING OF WATER
!
!-----------------------------------------------------------------------
!
DO 7000 IVEG = 1, 2
!
CCT = CCX
TS = TC
DTS = DTC
FLUX = CHF
IF ( IVEG .EQ. 1 ) GO TO 7100
CCT = CG
TS = TGS
DTS = DTG
FLUX = CCT * DTG / DTT
7100 CONTINUE
!
TTA = TS - DTS
TTB = TS
SNOWW(IVEG) = 0.
IF ( TTA .LE. TF ) SNOWW(IVEG) = CAPAC(IVEG)
CAPAC(IVEG) = CAPAC(IVEG) - SNOWW(IVEG)
IF ( TTA .GT. TF .AND. TTB .GT. TF ) GO TO 7200
IF ( TTA .LE. TF .AND. TTB .LE. TF ) GO TO 7200
!
DTF = TF - TTA
DTIME1 = CCT * DTF / FLUX
HF = FLUX*(DTT-DTIME1)
FCAP = - CAPAC(IVEG) * SNOMEL
SPWET = AMIN1( 5. , SNOWW(IVEG) )
IF ( DTS .GT. 0. ) FCAP = SPWET * SNOMEL
DTIME2 = FCAP / FLUX
DTF2 = FLUX * (DTT-DTIME1-DTIME2)/CCT
TN = TF + DTF2
TS = TF - 0.1
IF (ABS(HF) .GE.ABS(FCAP) ) TS = TN
CHANGE = HF
IF (ABS(CHANGE) .GE.ABS(FCAP) ) CHANGE = FCAP
!
CHANGE = CHANGE / SNOMEL
!
IF (CHANGE.GT.0.0) SMELT=CHANGE+SMELT
!
SNOWW(IVEG) = SNOWW(IVEG) - CHANGE
CAPAC(IVEG) = CAPAC(IVEG) + CHANGE
!
IF ( IVEG .EQ. 1 ) TC = TS
IF ( IVEG .EQ. 2 ) TGS = TS
IF ( SNOWW(IVEG) .LT. 0.00001 ) GO TO 7200
ZMELT = 0.
! modified to force water into soil. Xue Feb. 1994
ZMELT = CAPAC(IVEG)
FILTR = FILTR+ ZMELT
WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
CAPAC(IVEG) = 0.
7200 CONTINUE
!
CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
!
7000 CONTINUE
!
FLUXEF = SHF - CCT*DTG/DTT
TD = TD + FLUXEF / ( CG * 2. * SQRT ( PIE*365. ) ) * DTT
!
change=0.0
!
!----------------------------------------------------------------------
! BARE SOIL EVAPORATION LOSS
!----------------------------------------------------------------------
!
FILTR = FILTR - EGS / HLAT / 1000.
WWW(1) = WWW(1) - EGS / HLAT / 1000. / ( POROS * ZDEPTH(1) )
!
!----------------------------------------------------------------------
! EXTRACTION OF TRANSPIRATION LOSS FROM ROOT ZONE
!----------------------------------------------------------------------
!
DO 2000 IVEG = 1, 2
!
IF ( IVEG .EQ. 1 ) ABSOIL = ECT / HLAT / 1000.
IF ( IVEG .EQ. 2 ) ABSOIL = EGT / HLAT / 1000.
!
IF (NROOT.EQ.1) THEN
EF(2) = 0.
EF(3) = 0.
TOTDEP = ZDEPTH(1)
!
DO 3000 IL = 2, 3
TOTDEP = TOTDEP + ZDEPTH(IL)
!
IF ( ROOTD(IVEG) .LT. TOTDEP ) GO TO 400
!
EF(IL) = ZDEPTH(IL) / ROOTD(IVEG)
GO TO 500
!
400 CONTINUE
EF(IL) = ROOTD(IVEG) - TOTDEP + ZDEPTH(IL)
EF(IL) = EF(IL) / ROOTD(IVEG)
GO TO 600
!
500 CONTINUE
3000 CONTINUE
!
600 EFT = EF(2) + EF(3)
!
EFT = MAX(EFT,0.1E-5)
!
EF(2) = EF(2) / EFT
EF(3) = EF(3) / EFT
!
DO 4000 IL = 2, 3
WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
4000 CONTINUE
ELSE
EF(1) = ROOTP(1)
EF(2) = ROOTP(2)
EF(3) = ROOTP(3)
DO 4004 IL = 1, 3
WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
4004 CONTINUE
END IF
!
2000 CONTINUE
!
!----------------------------------------------------------------------
!
! CALCULATION OF INTERFLOW, INFILTRATION EXCESS AND LOSS TO
! GROUNDWATER . ALL LOSSES ARE ASSIGNED TO VARIABLE 'ROFF' .
!
!----------------------------------------------------------------------
!
DO 5000 IL = 1, 2
IF ( WWW(IL) .GT. 0. ) GO TO 700
WWW(IL+1) = WWW(IL+1) + WWW(IL) * ZDEPTH(IL)/ZDEPTH(IL+1)
WWW(IL) = 0.
700 CONTINUE
5000 CONTINUE
!
!=======================================================================
! calculation of interflow, infiltration excess and loss to
! groundwater . all losses are assigned to variable 'roff' .
!----------------------------------------------------------------------
!
do 8000 i = 1, 3
!
TEMW(I) = AMAX1( 0.03, WWW(I) )
TEMWP(I) = TEMW(I) ** ( -BEE )
TEMWPP(I) = AMIN1( 1., TEMW(I)) ** ( 2.*BEE+ 3. )
8000 CONTINUE
!
!-----------------------------------------------------------------------
!
! calculation of gravitationally driven drainage from w(3) : taken
! as an integral of time varying conductivity.addition of liston
! baseflow term to original q3g to insure flow in
! dry season. modified liston baseflow constant scaled
! by available water.
!
! q3g (q3) : equation (62) , SE-86
!
!-----------------------------------------------------------------------
!
POWS = 2.*BEE+2.
Q3G = TEMW(3)**(-POWS) + SATCO/ZDEPTH(3)/POROS*SLOPE*POWS*DTT
Q3G = Q3G ** ( 1. / POWS )
Q3G = - ( 1. / Q3G - WWW(3) ) * POROS * ZDEPTH(3) / DTT
Q3G = AMAX1( 0., Q3G )
Q3G = AMIN1( Q3G, WWW(3)*POROS*ZDEPTH(3)/DTT )
!
Q3G = Q3G + 0.002*POROS*ZDEPTH(3)*0.5 / 86400. * WWW(3)
!
!----------------------------------------------------------------------
!
! calculation of inter-layer exchanges of water due to gravitation
! and hydraulic gradient. the values of w(x) + dw(x) are used to
! calculate the potential gradients between layers.
! modified calculation of mean conductivities follows ME-82 ),
! reduces recharge flux to top layer.
!
! dpdw : estimated derivative of soil moisture potential
! with respect to soil wetness. assumption of
! gravitational drainage used to estimate likely
! minimum wetness over the time step.
!
! qqq (q ) : equation (61) , SE-86
! i,i+1
! -
! avk (k ) : equation (4.14) , ME-82
! i,i+1
!
!----------------------------------------------------------------------
!
WMAX = AMAX1( WWW(1), WWW(2), WWW(3), 0.05 )
WMAX = AMIN1( WMAX, 1. )
PMAX = WMAX**(-BEE)
WMIN = (PMAX-2./( PHSAT*(ZDEPTH(1)+2.*ZDEPTH(2)+ZDEPTH(3)))) &
**(-1./BEE)
WMIN = AMIN1( WWW(1), WWW(2), WWW(3), WMIN )
WMIN = AMAX1( WMIN, 0.02 )
PMIN = WMIN**(-BEE)
DPDW = PHSAT*( PMAX-PMIN )/( WMAX-WMIN )
!
DO 8200 I = 1, 2
!
RSAME = 0.
AVK = TEMWP(I)*TEMWPP(I) - TEMWP(I+1)*TEMWPP(I+1)
DIV = TEMWP(I+1) - TEMWP(I)
IF ( ABS(DIV) .LT. 1.E-6 ) RSAME = 1.
AVK = SATCO*AVK / ( ( 1. + 3./BEE ) * DIV + RSAME )
AVKMIN = SATCO * AMIN1( TEMWPP(I), TEMWPP(I+1) )
AVKMAX = SATCO * AMAX1( TEMWPP(I), TEMWPP(I+1) )*1.01
AVK = AMAX1( AVK, AVKMIN )
AVK = AMIN1( AVK, AVKMAX )
!
!-----------------------------------------------------------------------
! conductivities and base flow reduced when temperature drops below
! freezing.
!-----------------------------------------------------------------------
!
TSNOW = AMIN1 ( TF-0.01, TGS )
AREAS = AMIN1 (0.999,13.2*SNOWW(2))
TGG = TSNOW*AREAS + TGS*(1.-AREAS)
TS = TGG*(2-I) + TD*(I-1)
PROPS = ( TS-(TF-10.) ) / 10.
PROPS = AMAX1( 0.05, AMIN1( 1.0, PROPS ) )
AVK = AVK * PROPS
Q3G = Q3G * PROPS
!
!-----------------------------------------------------------------------
! backward implicit calculation of flows between soil layers.
!-----------------------------------------------------------------------
!
DPDWDZ = DPDW * 2./( ZDEPTH(I) + ZDEPTH(I+1) )
AAA(I) = 1. + AVK*DPDWDZ*( 1./ZDEPTH(I)+1./ZDEPTH(I+1) ) &
*DTT/POROS
BBB(I) =-AVK * DPDWDZ * 1./ZDEPTH(2)*DTT/POROS
CCC(I) = AVK * ( DPDWDZ * ( WWW(I)-WWW(I+1) ) + 1. + &
(I-1)*DPDWDZ*Q3G*1./ZDEPTH(3)*DTT/POROS )
8200 CONTINUE
!
DENOM = ( AAA(1)*AAA(2) - BBB(1)*BBB(2) )
RDENOM = 0.
IF ( ABS(DENOM) .LT. 1.E-6 ) RDENOM = 1.
RDENOM = ( 1.-RDENOM)/( DENOM + RDENOM )
QQQ(1) = ( AAA(2)*CCC(1) - BBB(1)*CCC(2) ) * RDENOM
QQQ(2) = ( AAA(1)*CCC(2) - BBB(2)*CCC(1) ) * RDENOM
!
!-----------------------------------------------------------------------
! update wetness of each soil moisture layer due to layer interflow
! and base flow.
!-----------------------------------------------------------------------
!
WWW(3) = WWW(3) - Q3G*DTT/(POROS*ZDEPTH(3))
ROFF = ROFF + Q3G * DTT
!
DO 8300 I = 1, 2
!
QMAX = WWW(I) * (POROS*ZDEPTH(I) /DTT)
QMIN = -WWW(I+1) * (POROS*ZDEPTH(I+1)/DTT)
QQQ(I) = AMIN1( QQQ(I),QMAX)
QQQ(I) = AMAX1( QQQ(I),QMIN)
WWW(I) = WWW(I) - QQQ(I)/(POROS*ZDEPTH(I) /DTT)
WWW(I+1) = WWW(I+1) + QQQ(I)/(POROS*ZDEPTH(I+1)/DTT)
8300 CONTINUE
!
! *** LOAD water flow & root-zone drainage PILPS DATA
SOILDIF=SOILDIF+QQQ(1)*DTT*1000.
SOILDRA=SOILDRA+Q3G*DTT*1000.
!
DO 8400 I = 1, 3
EXCESS = AMAX1(0.,(WWW(I) - 1.))
WWW(I) = WWW(I) - EXCESS
ROFF = ROFF + EXCESS * POROS*ZDEPTH(I)
!
! *** LOAD IN as root-drainage for PILPS
IF (I.LT.2) THEN
RNOFFS= RNOFFS+ 1000.*EXCESS*POROS*ZDEPTH(I)
ELSE
RNOFFB= RNOFFB+ 1000.*EXCESS*POROS*ZDEPTH(I)
ENDIF
8400 CONTINUE
!
!-----------------------------------------------------------------------
! prevent negative values of www(i)
!-----------------------------------------------------------------------
!
DO 8402 I = 1,2
DEFICIT = AMAX1 (0.,(1.E-12 - WWW(I)))
IF (I.EQ.1) SOILDIF=SOILDIF-DEFICIT* &
ZDEPTH(1)*POROS
WWW (I) = WWW(I) + DEFICIT
WWW (I+1) = WWW(I+1) - DEFICIT * ZDEPTH(I) / ZDEPTH (I+1)
8402 CONTINUE
WWW(3) = AMAX1 (WWW(3),1.E-12)
!
800 CONTINUE
!
IF (WWW(1) .GT.1.) THEN
WWW(2) = WWW(2) + (WWW(1)-1.) * ZDEPTH(1)/ &
ZDEPTH(2)
SOILDIF=SOILDIF+(WWW(1)-1.)*ZDEPTH(1) &
*POROS*1000.
WWW(1) = 1.
END IF
If (WWW(2) .GT.1.) WWW(3) = WWW(3) + (WWW(2)-1.) * &
ZDEPTH(2) / ZDEPTH(3)
!
! *** LOAD IN AS PILP ROOT DRAINAGE
IF (WWW(2) .GT.1.) WWW(2) = 1.
IF (WWW(3) .GT.1.) THEN
ROFF = ROFF + (WWW(3)-1.)*POROS*ZDEPTH(3)
RNOFFB=RNOFFB+((WWW(3)-1.)*ZDEPTH(3)* &
POROS*1000.)
WWW(3) = 1.
END IF
!
!------------------------------------------------------
END SUBROUTINE UPDAT1_ICE
!------------------------------------------------------
!=======================================================================
!
SUBROUTINE CONVDIM(IOFLAG, & 2
DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, &
DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, &
DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, &
DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, &
DZO, WO, TSSN, TSSNO, BWO, BTO, CTO, FIO, FLO, BIO, BLO, HO )
!
!=======================================================================
! Ratko Oct., 2007
!----------------------------------------------------------------------
REAL, DIMENSION (4) :: DZO,WO,TSSN,TSSNO,BWO,BTO,CTO,FIO,FLO,BIO,BLO,HO
IF (IOFLAG.EQ.0) THEN ! variable to array
DZO (1) = DZO1
WO (1) = WO1
TSSN (1) = TSSN1
TSSNO (1) = TSSNO1
BWO (1) = BWO1
BTO (1) = BTO1
CTO (1) = CTO1
FIO (1) = FIO1
FLO (1) = FLO1
BIO (1) = BIO1
BLO (1) = BLO1
HO (1) = HO1
DZO (2) = DZO2
WO (2) = WO2
TSSN (2) = TSSN2
TSSNO (2) = TSSNO2
BWO (2) = BWO2
BTO (2) = BTO2
CTO (2) = CTO2
FIO (2) = FIO2
FLO (2) = FLO2
BIO (2) = BIO2
BLO (2) = BLO2
HO (2) = HO2
DZO (3) = DZO3
WO (3) = WO3
TSSN (3) = TSSN3
TSSNO (3) = TSSNO3
BWO (3) = BWO3
BTO (3) = BTO3
CTO (3) = CTO3
FIO (3) = FIO3
FLO (3) = FLO3
BIO (3) = BIO3
BLO (3) = BLO3
HO (3) = HO3
DZO (4) = DZO4
WO (4) = WO4
TSSN (4) = TSSN4
TSSNO (4) = TSSNO4
BWO (4) = BWO4
BTO (4) = BTO4
CTO (4) = CTO4
FIO (4) = FIO4
FLO (4) = FLO4
BIO (4) = BIO4
BLO (4) = BLO4
HO (4) = HO4
ELSEIF (IOFLAG.EQ.1) THEN ! array to variable
DZO1 = DZO(1)
WO1 = WO(1)
TSSN1 = TSSN(1)
TSSNO1 = TSSNO(1)
BWO1 = BWO(1)
BTO1 = BTO(1)
CTO1 = CTO(1)
FIO1 = FIO(1)
FLO1 = FLO(1)
BIO1 = BIO(1)
BLO1 = BLO(1)
HO1 = HO(1)
DZO2 = DZO(2)
WO2 = WO(2)
TSSN2 = TSSN(2)
TSSNO2 = TSSNO(2)
BWO2 = BWO(2)
BTO2 = BTO(2)
CTO2 = CTO(2)
FIO2 = FIO(2)
FLO2 = FLO(2)
BIO2 = BIO(2)
BLO2 = BLO(2)
HO2 = HO(2)
DZO3 = DZO(3)
WO3 = WO(3)
TSSN3 = TSSN(3)
TSSNO3 = TSSNO(3)
BWO3 = BWO(3)
BTO3 = BTO(3)
CTO3 = CTO(3)
FIO3 = FIO(3)
FLO3 = FLO(3)
BIO3 = BIO(3)
BLO3 = BLO(3)
HO3 = HO(3)
DZO4 = DZO(4)
WO4 = WO(4)
TSSN4 = TSSN(4)
TSSNO4 = TSSNO(4)
BWO4 = BWO(4)
BTO4 = BTO(4)
CTO4 = CTO(4)
FIO4 = FIO(4)
FLO4 = FLO(4)
BIO4 = BIO(4)
BLO4 = BLO(4)
HO4 = HO(4)
ELSE
print*,'something wrong in CONVDIM',IOFLAG
STOP
ENDIF
!------------------------------------------------------
END SUBROUTINE CONVDIM
!------------------------------------------------------
END MODULE module_sf_ssib