/wrfv2_fire/phys/module_sf_ssib.F
FORTRAN Legacy | 6529 lines | 4263 code | 79 blank | 2187 comment | 60 complexity | 0731473777a90263eb0524243f12f129 MD5 | raw file
Possible License(s): AGPL-1.0
- MODULE module_sf_ssib
- !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, &
- 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
- PLANTR=RCC
- 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 &
- ( 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.
- !
- CAPAC(1)=SNOB
- CAPAC(2)=SNOA
- SNOWDEN = 3.75 ! mchen add for initialization
- 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
- PLANTR=RCC
- 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 &
- ,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)
- ! 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, &
- 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, &
- 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, &
- 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)
- !
- !=======================================================================
- !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, &
- 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, &
- 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, &
- 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)
- !
- !=======================================================================
- 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, &
- 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, &
- 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, &
- 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)
- !
- !=======================================================================
- !
- !-----------------------------------------------------------------------
- ! ** 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, &
- 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, &
- 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, &
- 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, &
- 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)
- !
- !=======================================================================
- 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, &
- 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, &
- 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, &
- 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
- print*, ' Snow Temp. Wrong in thermal.f',i,tssn(i)
- tssn(i)=273.16
- STOP
- 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, &
- 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 &
- (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 &
- (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 rplaced 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)
- !
- !=======================================================================
- 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, &
- 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, &
- 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, &
- 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