| blob | 8e968b2f0abd0b2b93750ae2905e0b9ae9889e4e |
1 MODULE module_sf_ssib
2 !This version of SSiB land-surface model includes a multi-layer snow scheme
3 !For better results, please use the SSiB vegetation map (geog_data_res in WPS)
4 !References for the SSiB:
5 !Xue et al. 1991, J. Climate, 4, 345-364.
6 !Sun and Xue, 2001, Adv. in Atmos. Sci, 18, 335-354.
7 !Xue et al., 2003, J. Geophy. Res. 108, D22, doi: 10.1029/2002JD003174.
8 !Coding by Fernando De Sales and Zhengxin Liu (2011)
10 REAL, PARAMETER :: CPAIR = 1004.6 &
11 ,STEFAN = 5.669 * 10E-9 &
12 ,GRAV = 9.81 &
13 ,VKC = 0.4 &
14 ,PIE = 3.14159265 &
15 ,TIMCON = PIE/86400. &
16 ,CLAI = 4.2 * 1000. * 0.2 &
17 ,CW = 4.2 * 1000. * 1000. &
18 ,TF = 273.16 &
19 ,GASR = 287.05 &
20 ,HLAT = 2.52E6 &
21 ,SNOMEL = 370518.5 * 1000.
22 INTEGER, PARAMETER :: ITRUNK = 3
24 !crr snow
25 REAL, PARAMETER :: SSISNOW = 0.04 &
26 ,FLMIN = 0.03 &
27 ,FLMAX = 0.10 &
28 ,DZMIN = 0.002 &
29 ,WOMIN = 0.0004 &
30 ,CL = 4212.7 &
31 ,DLM = 3.335d5 &
32 ,RHOWATER = 1000.0 &
33 ,DICE = 920.0 &
34 ,DKSATSNOW= 0.01 &
35 ,SNODEP_CR= 0.07
36 INTEGER, PARAMETER :: N = 3 &
37 ,N1 = 4 &
38 ,N2 = 4
39 !crr snow
40 !ssib vegetation parameters
41 REAL, DIMENSION (13,2,3,2) :: tran0,ref0
42 REAL, DIMENSION (13,12,2) :: green0,vcover0,zlt0
43 REAL, DIMENSION (13,2,3) :: rstpar0
44 REAL, DIMENSION (13,12) :: z000,d0,z20,z10,rdc0,rbc0
45 REAL, DIMENSION (13,3) :: depth0,soref0
46 REAL, DIMENSION (13,2) :: chil0,topt0,tl0,tu0,defac0,ph10,ph20,rootd0
47 REAL, DIMENSION (13) :: bee0,phsat0,poros0,satco0,slope0
48 !
49 data tran0/ &
50 0.5000000E-01, 0.5000000E-01, 0.5000000E-01, 0.5000000E-01, &
51 0.5000000E-01, 0.5000000E-01, 0.7000000E-01, 0.5000000E-01, &
52 0.5000000E-01, 0.5000000E-01, 0.1000000E-02, 0.5000000E-01, &
53 0.1000000E-02, &
54 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
55 0.1000000E-02, 0.7000000E-01, 0.1000000E-02, 0.7000000E-01, &
56 0.1000000E-02, 0.7000000E-01, 0.1000000E-02, 0.7000000E-01, &
57 0.1000000E-02, &
58 0.2500000E+00, 0.2500000E+00, 0.1500000E+00, 0.1000000E+00, &
59 0.1000000E+00, 0.2500000E+00, 0.2475000E+00, 0.2500000E+00, &
60 0.2500000E+00, 0.2500000E+00, 0.1000000E-02, 0.2500000E+00, &
61 0.1000000E-02, &
62 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
63 0.1000000E-02, 0.2475000E+00, 0.1000000E-02, 0.2475000E+00, &
64 0.1000000E-02, 0.2475000E+00, 0.1000000E-02, 0.2475000E+00, &
65 0.1000000E-02, &
66 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
67 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
68 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
69 0.0000000E+00, &
70 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
71 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
72 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
73 0.0000000E+00, &
74 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
75 0.1000000E-02, 0.1000000E-02, 0.2200000E+00, 0.1000000E-02, &
76 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
77 0.1000000E-02, &
78 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
79 0.1000000E-02, 0.2200000E+00, 0.1000000E-02, 0.2200000E+00, &
80 0.1000000E-02, 0.2200000E+00, 0.1000000E-02, 0.2200000E+00, &
81 0.1000000E-02, &
82 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
83 0.1000000E-02, 0.1000000E-02, 0.3750000E+00, 0.1000000E-02, &
84 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
85 0.1000000E-02, &
86 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
87 0.1000000E-02, 0.3750000E+00, 0.1000000E-02, 0.3750000E+00, &
88 0.1000000E-02, 0.3750000E+00, 0.1000000E-02, 0.3750000E+00, &
89 0.1000000E-02, &
90 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
91 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
92 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
93 0.0000000E+00, &
94 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
95 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
96 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
97 0.0000000E+00/
98 data ref0/ &
99 0.1000000E+00, 0.1000000E+00, 0.7000000E-01, 0.7000000E-01, &
100 0.7000000E-01, 0.1000000E+00, 0.1050000E+00, 0.1000000E+00, &
101 0.1000000E+00, 0.1000000E+00, 0.1000000E-02, 0.1000000E+00, &
102 0.1000000E-02, &
103 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
104 0.1000000E-02, 0.1050000E+00, 0.1000000E-02, 0.1050000E+00, &
105 0.1000000E-02, 0.1050000E+00, 0.1000000E-02, 0.1050000E+00, &
106 0.1000000E-02, &
107 0.4500000E+00, 0.4500000E+00, 0.4000000E+00, 0.3500000E+00, &
108 0.3500000E+00, 0.4500000E+00, 0.5775000E+00, 0.4500000E+00, &
109 0.4500000E+00, 0.4500000E+00, 0.1000000E-02, 0.4500000E+00, &
110 0.1000000E-02, &
111 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
112 0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
113 0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
114 0.1000000E-02, &
115 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
116 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
117 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
118 0.0000000E+00, &
119 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
120 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
121 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
122 0.0000000E+00, &
123 0.1600000E+00, 0.1600000E+00, 0.1600000E+00, 0.1600000E+00, &
124 0.1600000E+00, 0.1600000E+00, 0.3600000E+00, 0.1600000E+00, &
125 0.1600000E+00, 0.1600000E+00, 0.1000000E-02, 0.1600000E+00, &
126 0.1000000E-02, &
127 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
128 0.1000000E-02, 0.3600000E+00, 0.1000000E-02, 0.3600000E+00, &
129 0.1000000E-02, 0.3600000E+00, 0.1000000E-02, 0.3600000E+00, &
130 0.1000000E-02, &
131 0.3900000E+00, 0.3900000E+00, 0.3900000E+00, 0.3900000E+00, &
132 0.3900000E+00, 0.3900000E+00, 0.5775000E+00, 0.3900000E+00, &
133 0.3900000E+00, 0.3900000E+00, 0.1000000E-02, 0.3900000E+00, &
134 0.1000000E-02, &
135 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, 0.1000000E-02, &
136 0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
137 0.1000000E-02, 0.5775000E+00, 0.1000000E-02, 0.5775000E+00, &
138 0.1000000E-02, &
139 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
140 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
141 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
142 0.0000000E+00, &
143 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
144 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
145 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
146 0.0000000E+00/
147 data green0/ &
148 0.9050000E+00, 0.2564000E-01, 0.8680600E+00, 0.9132400E+00, &
149 0.2475200E+00, 0.6319100E+00, 0.5681800E+00, 0.7978700E+00, &
150 0.8364300E+00, 0.4512600E+00, 0.1000000E-03, 0.2083300E+00, &
151 0.1000000E-03, &
152 0.9050000E+00, 0.2564000E-01, 0.8717700E+00, 0.9170300E+00, &
153 0.2475200E+00, 0.6566600E+00, 0.6218900E+00, 0.5319100E+00, &
154 0.7172100E+00, 0.4512600E+00, 0.1000000E-03, 0.2083300E+00, &
155 0.1000000E-03, &
156 0.9050000E+00, 0.4153800E+00, 0.8847300E+00, 0.9226600E+00, &
157 0.2475200E+00, 0.5176000E+00, 0.6637200E+00, 0.3623200E+00, &
158 0.2577300E+00, 0.4512600E+00, 0.1000000E-03, 0.4411800E+00, &
159 0.1000000E-03, &
160 0.9050000E+00, 0.7594900E+00, 0.9061000E+00, 0.9247000E+00, &
161 0.6637200E+00, 0.6527400E+00, 0.6972100E+00, 0.5681800E+00, &
162 0.7246400E+00, 0.4512600E+00, 0.1000000E-03, 0.7594900E+00, &
163 0.1000000E-03, &
164 0.9050000E+00, 0.8875700E+00, 0.9164200E+00, 0.9266400E+00, &
165 0.8104700E+00, 0.6527400E+00, 0.8104700E+00, 0.5681800E+00, &
166 0.1736100E+00, 0.4512600E+00, 0.1000000E-03, 0.8875700E+00, &
167 0.1000000E-03, &
168 0.9050000E+00, 0.9252000E+00, 0.9259300E+00, 0.9045800E+00, &
169 0.8680600E+00, 0.7246400E+00, 0.9079900E+00, 0.5681800E+00, &
170 0.5681800E+00, 0.6218900E+00, 0.1000000E-03, 0.9252000E+00, &
171 0.1000000E-03, &
172 0.9050000E+00, 0.8364300E+00, 0.9293700E+00, 0.9021600E+00, &
173 0.6040900E+00, 0.8712500E+00, 0.8132000E+00, 0.5681800E+00, &
174 0.5681800E+00, 0.9200800E+00, 0.1000000E-03, 0.8364300E+00, &
175 0.1000000E-03, &
176 0.9050000E+00, 0.6967200E+00, 0.8209400E+00, 0.9126500E+00, &
177 0.5854000E+00, 0.7966000E+00, 0.3943200E+00, 0.8680600E+00, &
178 0.7246400E+00, 0.6970300E+00, 0.1000000E-03, 0.6967200E+00, &
179 0.1000000E-03, &
180 0.9050000E+00, 0.3306900E+00, 0.7123000E+00, 0.8982800E+00, &
181 0.4990000E+00, 0.7654600E+00, 0.4434600E+00, 0.6505600E+00, &
182 0.8403400E+00, 0.7567000E-01, 0.1000000E-03, 0.3439200E+00, &
183 0.1000000E-03, &
184 0.9050000E+00, 0.1656400E+00, 0.6145700E+00, 0.8548200E+00, &
185 0.3834400E+00, 0.6146100E+00, 0.5434800E+00, 0.5154600E+00, &
186 0.8680600E+00, 0.4512600E+00, 0.1000000E-03, 0.1785700E+00, &
187 0.1000000E-03, &
188 0.9050000E+00, 0.1538000E-01, 0.8599500E+00, 0.8733600E+00, &
189 0.2487600E+00, 0.5086500E+00, 0.5531000E+00, 0.6302500E+00, &
190 0.8875700E+00, 0.4512600E+00, 0.1000000E-03, 0.1470600E+00, &
191 0.1000000E-03, &
192 0.9050000E+00, 0.2564000E-01, 0.8599500E+00, 0.9132400E+00, &
193 0.1984100E+00, 0.7898900E+00, 0.4975100E+00, 0.7978700E+00, &
194 0.9132400E+00, 0.4512600E+00, 0.1000000E-03, 0.2083300E+00, &
195 0.1000000E-03, &
196 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
197 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
198 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
199 0.1000000E-03, &
200 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
201 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
202 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
203 0.1000000E-03, &
204 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
205 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
206 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
207 0.1000000E-03, &
208 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
209 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
210 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
211 0.1000000E-03, &
212 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
213 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
214 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
215 0.1000000E-03, &
216 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
217 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
218 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
219 0.1000000E-03, &
220 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
221 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
222 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
223 0.1000000E-03, &
224 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
225 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
226 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
227 0.1000000E-03, &
228 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
229 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
230 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
231 0.1000000E-03, &
232 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
233 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
234 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
235 0.1000000E-03, &
236 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
237 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
238 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
239 0.1000000E-03, &
240 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
241 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
242 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
243 0.1000000E-03/
244 data vcover0/ &
245 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
246 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
247 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
248 0.1000000E-04, &
249 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
250 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
251 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
252 0.1000000E-04, &
253 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
254 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
255 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
256 0.1000000E-04, &
257 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
258 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
259 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
260 0.1000000E-04, &
261 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
262 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
263 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
264 0.1000000E-04, &
265 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
266 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
267 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
268 0.1000000E-04, &
269 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
270 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
271 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
272 0.1000000E-04, &
273 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
274 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
275 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
276 0.1000000E-04, &
277 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
278 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
279 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
280 0.1000000E-04, &
281 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
282 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
283 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
284 0.1000000E-04, &
285 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
286 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
287 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
288 0.1000000E-04, &
289 0.9800000E+00, 0.7500000E+00, 0.7500000E+00, 0.7500000E+00, &
290 0.5000000E+00, 0.3000000E+00, 0.9000000E+00, 0.1000000E+00, &
291 0.1000000E+00, 0.3000000E+00, 0.1000000E-04, 0.7500000E-01, &
292 0.1000000E-04, &
293 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
294 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
295 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
296 0.1000000E-04, &
297 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
298 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
299 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
300 0.1000000E-04, &
301 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
302 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
303 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
304 0.1000000E-04, &
305 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
306 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
307 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
308 0.1000000E-04, &
309 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
310 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
311 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
312 0.1000000E-04, &
313 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
314 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
315 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
316 0.1000000E-04, &
317 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
318 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
319 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
320 0.1000000E-04, &
321 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
322 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
323 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
324 0.1000000E-04, &
325 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
326 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
327 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
328 0.1000000E-04, &
329 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
330 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
331 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
332 0.1000000E-04, &
333 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
334 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
335 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
336 0.1000000E-04, &
337 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
338 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
339 0.1000000E-03, 0.1000000E-03, 0.1000000E-04, 0.1000000E-03, &
340 0.1000000E-04/
341 data chil0/ &
342 0.1000000E+00, 0.2500000E+00, 0.1300000E+00, 0.1000000E-01, &
343 0.1000000E-01, 0.1000000E-01, -0.3000000E+00, 0.1000000E-01, &
344 0.1000000E-01, 0.2000000E+00, 0.1000000E-01, -0.2000000E-01, &
345 0.1000000E-01, &
346 0.1000000E+00, 0.2500000E+00, 0.1300000E+00, 0.1000000E-01, &
347 0.1000000E-01, -0.3000000E+00, -0.3000000E+00, -0.3000000E+00, &
348 0.1000000E-01, 0.2000000E+00, 0.1000000E-01, -0.2000000E-01, &
349 0.1000000E-01/
350 data rstpar0/ &
351 0.2335900E+04, 0.9802230E+04, 0.6335955E+04, 0.2869680E+04, &
352 0.2869680E+04, 0.5665121E+05, 0.2582010E+04, 0.9398942E+05, &
353 0.9398942E+05, 0.9802230E+04, 0.1000000E+04, 0.7459000E+04, &
354 0.1000000E+04, &
355 0.2335900E+04, 0.9802230E+04, 0.6335955E+04, 0.2869680E+04, &
356 0.2869680E+04, 0.2582010E+04, 0.2582010E+04, 0.2582010E+04, &
357 0.1000000E+01, 0.2582010E+04, 0.1000000E+04, 0.7459000E+04, &
358 0.1000000E+04, &
359 0.1450000E-01, 0.1055000E+02, 0.7120000E+01, 0.3690000E+01, &
360 0.3690000E+01, 0.1083000E+02, 0.1090000E+01, 0.1000000E-01, &
361 0.1000000E-01, 0.1055000E+02, 0.1000000E+04, 0.5700000E+01, &
362 0.1000000E+04, &
363 0.1450000E-01, 0.1055000E+02, 0.7120000E+01, 0.3690000E+01, &
364 0.3690000E+01, 0.1090000E+01, 0.1090000E+01, 0.1090000E+01, &
365 0.1000000E+01, 0.1090000E+01, 0.1000000E+04, 0.5700000E+01, &
366 0.1000000E+04, &
367 0.1534900E+03, 0.1800000E+03, 0.2065000E+03, 0.2330000E+03, &
368 0.2330000E+03, 0.1650000E+03, 0.1100000E+03, 0.8550000E+03, &
369 0.8550000E+03, 0.1800000E+03, 0.1000000E+04, 0.2520000E+02, &
370 0.1000000E+04, &
371 0.1534900E+03, 0.1800000E+03, 0.2065000E+03, 0.2330000E+03, &
372 0.2330000E+03, 0.1100000E+03, 0.1100000E+03, 0.1100000E+03, &
373 0.1000000E+01, 0.1100000E+03, 0.1000000E+04, 0.2520000E+02, &
374 0.1000000E+04/
375 data topt0/ &
376 0.3030000E+03, 0.3000000E+03, 0.2940000E+03, 0.2880000E+03, &
377 0.2880000E+03, 0.2970000E+03, 0.3130000E+03, 0.3150000E+03, &
378 0.3150000E+03, 0.3000000E+03, 0.3100000E+03, 0.3000000E+03, &
379 0.3100000E+03, &
380 0.3030000E+03, 0.3000000E+03, 0.2940000E+03, 0.2880000E+03, &
381 0.2880000E+03, 0.3120000E+03, 0.3130000E+03, 0.3130000E+03, &
382 0.3150000E+03, 0.2890000E+03, 0.3100000E+03, 0.3000000E+03, &
383 0.3100000E+03/
384 data tl0/ &
385 0.2730000E+03, 0.2730000E+03, 0.2700000E+03, 0.2680000E+03, &
386 0.2680000E+03, 0.2730000E+03, 0.2830000E+03, 0.2830000E+03, &
387 0.2830000E+03, 0.2730000E+03, 0.3000000E+03, 0.2730000E+03, &
388 0.3000000E+03, &
389 0.2730000E+03, 0.2730000E+03, 0.2700000E+03, 0.2680000E+03, &
390 0.2680000E+03, 0.2730000E+03, 0.2830000E+03, 0.2830000E+03, &
391 0.2830000E+03, 0.2730000E+03, 0.3000000E+03, 0.2730000E+03, &
392 0.3000000E+03/
393 data tu0/ &
394 0.3180000E+03, 0.3180000E+03, 0.3150000E+03, 0.3130000E+03, &
395 0.3130000E+03, 0.3230000E+03, 0.3280000E+03, 0.3230000E+03, &
396 0.3230000E+03, 0.3230000E+03, 0.3200000E+03, 0.3180000E+03, &
397 0.3200000E+03, &
398 0.3180000E+03, 0.3180000E+03, 0.3150000E+03, 0.3130000E+03, &
399 0.3130000E+03, 0.3230000E+03, 0.3280000E+03, 0.3280000E+03, &
400 0.3230000E+03, 0.3090000E+03, 0.3200000E+03, 0.3150000E+03, &
401 0.3200000E+03/
402 data defac0/ &
403 0.2730000E-01, 0.3570000E-01, 0.3400000E-01, 0.3100000E-01, &
404 0.3100000E-01, 0.3570000E-01, 0.2380000E-01, 0.2750000E-01, &
405 0.2750000E-01, 0.2750000E-01, 0.0000000E+00, 0.0000000E+00, &
406 0.0000000E+00, &
407 0.2730000E-01, 0.3570000E-01, 0.3400000E-01, 0.3100000E-01, &
408 0.3100000E-01, 0.2380000E-01, 0.2380000E-01, 0.2380000E-01, &
409 0.2380000E-01, 0.2380000E-01, 0.0000000E+00, 0.0000000E+00, &
410 0.0000000E+00/
411 data ph10/ &
412 0.1200000E+01, 0.5350000E+01, 0.1920000E+01, 0.3700000E+01, &
413 0.7800000E+01, 0.1800000E+01, 0.1730000E+01, 0.1920000E+01, &
414 0.1390000E+01, 0.9600000E+00, 0.3000000E+01, 0.1800000E+01, &
415 0.5000000E+01, &
416 0.1200000E+01, 0.5350000E+01, 0.1920000E+01, 0.3700000E+01, &
417 0.7800000E+01, 0.1800000E+01, 0.1730000E+01, 0.1920000E+01, &
418 0.1390000E+01, 0.9600000E+00, 0.3000000E+01, 0.1800000E+01, &
419 0.5000000E+01/
420 data ph20/ &
421 0.6250000E+01, 0.5570000E+01, 0.5730000E+01, 0.5530000E+01, &
422 0.5660000E+01, 0.5670000E+01, 0.5800000E+01, 0.5610000E+01, &
423 0.6370000E+01, 0.5370000E+01, 0.6000000E+01, 0.5670000E+01, &
424 0.6000000E+01, &
425 0.6250000E+01, 0.5570000E+01, 0.5730000E+01, 0.5530000E+01, &
426 0.5660000E+01, 0.5670000E+01, 0.5800000E+01, 0.5610000E+01, &
427 0.6370000E+01, 0.5370000E+01, 0.6000000E+01, 0.5670000E+01, &
428 0.6000000E+01/
429 data zlt0/ &
430 0.5014160E+01, 0.3900000E+00, 0.3456000E+01, 0.6570000E+01, &
431 0.4040000E+00, 0.1766000E+01, 0.7040000E+00, 0.5780000E+00, &
432 0.1076000E+01, 0.3776000E+00, 0.1000000E-03, 0.4800000E-01, &
433 0.1000000E-03, &
434 0.5014160E+01, 0.3900000E+00, 0.3556000E+01, 0.6870000E+01, &
435 0.4040000E+00, 0.1546000E+01, 0.8040000E+00, 0.5780000E+00, &
436 0.9760000E+00, 0.3776000E+00, 0.1000000E-03, 0.4800000E-01, &
437 0.1000000E-03, &
438 0.5014160E+01, 0.6500000E+00, 0.3956000E+01, 0.7370000E+01, &
439 0.4040000E+00, 0.1416000E+01, 0.9040000E+00, 0.4480000E+00, &
440 0.7760000E+00, 0.3776000E+00, 0.1000000E-03, 0.6800000E-01, &
441 0.1000000E-03, &
442 0.5014160E+01, 0.1580000E+01, 0.4856000E+01, 0.7570000E+01, &
443 0.9040000E+00, 0.1216000E+01, 0.1004000E+01, 0.2880000E+00, &
444 0.2760000E+00, 0.3776000E+00, 0.1000000E-03, 0.1580000E+00, &
445 0.1000000E-03, &
446 0.5014160E+01, 0.3380000E+01, 0.5456000E+01, 0.7770000E+01, &
447 0.1604000E+01, 0.1186000E+01, 0.1604000E+01, 0.2580000E+00, &
448 0.5760000E+00, 0.3776000E+00, 0.1000000E-03, 0.3380000E+00, &
449 0.1000000E-03, &
450 0.5014160E+01, 0.5080000E+01, 0.6156000E+01, 0.8070000E+01, &
451 0.2304000E+01, 0.1416000E+01, 0.3304000E+01, 0.2580000E+00, &
452 0.1760000E+00, 0.5076000E+00, 0.1000000E-03, 0.5080000E+00, &
453 0.1000000E-03, &
454 0.5014160E+01, 0.5380000E+01, 0.6456000E+01, 0.7870000E+01, &
455 0.4304000E+01, 0.2606000E+01, 0.4304000E+01, 0.2580000E+00, &
456 0.1760000E+00, 0.1737600E+01, 0.1000000E-03, 0.5380000E+00, &
457 0.1000000E-03, &
458 0.5014160E+01, 0.4880000E+01, 0.6456000E+01, 0.7670000E+01, &
459 0.2904000E+01, 0.5206000E+01, 0.3804000E+01, 0.8080000E+00, &
460 0.2760000E+00, 0.1937600E+01, 0.1000000E-03, 0.4880000E+00, &
461 0.1000000E-03, &
462 0.5014160E+01, 0.3780000E+01, 0.5756000E+01, 0.7570000E+01, &
463 0.2004000E+01, 0.4556000E+01, 0.1804000E+01, 0.1508000E+01, &
464 0.4760000E+00, 0.1477600E+01, 0.1000000E-03, 0.3780000E+00, &
465 0.1000000E-03, &
466 0.5014160E+01, 0.1630000E+01, 0.4556000E+01, 0.7370000E+01, &
467 0.1304000E+01, 0.3816000E+01, 0.1104000E+01, 0.1148000E+01, &
468 0.5760000E+00, 0.3776000E+00, 0.1000000E-03, 0.1680000E+00, &
469 0.1000000E-03, &
470 0.5014160E+01, 0.6500000E+00, 0.3256000E+01, 0.6870000E+01, &
471 0.8040000E+00, 0.2806000E+01, 0.9040000E+00, 0.7480000E+00, &
472 0.6760000E+00, 0.3776000E+00, 0.1000000E-03, 0.6800000E-01, &
473 0.1000000E-03, &
474 0.5014160E+01, 0.3900000E+00, 0.3256000E+01, 0.6570000E+01, &
475 0.5040000E+00, 0.1866000E+01, 0.8040000E+00, 0.5780000E+00, &
476 0.8760000E+00, 0.3776000E+00, 0.1000000E-03, 0.4800000E-01, &
477 0.1000000E-03, &
478 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
479 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
480 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
481 0.1000000E-03, &
482 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
483 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
484 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
485 0.1000000E-03, &
486 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
487 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
488 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
489 0.1000000E-03, &
490 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
491 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
492 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
493 0.1000000E-03, &
494 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
495 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
496 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
497 0.1000000E-03, &
498 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
499 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
500 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
501 0.1000000E-03, &
502 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
503 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
504 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
505 0.1000000E-03, &
506 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
507 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
508 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
509 0.1000000E-03, &
510 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
511 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
512 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
513 0.1000000E-03, &
514 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
515 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
516 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
517 0.1000000E-03, &
518 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
519 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
520 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
521 0.1000000E-03, &
522 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
523 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
524 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, 0.1000000E-03, &
525 0.1000000E-03/
526 data z000/ &
527 0.2652970E+01, 0.5201000E+00, 0.5706300E+00, 0.1112210E+01, &
528 0.6414000E+00, 0.8427100E+00, 0.7771000E-01, 0.2446700E+00, &
529 0.6559000E-01, 0.7524000E-01, 0.1118000E-01, 0.1448500E+00, &
530 0.1011000E-01, &
531 0.2652970E+01, 0.5201000E+00, 0.5696600E+00, 0.1102780E+01, &
532 0.6414000E+00, 0.8087800E+00, 0.7779000E-01, 0.2446700E+00, &
533 0.6549000E-01, 0.7524000E-01, 0.1118000E-01, 0.1448500E+00, &
534 0.1011000E-01, &
535 0.2652970E+01, 0.6664900E+00, 0.5656600E+00, 0.1087660E+01, &
536 0.6414000E+00, 0.7875000E+00, 0.7785000E-01, 0.2272100E+00, &
537 0.6521000E-01, 0.7524000E-01, 0.1118000E-01, 0.1752100E+00, &
538 0.1011000E-01, &
539 0.2652970E+01, 0.9105300E+00, 0.5654400E+00, 0.1081830E+01, &
540 0.8633500E+00, 0.7284100E+00, 0.7788000E-01, 0.1998800E+00, &
541 0.6360000E-01, 0.7524000E-01, 0.1118000E-01, 0.2871900E+00, &
542 0.1011000E-01, &
543 0.2652970E+01, 0.1031200E+01, 0.5592300E+00, 0.1076120E+01, &
544 0.9728300E+00, 0.7284100E+00, 0.7779000E-01, 0.1998800E+00, &
545 0.6480000E-01, 0.7524000E-01, 0.1118000E-01, 0.4302000E+00, &
546 0.1011000E-01, &
547 0.2652970E+01, 0.1043680E+01, 0.5524400E+00, 0.1067790E+01, &
548 0.1005600E+01, 0.7875000E+00, 0.7712000E-01, 0.1998800E+00, &
549 0.6331000E-01, 0.7575000E-01, 0.1118000E-01, 0.5087600E+00, &
550 0.1011000E-01, &
551 0.2652970E+01, 0.1041940E+01, 0.5497000E+00, 0.1073310E+01, &
552 0.9967700E+00, 0.9266800E+00, 0.7594000E-01, 0.1998800E+00, &
553 0.6331000E-01, 0.7767000E-01, 0.1118000E-01, 0.5200300E+00, &
554 0.1011000E-01, &
555 0.2652970E+01, 0.1037530E+01, 0.5497000E+00, 0.1078960E+01, &
556 0.1011190E+01, 0.9715300E+00, 0.7658000E-01, 0.2674000E+00, &
557 0.6360000E-01, 0.7782000E-01, 0.1118000E-01, 0.5009500E+00, &
558 0.1011000E-01, &
559 0.2652970E+01, 0.1036510E+01, 0.5562600E+00, 0.1081830E+01, &
560 0.9965000E+00, 0.9658800E+00, 0.7776000E-01, 0.2923300E+00, &
561 0.6446000E-01, 0.7745000E-01, 0.1118000E-01, 0.4503800E+00, &
562 0.1011000E-01, &
563 0.2652970E+01, 0.9170700E+00, 0.5686600E+00, 0.1087660E+01, &
564 0.9386100E+00, 0.9555100E+00, 0.7790000E-01, 0.2803400E+00, &
565 0.6480000E-01, 0.7524000E-01, 0.1118000E-01, 0.2973700E+00, &
566 0.1011000E-01, &
567 0.2652970E+01, 0.6664900E+00, 0.5725100E+00, 0.1102780E+01, &
568 0.8346400E+00, 0.9204000E+00, 0.7785000E-01, 0.2580600E+00, &
569 0.6510000E-01, 0.7524000E-01, 0.1118000E-01, 0.1752100E+00, &
570 0.1011000E-01, &
571 0.2652970E+01, 0.5201000E+00, 0.5725100E+00, 0.1112210E+01, &
572 0.7049800E+00, 0.8427100E+00, 0.7779000E-01, 0.2446700E+00, &
573 0.6537000E-01, 0.7524000E-01, 0.1118000E-01, 0.1448500E+00, &
574 0.1011000E-01/
575 data d0/ &
576 0.2737261E+02, 0.1366377E+02, 0.1813464E+02, 0.1376361E+02, &
577 0.9193320E+01, 0.1390777E+02, 0.2185200E+00, 0.2812600E+01, &
578 0.1638000E+00, 0.1062900E+00, 0.6000000E-04, 0.6314240E+01, &
579 0.4000000E-04, &
580 0.2737261E+02, 0.1366377E+02, 0.1814677E+02, 0.1380041E+02, &
581 0.9193320E+01, 0.1376090E+02, 0.2265800E+00, 0.2812600E+01, &
582 0.1548100E+00, 0.1062900E+00, 0.6000000E-04, 0.6314240E+01, &
583 0.4000000E-04, &
584 0.2737261E+02, 0.1461883E+02, 0.1819051E+02, 0.1385740E+02, &
585 0.9193320E+01, 0.1367074E+02, 0.2332800E+00, 0.2662290E+01, &
586 0.1343400E+00, 0.1062900E+00, 0.6000000E-04, 0.7639520E+01, &
587 0.4000000E-04, &
588 0.2737261E+02, 0.1569677E+02, 0.1825890E+02, 0.1387880E+02, &
589 0.9903400E+01, 0.1344527E+02, 0.2389500E+00, 0.2390910E+01, &
590 0.6191000E-01, 0.1062900E+00, 0.6000000E-04, 0.1070958E+02, &
591 0.4000000E-04, &
592 0.2737261E+02, 0.1632865E+02, 0.1829956E+02, 0.1389946E+02, &
593 0.1030010E+02, 0.1344527E+02, 0.2605400E+00, 0.2390910E+01, &
594 0.1096800E+00, 0.1062900E+00, 0.6000000E-04, 0.1278272E+02, &
595 0.4000000E-04, &
596 0.2737261E+02, 0.1662263E+02, 0.1833903E+02, 0.1392915E+02, &
597 0.1053455E+02, 0.1367074E+02, 0.2988000E+00, 0.2390910E+01, &
598 0.5103000E-01, 0.1229900E+00, 0.6000000E-04, 0.1356813E+02, &
599 0.4000000E-04, &
600 0.2737261E+02, 0.1666297E+02, 0.1835387E+02, 0.1390953E+02, &
601 0.1091967E+02, 0.1425275E+02, 0.3251800E+00, 0.2390910E+01, &
602 0.5103000E-01, 0.2152100E+00, 0.6000000E-04, 0.1366182E+02, &
603 0.4000000E-04, &
604 0.2737261E+02, 0.1660123E+02, 0.1835387E+02, 0.1388922E+02, &
605 0.1068047E+02, 0.1459719E+02, 0.3130700E+00, 0.2974600E+01, &
606 0.6191000E-01, 0.2289700E+00, 0.6000000E-04, 0.1349985E+02, &
607 0.4000000E-04, &
608 0.2737261E+02, 0.1641343E+02, 0.1831739E+02, 0.1387880E+02, &
609 0.1044517E+02, 0.1452246E+02, 0.2649800E+00, 0.3137710E+01, &
610 0.9547000E-01, 0.1996100E+00, 0.6000000E-04, 0.1301951E+02, &
611 0.4000000E-04, &
612 0.2737261E+02, 0.1572679E+02, 0.1823553E+02, 0.1385740E+02, &
613 0.1016423E+02, 0.1443002E+02, 0.2438100E+00, 0.3062460E+01, &
614 0.1096800E+00, 0.1062900E+00, 0.6000000E-04, 0.1090759E+02, &
615 0.4000000E-04, &
616 0.2737261E+02, 0.1461883E+02, 0.1810866E+02, 0.1380041E+02, &
617 0.9814290E+01, 0.1422050E+02, 0.2332800E+00, 0.2907360E+01, &
618 0.1225000E+00, 0.1062900E+00, 0.6000000E-04, 0.7639520E+01, &
619 0.4000000E-04, &
620 0.2737261E+02, 0.1366377E+02, 0.1810866E+02, 0.1376361E+02, &
621 0.9417390E+01, 0.1390777E+02, 0.2265800E+00, 0.2812600E+01, &
622 0.1450200E+00, 0.1062900E+00, 0.6000000E-04, 0.6314240E+01, &
623 0.4000000E-04/
624 data z10/ &
625 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
626 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
627 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
628 0.1000000E-03, &
629 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
630 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
631 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
632 0.1000000E-03, &
633 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
634 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
635 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
636 0.1000000E-03, &
637 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
638 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
639 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
640 0.1000000E-03, &
641 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
642 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
643 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
644 0.1000000E-03, &
645 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
646 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
647 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
648 0.1000000E-03, &
649 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
650 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
651 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
652 0.1000000E-03, &
653 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
654 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
655 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
656 0.1000000E-03, &
657 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
658 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
659 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
660 0.1000000E-03, &
661 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
662 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
663 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
664 0.1000000E-03, &
665 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
666 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
667 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
668 0.1000000E-03, &
669 0.1000000E+01, 0.1150000E+02, 0.1600000E+02, 0.8500000E+01, &
670 0.7000000E+01, 0.1000000E+02, 0.1000000E+00, 0.2000000E+01, &
671 0.1000000E+00, 0.1000000E+00, 0.1000000E-01, 0.1150000E+02, &
672 0.1000000E-03/
673 data z20/ &
674 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
675 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
676 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
677 0.1000000E+00, &
678 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
679 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
680 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
681 0.1000000E+00, &
682 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
683 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
684 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
685 0.1000000E+00, &
686 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
687 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
688 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
689 0.1000000E+00, &
690 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
691 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
692 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
693 0.1000000E+00, &
694 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
695 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
696 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
697 0.1000000E+00, &
698 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
699 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
700 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
701 0.1000000E+00, &
702 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
703 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
704 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
705 0.1000000E+00, &
706 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
707 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
708 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
709 0.1000000E+00, &
710 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
711 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
712 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
713 0.1000000E+00, &
714 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
715 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
716 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
717 0.1000000E+00, &
718 0.3500000E+02, 0.2000000E+02, 0.2000000E+02, 0.1700000E+02, &
719 0.1400000E+02, 0.1800000E+02, 0.6000000E+00, 0.5000000E+01, &
720 0.5000000E+00, 0.6000000E+00, 0.1000000E+00, 0.2000000E+02, &
721 0.1000000E+00/
722 data rdc0/ &
723 0.2858700E+03, 0.2113200E+03, 0.2985200E+03, 0.5654100E+03, &
724 0.1852000E+03, 0.2301300E+03, 0.2443000E+02, 0.1036000E+03, &
725 0.2311000E+02, 0.2286000E+02, 0.2376000E+02, 0.1949000E+03, &
726 0.2850000E+02, &
727 0.2858700E+03, 0.2113200E+03, 0.3013500E+03, 0.5870500E+03, &
728 0.1852000E+03, 0.2244200E+03, 0.2463000E+02, 0.1036000E+03, &
729 0.2294000E+02, 0.2286000E+02, 0.2376000E+02, 0.1949000E+03, &
730 0.2850000E+02, &
731 0.2858700E+03, 0.2187800E+03, 0.3124600E+03, 0.6234600E+03, &
732 0.1852000E+03, 0.2215700E+03, 0.2480000E+02, 0.1023500E+03, &
733 0.2262000E+02, 0.2286000E+02, 0.2376000E+02, 0.1964400E+03, &
734 0.2850000E+02, &
735 0.2858700E+03, 0.2434000E+03, 0.3312300E+03, 0.6381300E+03, &
736 0.2048700E+03, 0.2164100E+03, 0.2496000E+02, 0.1007200E+03, &
737 0.2189000E+02, 0.2286000E+02, 0.2376000E+02, 0.2014400E+03, &
738 0.2850000E+02, &
739 0.2858700E+03, 0.2948700E+03, 0.3458300E+03, 0.6528600E+03, &
740 0.2330100E+03, 0.2164100E+03, 0.2572000E+02, 0.1007200E+03, &
741 0.2230000E+02, 0.2286000E+02, 0.2376000E+02, 0.2071300E+03, &
742 0.2850000E+02, &
743 0.2858700E+03, 0.3459000E+03, 0.3619400E+03, 0.6750500E+03, &
744 0.2620800E+03, 0.2215700E+03, 0.2774000E+02, 0.1007200E+03, &
745 0.2182000E+02, 0.2301000E+02, 0.2376000E+02, 0.2107900E+03, &
746 0.2850000E+02, &
747 0.2858700E+03, 0.3551800E+03, 0.3685400E+03, 0.6602400E+03, &
748 0.3443100E+03, 0.2500700E+03, 0.3006000E+02, 0.1007200E+03, &
749 0.2182000E+02, 0.2436000E+02, 0.2376000E+02, 0.2113100E+03, &
750 0.2850000E+02, &
751 0.2858700E+03, 0.3418400E+03, 0.3685400E+03, 0.6454900E+03, &
752 0.2870900E+03, 0.2885700E+03, 0.2886000E+02, 0.1053000E+03, &
753 0.2189000E+02, 0.2469000E+02, 0.2376000E+02, 0.2104200E+03, &
754 0.2850000E+02, &
755 0.2858700E+03, 0.3072200E+03, 0.3528500E+03, 0.6381300E+03, &
756 0.2495800E+03, 0.2780300E+03, 0.2590000E+02, 0.1079400E+03, &
757 0.2216000E+02, 0.2404000E+02, 0.2376000E+02, 0.2081500E+03, &
758 0.2850000E+02, &
759 0.2858700E+03, 0.2448400E+03, 0.3236500E+03, 0.6231300E+03, &
760 0.2211200E+03, 0.2668400E+03, 0.2511000E+02, 0.1065900E+03, &
761 0.2230000E+02, 0.2286000E+02, 0.2376000E+02, 0.2018800E+03, &
762 0.2850000E+02, &
763 0.2858700E+03, 0.2187800E+03, 0.2927900E+03, 0.5870500E+03, &
764 0.2008900E+03, 0.2475700E+03, 0.2480000E+02, 0.1044900E+03, &
765 0.2244000E+02, 0.2286000E+02, 0.2376000E+02, 0.1964400E+03, &
766 0.2850000E+02, &
767 0.2858700E+03, 0.2113200E+03, 0.2927900E+03, 0.5654100E+03, &
768 0.1892600E+03, 0.2301300E+03, 0.2464000E+02, 0.1036000E+03, &
769 0.2277000E+02, 0.2286000E+02, 0.2376000E+02, 0.1949000E+03, &
770 0.2850000E+02/
771 data rbc0/ &
772 0.5430000E+01, 0.6936000E+02, 0.8590000E+01, 0.8800000E+00, &
773 0.7850000E+01, 0.2661000E+02, 0.2207000E+02, 0.2188000E+02, &
774 0.1761000E+02, 0.4351000E+02, 0.3592951E+05, 0.5600000E+03, &
775 0.3546177E+05, &
776 0.5430000E+01, 0.6936000E+02, 0.8450000E+01, 0.8600000E+00, &
777 0.7850000E+01, 0.3044000E+02, 0.2053000E+02, 0.2188000E+02, &
778 0.1942000E+02, 0.4351000E+02, 0.3592951E+05, 0.5600000E+03, &
779 0.3546177E+05, &
780 0.5430000E+01, 0.4257000E+02, 0.7980000E+01, 0.8400000E+00, &
781 0.7850000E+01, 0.3295000E+02, 0.1934000E+02, 0.2673000E+02, &
782 0.2446000E+02, 0.4351000E+02, 0.3592951E+05, 0.4019700E+03, &
783 0.3546177E+05, &
784 0.5430000E+01, 0.1897000E+02, 0.7180000E+01, 0.8300000E+00, &
785 0.3810000E+01, 0.4003000E+02, 0.1838000E+02, 0.3712000E+02, &
786 0.6928000E+02, 0.4351000E+02, 0.3592951E+05, 0.1855200E+03, &
787 0.3546177E+05, &
788 0.5430000E+01, 0.1035000E+02, 0.6810000E+01, 0.8200000E+00, &
789 0.2400000E+01, 0.4003000E+02, 0.1516000E+02, 0.3712000E+02, &
790 0.3303000E+02, 0.4351000E+02, 0.3592951E+05, 0.9801000E+02, &
791 0.3546177E+05, &
792 0.5430000E+01, 0.7880000E+01, 0.6480000E+01, 0.8100000E+00, &
793 0.1860000E+01, 0.3295000E+02, 0.1068000E+02, 0.3712000E+02, &
794 0.8702000E+02, 0.3568000E+02, 0.3592951E+05, 0.7224000E+02, &
795 0.3546177E+05, &
796 0.5430000E+01, 0.7610000E+01, 0.6360000E+01, 0.8200000E+00, &
797 0.1290000E+01, 0.1870000E+02, 0.8300000E+01, 0.3712000E+02, &
798 0.8702000E+02, 0.1449000E+02, 0.3592951E+05, 0.6938000E+02, &
799 0.3546177E+05, &
800 0.5430000E+01, 0.8090000E+01, 0.6360000E+01, 0.8300000E+00, &
801 0.1600000E+01, 0.1318000E+02, 0.9330000E+01, 0.1722000E+02, &
802 0.6928000E+02, 0.1281000E+02, 0.3592951E+05, 0.7434000E+02, &
803 0.3546177E+05, &
804 0.5430000E+01, 0.9570000E+01, 0.6660000E+01, 0.8300000E+00, &
805 0.2040000E+01, 0.1420000E+02, 0.1457000E+02, 0.1317000E+02, &
806 0.4003000E+02, 0.1669000E+02, 0.3592951E+05, 0.8988000E+02, &
807 0.3546177E+05, &
808 0.5430000E+01, 0.1847000E+02, 0.7400000E+01, 0.8400000E+00, &
809 0.2820000E+01, 0.1559000E+02, 0.1760000E+02, 0.1497000E+02, &
810 0.3303000E+02, 0.4351000E+02, 0.3592951E+05, 0.1757600E+03, &
811 0.3546177E+05, &
812 0.5430000E+01, 0.4257000E+02, 0.8880000E+01, 0.8600000E+00, &
813 0.4210000E+01, 0.1933000E+02, 0.1934000E+02, 0.1906000E+02, &
814 0.2810000E+02, 0.4351000E+02, 0.3592951E+05, 0.4019700E+03, &
815 0.3546177E+05, &
816 0.5430000E+01, 0.6936000E+02, 0.8880000E+01, 0.8800000E+00, &
817 0.6400000E+01, 0.2661000E+02, 0.2053000E+02, 0.2188000E+02, &
818 0.2165000E+02, 0.4351000E+02, 0.3592951E+05, 0.5600000E+03, &
819 0.3546177E+05/
820 data rootd0/ &
821 0.1000000E+01, 0.1000000E+01, 0.1000000E+01, 0.5000000E+00, &
822 0.5000000E+00, 0.5000000E+00, 0.5000000E+00, 0.5000000E+00, &
823 0.5000000E+00, 0.2000000E+00, 0.1000000E+00, 0.1000000E+01, &
824 0.1000000E+01, &
825 0.1000000E+01, 0.1000000E+01, 0.1000000E+01, 0.5000000E+00, &
826 0.5000000E+00, 0.5000000E+00, 0.5000000E+00, 0.5000000E+00, &
827 0.5000000E+00, 0.2000000E+00, 0.1000000E+00, 0.1000000E+01, &
828 0.1000000E+01/
829 data soref0/ &
830 0.1100000E+00, 0.1100000E+00, 0.1100000E+00, 0.1100000E+00, &
831 0.1100000E+00, 0.1100000E+00, 0.1000000E+00, 0.1000000E+00, &
832 0.3000000E+00, 0.1000000E+00, 0.3000000E+00, 0.1000000E+00, &
833 0.1000000E+00, &
834 0.2250000E+00, 0.2250000E+00, 0.2250000E+00, 0.2250000E+00, &
835 0.2250000E+00, 0.2250000E+00, 0.2000000E+00, 0.2000000E+00, &
836 0.3500000E+00, 0.2000000E+00, 0.3500000E+00, 0.1500000E+00, &
837 0.1500000E+00, &
838 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
839 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
840 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, &
841 0.0000000E+00/
842 data bee0/ &
843 0.7120000E+01, 0.7120000E+01, 0.7120000E+01, 0.7120000E+01, &
844 0.7120000E+01, 0.7120000E+01, 0.7120000E+01, 0.4050000E+01, &
845 0.4050000E+01, 0.7120000E+01, 0.4050000E+01, 0.7797000E+01, &
846 0.4804000E+01/
847 data phsat0/ &
848 -0.8600000E-01, -0.8600000E-01, -0.8600000E-01, -0.8600000E-01, &
849 -0.8600000E-01, -0.8600000E-01, -0.8600000E-01, -0.3500000E-01, &
850 -0.3500000E-01, -0.8600000E-01, -0.3500000E-01, -0.1980000E+00, &
851 -0.1670000E+00/
852 data poros0/ &
853 0.4200000E+00, 0.4200000E+00, 0.4200000E+00, 0.4200000E+00, &
854 0.4200000E+00, 0.4200000E+00, 0.4200000E+00, 0.4352000E+00, &
855 0.4352000E+00, 0.4200000E+00, 0.4352000E+00, 0.4577000E+00, &
856 0.4352000E+00/
857 data satco0/ &
858 0.2000000E-04, 0.2000000E-04, 0.2000000E-04, 0.2000000E-04, &
859 0.2000000E-04, 0.2000000E-04, 0.2000000E-04, 0.1760000E-03, &
860 0.1760000E-03, 0.2000000E-04, 0.1760000E-03, 0.3500000E-05, &
861 0.7620000E-04/
862 data slope0/ &
863 0.1736000E+00, 0.1736000E+00, 0.1736000E+00, 0.1736000E+00, &
864 0.1736000E+00, 0.1736000E+00, 0.1736000E+00, 0.8720000E-01, &
865 0.8720000E-01, 0.1736000E+00, 0.8720000E-01, 0.3420000E+00, &
866 0.8720000E-01/
867 data depth0/ &
868 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, &
869 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, &
870 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, 0.2000000E-01, &
871 0.1000000E+01, &
872 0.1480000E+01, 0.1480000E+01, 0.1480000E+01, 0.1480000E+01, &
873 0.1480000E+01, 0.1480000E+01, 0.4700000E+00, 0.4700000E+00, &
874 0.4700000E+00, 0.1700000E+00, 0.1700000E+00, 0.1480000E+01, &
875 0.1000000E+01, &
876 0.2000000E+01, 0.2000000E+01, 0.2000000E+01, 0.2000000E+01, &
877 0.2000000E+01, 0.2000000E+01, 0.1000000E+01, 0.1000000E+01, &
878 0.1000000E+01, 0.1000000E+01, 0.3000000E+00, 0.2000000E+01, &
879 0.1000000E+01/
880 !------------------------------------------------------------------------
881 CONTAINS
882 !
883 !-----------------------------------------------------------------------
884 !**********************************************
885 SUBROUTINE SSIB( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE, &
886 PPL, PPC, RLWDOWN, ZWIND2, &
887 WWW1, WWW2, WWW3, &
888 TC, TGS, TD, &
889 SNOA, ROFF, &
890 UMM, VMM, QM, TM, &
891 PM, PSUR, ivgtyp, &
892 SWDOWN1, SNOB, &
893 SALB11, SALB12, SALB21, SALB22, &
894 RADFRAC11, RADFRAC12, RADFRAC21, RADFRAC22, &
895 XHSFLX, ELATEN, GHTFLX, XHLFLX, TGEFF, &
896 USTAR, RIB, FM, FH, CM, &
897 XLHF, XSHF, XGHF, XEGS, XECI, XECT, & ! output
898 XEGI, XEGT, XSDN, XSUP, XLDN, XLUP, & ! output
899 XWAT, XHCX, XHGX, XZLT, XVCF, XXZ0, & ! output
900 XVEG, XDD, & ! output
901 ISNOW,SWE,SNOWDEN,SNOWDEPTH,TKAIR, & ! snow
902 DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, & ! snow
903 DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, & ! snow
904 DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, & ! snow
905 DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, & ! snow
906 DAY, CLOUD, Q2M, TA, BEDO, UV10, & ! add uv10 (01/2014)
907 sw_physics, MMINLU &
908 )
909 !**********************************************
910 !-----------------------------------------------------------------------
911 ! THERE ARE A MAIN SSIB PROGRAM AND 12 SUBROUTINE FILES, WHICH ARE:
912 ! VEGOUT
913 ! CROPS
914 ! RADAB
915 ! ROOT1
916 ! STOMA1
917 ! INTERC
918 ! TEMRS1
919 ! UPDAT1
920 ! RASIT5
921 ! STRES1
922 ! NEWTON
923 ! YONGKANG XUE
924 !-----------------------------------------------------------------------
925 ! INPUT
926 ! DDTT: TIME INTERVAL
927 ! SUNANGLE: SOLAR ZENITH ANGLE
928 ! SWDOWN: SHORT WAVE DOWN(W/M*M);
929 ! RADFRAC: SHORT WAVE COMPONENTS (visible and near IR; direct and diffuse)
930 ! RLWDOWN: LONG WAVE DOWN(W/M*M);
931 ! PPL, PPC: LARGE SCALE AND CONVECTIVE PRECIPITATIONS AT THE TIME STEP (mm)
932 ! TM: TEMPERETURE AT LOWEST MODEL LAYER (K)
933 ! UMM,VMM: ZONAL AND MERIDIONAL WINDS AT LOWEST MODEL LAYER (m/S)
934 ! QM: WATER VAPOR AT LOWEST MODEL LAYER;
935 ! PSURF: SURFACE PRESSURE (mb)
936 ! ZWIND: HEIGHT (m) OF LOWEST MODEL LAYER
937 ! ITYPE: VEGETATION TYPE
938 ! ZLAT: LATITUDE, SOUTH POLE IS -90 DEGREE AND NORTH POLE IS 90 DEGREE
939 ! MONTH: MONTH
940 ! DAY: CALENDER DATE
941 ! IYEAR: YEAR
942 ! OUTPUT
943 ! ETMASS: EVAPORATION (mm/step)
944 ! ELATEN: LATENT HEAT FLUX (w/m*m)
945 ! EVAPSOIL,EVAPWC,EVAPDC,EVAPSN: LATENT HEAT FROM (SOIL, INTERCEPTION,
946 ! TRANSPIRATION, AND SNOW SURFACE)
947 ! HFLUX: SENSIBLE HEAT FLUX(w/m*m)
948 ! GHTFLX: GROUND HEAT FLUX(w/m*m) = CHF+SHF
949 ! USTAR: FRICTION VELOCITY (m/s)
950 ! DRAG: MOMENTUM FLUX (kg/m/s**2)
951 ! DRAGU: U COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
952 ! DRAGV: V COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
953 ! TGEFF: RADIATIVE TEMPERATURE (K)
954 ! BEDO: TOTAL ALBEDO
955 ! SALB: ALBEDO FOR 4 COMPONENTS
956 ! RADT: NET RADIATION AT CANOPY AND GROUND LEVELS
957 ! TGS: SOIL SURFACE TEMPERATURE (K)
958 ! TC: CANOPY TEMPERATURE (K)
959 ! TD: DEEP SOIL TEMPERATURE (K)
960 ! TA: TEMPERATURE AT CANOPY AIR SPACE (K)
961 ! CAPAC: INTERCEPTION AT CANOPY (1) and SNOW DEPTH (2)
962 ! WWW: SOIL MOISTURE
963 ! SOILM: TOTAL SOIL WATER CONTENT
964 ! ROFF: RUN OFF
965 !
966 !----------------------------------------------------------------------
968 INTEGER, DIMENSION (12) :: IDAYS
970 REAL, DIMENSION (2) :: CAPAC, SATCAP, GREEN, VCOVER, ZLT, CHIL, TOPT, TL, &
971 TU, DEFAC, PH1, PH2, RST, ROOTD, RADT, PAR, PD
972 REAL, DIMENSION (3) :: WWW, SOREF, ZDEPTH, ROOTP, PHSOIL, YMATT, YMATQ
973 REAL, DIMENSION (2,2) :: RADFRAC, SALB
974 REAL, DIMENSION (2,3) :: RSTPAR
975 REAL, DIMENSION (2,4) :: RSTFAC
976 REAL, DIMENSION (3,2) :: RADN
977 REAL, DIMENSION (2,3,2) :: TRAN, REF, ALBEDO, EXTK
978 REAL, DIMENSION (2,2,2) :: RADFAC
980 INTEGER, DIMENSION (24) :: IVUSGS
981 INTEGER, DIMENSION (20) :: IVMODIS
982 REAL, DIMENSION (13) :: TD_DEPTH
983 INTEGER :: sw_physics !choice of SW radiation scheme
984 CHARACTER(LEN=*), INTENT(IN ) :: MMINLU !type of landuse/vegetation map
985 CHARACTER*256 :: message
986 !snow
987 REAL, DIMENSION (N2) :: SS,SSO,POROSITY,H,HO,BI,BIO,DZ,DZO,BW,BWO,BL
988 REAL, DIMENSION (N2) :: BLO,TSSN,TSSNO,W,WO,WF,FI,FIO, FL,FLO,DMLT
989 REAL, DIMENSION (N2) :: DMLTO,BT,BTO,S,SO,CT,CTO,DLIQVOL,DICEVOL
990 REAL, DIMENSION (N2) :: QK,PDZDTC,DMASS,DSOL,DHP,THK
991 !snow
992 ! Julian day
993 DATA IDAYS/31,59,90,120,151,181,212,243,273,304,334,366/
994 !
995 ! Deep soil temperature depth by vegetation type --------------------
996 DATA TD_DEPTH/1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.0, 1.0, 1.0 &
997 & , 0.5, 0.5, 1.5, 1.5/
998 !
999 ! Check vegetation/land use map choice
1000 ! USGS-SSIB vegetation type conversion
1001 DATA IVUSGS / 7, 12, 12, 12, 12, 12, 7, 9, &
1002 8, 6, 2, 5, 1, 4, 3, 0, &
1003 10, 3, 11, 10, 10, 10, 10, 13/
1004 ! MODIS-SSIB vegetation type conversion (fds Jan/2015)
1005 DATA IVMODIS / 4, 1, 5, 2, 3, 8, 9, 6, &
1006 6, 7, 7, 12, 11, 12, 13, 11, &
1007 0, 10, 10, 10/
1008 ! Converts vegetation/land use types
1009 IF(MMINLU.EQ.'SSIB') THEN
1010 ITYPE=IVGTYP
1011 ELSEIF(MMINLU.EQ.'USGS') THEN
1012 ITYPE=IVUSGS(IVGTYP)
1013 ELSEIF(MMINLU.EQ.'MODIS') THEN
1014 ITYPE=IVMODIS(IVGTYP)
1015 ELSE IF (MMINLU .EQ. 'MODIFIED_IGBP_MODIS_NOAH') THEN
1016 ITYPE=IVMODIS(IVGTYP)
1017 ELSE
1018 CALL wrf_error_fatal ( 'SSIB LSM only works with SSIB or USGS vegetation (landuse) map' )
1019 ENDIF
1021 ! Check for error in vegetation map
1022 if(itype.le.0.or.itype.gt.13) then
1023 !Make sure the correct vegetation map is being used!
1024 print *,"veg type: ",itype
1025 CALL wrf_error_fatal ( 'module_sf_ssib: ERROR in vegetation/landuse map' )
1026 endif
1027 !
1028 INTG=1
1029 XADJ=0.
1030 CTLPA=1.
1031 NROOT=1
1032 WFSOIL=0.
1033 !------------------------------------------------
1034 ZWIND=ZWIND2*0.5 ! TM & UM are on the middle lowest model layer
1035 !------------------------------------------------
1036 ! set DAY in year and current month MON_COR
1037 !------------------------------------------------
1038 IMONTH=1
1039 IDAY=INT(DAY)
1040 DO I=1,12
1041 IF(IDAY.LE.IDAYS(I)) THEN
1042 IMONTH=I
1043 EXIT
1044 ENDIF
1045 ENDDO
1046 !crr correction for southern hemisphere (reverse months) Ratko, Oct 28, 2005
1047 IF(ZLAT.LT.0.0) THEN
1048 MON_COR=IMONTH+6
1049 IF(MON_COR.GT.12) MON_COR=MON_COR-12
1050 ELSE
1051 MON_COR=IMONTH
1052 ENDIF
1053 !------------------------------------------------
1054 IF (ITIME.EQ.1) TA=TC
1055 !
1056 PSURF=PSUR*0.01
1057 DTT =DDTT*FLOAT(INTG)
1058 !------------------------------------------------
1059 ! ** Read in vegetation parameters
1060 CALL VEGOUT(TRAN,REF,GREEN,VCOVER,CHIL, &
1061 RSTPAR,TOPT,TL,TU,DEFAC,PH1,PH2, &
1062 ZLT,Z0,XDD,Z2,Z1,RDC,RBC,ROOTD,SOREF, &
1063 BEE, PHSAT, POROS, SATCO,SLOPE, &
1064 ZDEPTH,MON_COR,ITYPE)
1065 !
1067 IF (ITYPE.EQ.12) CALL CROPS(ZLAT,DAY,CHIL, &
1068 ZLT,GREEN,VCOVER,RSTPAR,TOPT,TL,TU,DEFAC,PH2,PH1)
1069 !
1070 !crr ------------ STC initialization ------------------------------------
1071 IF (ITIME.EQ.1) THEN
1072 STLEV1=0.05 ! half of 10cm layer
1073 STLEV2=1.05 ! half of second + first layer
1075 DEPTH = TD_DEPTH(ITYPE)
1077 IF (DEPTH.GT.STLEV1.AND.DEPTH.LE.STLEV2)THEN ! interp.
1078 TD = ( (STLEV2-DEPTH)*TGS + (DEPTH-STLEV1)*TD ) &
1079 & /(STLEV2-STLEV1)
1080 ELSE IF(DEPTH.GT.STLEV2)THEN ! extrap.
1081 TD = ( (DEPTH-STLEV1)*TD - (DEPTH-STLEV2)*TGS) &
1082 & /(STLEV2-STLEV1)
1083 ENDIF
1085 ENDIF
1086 !------------------------------------------------------------------------
1087 WWW(1) = WWW1 / POROS
1088 WWW(2) = WWW2 / POROS
1089 WWW(3) = WWW3 / POROS
1090 !------------------------------------------------
1091 !cfds Convert WEASD (kg/m2) to meter
1092 SNOA = SNOA/1000.
1093 SNOB = SNOB/1000.
1094 !------------------------------------------------
1095 !
1096 CALL CONVDIM(0, &
1097 DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, &
1098 DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, &
1099 DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, &
1100 DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, &
1101 DZO, WO, TSSN, TSSNO, BWO, BTO, CTO, FIO, FLO, BIO, BLO, HO )
1102 !
1104 IF (ITIME.EQ.1) THEN
1105 ISNOW = 1
1106 SNOWDEN = 3.75
1107 SWE = SNOA
1108 SNOWDEPTH = SWE * SNOWDEN
1109 TGG=AMIN1(273.15,TGS)
1110 !fds temp IF (SNOWDEPTH.gt.SNODEP_CR) THEN
1111 !fds temp ISNOW = 0
1112 !fds temp CALL LAYERN (TGG,SWE,SNOWDEPTH, DZO,BWO,WO,BTO,CTO &
1113 !fds temp ,FLO,FIO,HO,BLO,BIO,DLIQVOL,DICEVOL,TSSNO,DMLTO)
1114 !fds temp ENDIF
1116 ENDIF
1117 !
1118 CAPAC(1)=SNOB
1119 CAPAC(2)=SNOA
1120 IF (ITIME.EQ.1) THEN
1121 IF (SNOA.GT.0.) THEN
1122 !cxx IF (SNOA.GT.5.) THEN
1123 CAPAC(1) = ZLT(1) * 0.0001
1124 TC = AMIN1(TC ,TF-0.01)
1125 TGS = AMIN1(TGS,TF-0.01)
1126 ENDIF
1127 ENDIF
1128 !
1129 UM=SQRT(UMM**2+VMM**2)
1130 RHOAIR=100./GASR*(PSURF+0.01*PM)/(TM+TA)
1131 AKAPPA = GASR/CPAIR
1132 BPS =1.0 / EXP ( AKAPPA * ALOG (0.01*PM/PSURF) )
1133 ! BPS0 =1.0 / EXP ( AKAPPA * ALOG (PSURF/1000.) )
1134 ! BPS1 =1.0 / EXP ( AKAPPA * ALOG (0.01*PM/1000.) )
1135 !Cl 2001,2,2 added the following line
1136 IF (ISNOW.EQ.0) THEN
1137 TSOIL=TGS
1138 TGS=TSSNO(N)
1139 CAPAC(2)=SWE
1140 IPTYPE=2
1141 IF(TM.ge.TF) IPTYPE=1
1142 END IF
1143 !C
1144 !
1145 ! CONVERT TO VAPOR PRES. TO MB
1146 EM=(PSURF*QM)/0.6220
1147 IF (ITIME.EQ.1) EA=EM
1148 !
1149 SUNANG=AMAX1(SUNANGLE,0.01746)
1150 ! By Zhenxin 2011-06-20
1151 ! IF (sw_physics.eq.3) THEN
1152 IF (sw_physics.eq.3 .or. sw_physics.eq.4) THEN
1153 ! End By Zhenxin 2011-06-20
1154 !**********************************************
1155 !fds - RADFRAC from radiation scheme 3 (06/2010)
1156 !fds - Otherwise use cloud cover to calculate radfrac
1157 radfrac11 = amax1(radfrac11,0.025)
1158 radfrac12 = amax1(radfrac12,0.025)
1159 radfrac21 = amax1(radfrac21,0.025)
1160 radfrac22 = amax1(radfrac22,0.025)
1161 swdown = radfrac11 + radfrac12 + radfrac21 + radfrac22
1162 RADFRAC(1,1) = radfrac11/swdown
1163 RADFRAC(1,2) = radfrac12/swdown
1164 RADFRAC(2,1) = radfrac21/swdown
1165 RADFRAC(2,2) = radfrac22/swdown
1166 ELSE
1167 !**********************************************
1168 ! ** CALCULATE THE CLOUD COVER USING AN EMPIRICAL EQUATION
1169 ! ONLY USE THIS PART WHEN IT IS NEEDED
1170 !
1171 swdown = amax1(swdown1,0.1)
1172 CLOUD = AMAX1(CLOUD,0.0)
1173 CLOUD = AMIN1(CLOUD,1.0)
1174 CLOUD = AMAX1(0.58,CLOUD)
1175 !
1176 DIFRAT = 0.0604 / ( SUNANG-0.0223 ) + 0.0683
1177 IF ( DIFRAT .LT. 0.0 ) DIFRAT = 0.0
1178 IF ( DIFRAT .GT. 1.0 ) DIFRAT = 1.0
1179 !
1180 DIFRAT = DIFRAT + ( 1.0 - DIFRAT ) * CLOUD
1181 VNRAT = ( 580.0 - CLOUD*464.0 ) / ( ( 580.0-CLOUD*499.0) &
1182 & + ( 580.0 - CLOUD*464.0 ) )
1183 !
1184 RADFRAC(1,1) = (1.0-DIFRAT)*VNRAT
1185 RADFRAC(1,2) = DIFRAT*VNRAT
1186 RADFRAC(2,1) = (1.0-DIFRAT)*(1.0-VNRAT)
1187 RADFRAC(2,2) = DIFRAT*(1.0-VNRAT)
1188 !**********************************************
1189 ENDIF
1190 !
1191 RADN(1,1) = RADFRAC(1,1) * SWDOWN
1192 RADN(1,2) = RADFRAC(1,2) * SWDOWN
1193 RADN(2,1) = RADFRAC(2,1) * SWDOWN
1194 RADN(2,2) = RADFRAC(2,2) * SWDOWN
1195 RADN(3,1) = 0.
1196 RADN(3,2) = RLWDOWN
1197 !
1198 ! END OF EMPIRICAL EQUATIONS
1199 ! *********************************************************
1200 !
1201 CALL RADAB (TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF,TC, &
1202 TGS,SATCAP,EXTK,RADFAC,THERMK,RADT,PAR,PD,ALBEDO,SALB, &
1203 TGEFF,SUNANG,XADJ,CAPAC,RADN,ZLWUP,RADFRAC, &
1204 ISNOW,SNOWDEN,SNOWDEPTH,SWDOWN,BEDO,SNOCV,0, &
1205 fsdown,fldown,fsup,flup)
1206 !
1207 CALL ROOT1(PHSAT,BEE,WWW,PHSOIL)
1208 !
1209 CALL STOMA1(GREEN,VCOVER,CHIL,ZLT,PAR,PD,EXTK,SUNANG,RST, &
1210 RSTPAR, CTLPA)
1211 !
1212 RSTUN = RST(1)
1214 !***************************************************************************************
1215 ! For water balance check later
1216 TOTWB = WWW(1) * POROS * ZDEPTH(1) &
1217 + WWW(2) * POROS * ZDEPTH(2) &
1218 + WWW(3) * POROS * ZDEPTH(3) &
1219 + CAPAC(1) + CAPAC(2)
1220 !***************************************************************************************
1221 !
1222 CALL INTERCS (DTT,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL, &
1223 ROFF,ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET, &
1224 EXTK,ISNOW,P0,CSOIL,dzsoil,CHISL,SMELT)
1225 !
1226 CALL SET0(TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO, &
1227 SSO,CTO,BTO,DMLTO,WF,DHP)
1228 !
1229 !***************************************************************************************
1230 IF (ISNOW.EQ.0) THEN ! MULTI-LAYER SNOW
1231 !***************************************************************************************
1232 PRCP=P0
1233 TKAIR=TM
1234 CALL GETMET(IPTYPE,PRCP,TKAIR, &
1235 PRCPS,PRCPW,FIFALL,FLFALL,BIFALL,BLFALL)
1236 !c ** aerodynamic resistance and flux calculations
1237 SOLAR=0.
1238 DO 1100 IVEG = 2, 2
1239 DO 1100 IWAVE = 1, 2
1240 DO 1100 IRAD = 1, 2
1241 SOLAR=SOLAR+RADFAC(IVEG,IWAVE,IRAD)*RADN(IWAVE,IRAD)
1242 1100 CONTINUE
1243 CALL SNOW_1ST (DTT,TM,SOLAR,PRCPW,PRCPS,BIO,BLO,DICEVOL, &
1244 DLIQVOL,TSSNO,PDZDTC,POROSITY,SO,SSO,WF,DHP,DZO,WO, &
1245 BWO,BTO,CTO,DMASS,DSOL,SNROFF,HROFF,SNOWDEPTH,SOLSOIL, &
1246 FLO,FIO,DMLTO,HO,BIFALL,BLFALL,FLFALL)
1247 !
1248 CALL TEMRS2(DTT,TC,TGS,TD,TA,TM,QM,EM,PSUR,WWW,CAPAC,SATCAP, &
1249 DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,XDD,Z0,RDC,RBC,VCOVER, &
1250 Z2,ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP, &
1251 PH1,PH2,ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF, &
1252 ALBEDO,ZLWUP,THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, &
1253 ISNOW,CHISL,TSOIL,SOLSOIL,CSOIL,WFSOIL,POROSITY, &
1254 DZ,DZO,W,WO,WF,TSSN,TSSNO,BW,BWO,CT,CTO,FI,FIO,FL,FLO, &
1255 BL,BLO,BI,BIO,BT,BTO,DMLT,DMLTO,H,HO,S,SO,SS,SSO,DSOL,DHP, &
1256 DICEVOL,DLIQVOL,THK,QK,SWE,SNOWDEN,SNOWDEPTH,TKAIR,SNROFF, &
1257 DZSOIL,BPS,rib,CU,XCT,flup,UV10)
1258 !
1259 CALL OLD(TSSN,BW,BL,BI,H,FL,FI,W,DZ,SS,CT,BT,DMLT, &
1260 TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO,SSO,CTO,BTO,DMLTO)
1261 !
1262 !***************************************************************************************
1263 ELSE ! SINGLE-LAYER SNOW
1264 !***************************************************************************************
1265 !
1266 CALL TEMRS1(DTT,TC,TGS,TD,TA,TM,QM,EM,PSUR,WWW,CAPAC,SATCAP, &
1267 DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,XDD,Z0,RDC,RBC,VCOVER,Z2, &
1268 ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
1269 ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP, &
1270 THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN, &
1271 BPS,rib,CU,XCT,flup,UV10)
1272 !
1273 SWE=CAPAC(2)
1274 SNOWDEPTH=SWE*SNOWDEN
1275 SNROFF=0.
1276 !
1277 END IF
1278 !***************************************************************************************
1279 !
1280 CALL UPDAT1(DTT,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, &
1281 EGS,EG,HC,HG,HFLUX,ETMASS,ROFF, &
1282 1,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
1283 PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF, ISNOW,WFSOIL,SWE,SNROFF,SMELT)
1284 !
1285 IF (ISNOW.EQ.0) THEN
1286 CAPAC(2)=SWE
1287 IF (SNOWDEPTH.LT.SNODEP_CR) THEN
1288 ISNOW=1
1289 CALL LAYER1 (CSOIL,TGS,DZSOIL,H,W,SNOWDEPTH,SWE,STEMP,N2)
1290 ELSE
1291 ISNOW=0
1292 CALL MODNODE(SNOWDEPTH,DZO,WO,HO,TSSNO,BWO,BIO, &
1293 BLO,BTO,FIO,FLO,CTO,DLIQVOL,DICEVOL)
1294 END IF
1295 ELSE IF(ISNOW.GT.0) THEN
1296 IF (CAPAC(2)*SNOWDEN.GT.SNODEP_CR) THEN
1297 SWE=CAPAC(2)
1298 SNOWDEPTH=CAPAC(2)*SNOWDEN
1299 ISNOW=0
1300 CALL LAYERN (TGS,SWE,SNOWDEPTH, DZO,BWO,WO,BTO,CTO,FLO,FIO, &
1301 HO,BLO,BIO,DLIQVOL,DICEVOL,TSSNO,DMLTO)
1303 ELSE
1304 ISNOW=1
1305 END IF
1306 END IF
1307 ROFF=ROFF+SNROFF
1308 !
1309 !***************************************************************************************
1310 ! Check water and energy balances (fds Jan/2015)
1311 ENDWB = WWW(1) * POROS * ZDEPTH(1) &
1312 + WWW(2) * POROS * ZDEPTH(2) &
1313 + WWW(3) * POROS * ZDEPTH(3) &
1314 + CAPAC(1) + CAPAC(2) - (PPC+PPL)/1000. + ETMASS/1000. + ROFF
1315 ERRW = TOTWB - ENDWB
1316 IF(ABS(ERRW) .GT. 0.0001) THEN
1317 WRITE(message,*) 'SSIB WATER BALANCE WARNING: ',ERRW
1318 CALL wrf_message ( message )
1319 ENDIF
1320 !
1321 ZLHS = RADT(1) + RADT(2) - CHF - SHF
1322 ZRHS = HFLUX + (ECT + ECI + EGT + EGI + EGS)/DTT
1323 ERRH = ZLHS - ZRHS
1324 IF(ABS(ERRH) .GT. 1.) THEN
1325 WRITE(message,*) 'SSIB ENERGY BALANCE WARNING: ',ERRH
1326 CALL wrf_message ( message )
1327 ENDIF
1328 !***************************************************************************************
1331 !------------------------------------------------------------------------
1332 SOILM=(WWW(1)*ZDEPTH(1)+WWW(2)*ZDEPTH(2)+WWW(3)*ZDEPTH(3))*POROS
1333 !------------------------------------------------------------------------
1334 UMOM=RHOAIR*CU*USTAR*UMM
1335 VMOM=RHOAIR*CU*USTAR*VMM
1336 HLFLX= ETMASS/RHOAIR/DTT
1337 HSFLX= HFLUX/CPAIR/RHOAIR/DTT
1338 ULWSF1=TGEFF*TGEFF*TGEFF*TGEFF*STEFAN
1339 Q2M=0.622*EA/(PSURF-EA)
1340 EVAP=ETMASS*HLAT
1341 CM=(USTAR*USTAR)/(UM*UM)
1342 CH=1/(UM*RA)
1343 !
1344 FM=VKC/CU
1345 FH=VKC/XCT
1346 !
1347 !
1348 EVAPSOIL=EGS /DTT
1349 EVAPWC=ECI /DTT
1350 EVAPDC=ECT /DTT
1351 EVAPSN=EGI /DTT
1352 EVAPGX=EGT /DTT
1353 ELATEN=EVAPSOIL+EVAPWC+EVAPDC+EVAPSN+EVAPGX
1354 XHLFLX=ELATEN/HLAT
1355 GHTFLX=CHF+SHF
1356 !=====================================================================
1357 xhsflx=(hc+hg)/dtt
1358 !=====================================================================
1359 !
1360 CALL CONVDIM(1, &
1361 DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, &
1362 DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, &
1363 DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, &
1364 DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, &
1365 DZO, WO, TSSN, TSSNO, BWO, BTO, CTO, FIO, FLO, BIO, BLO, HO )
1366 !
1367 WWW1=WWW(1)*POROS
1368 WWW2=WWW(2)*POROS
1369 WWW3=WWW(3)*POROS
1370 SNOA = CAPAC(2)
1371 SNOB = CAPAC(1)
1372 !------------------------------------------------
1373 !cfds Convert WEASD back to kg/m2
1374 SNOA = SNOA*1000.
1375 SNOB = SNOB*1000.
1376 !------------------------------------------------
1377 SALB11=SALB(1,1)
1378 SALB12=SALB(1,2)
1379 SALB21=SALB(2,1)
1380 SALB22=SALB(2,2)
1381 !
1382 ! output
1383 !
1384 xlhf = elaten
1385 xshf = xhsflx
1386 xghf = ghtflx
1387 xegs = evapsoil
1388 xeci = evapwc
1389 xect = evapdc
1390 xegi = evapsn
1391 xegt = evapgx
1392 xsdn = fsdown
1393 xsup = fsup
1394 xldn = fldown
1395 xlup = flup
1396 xwat = soilm
1397 xhcx = hc/dtt
1398 xhgx = hg/dtt
1399 xzlt = zlt(1)
1400 xvcf = vcover(1)
1401 xxz0 = z0
1402 xveg = float(itype)
1404 !------------------------------------------------------
1405 END SUBROUTINE SSIB
1406 !------------------------------------------------------
1407 !
1408 !-----------------------------------------------------------------------
1409 !**********************************************
1410 SUBROUTINE SSIB_SEAICE &
1411 ( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE, &
1412 PPL, PPC, RLWDOWN, ZWIND2, &
1413 WWW1, WWW2, WWW3, &
1414 TC, TGS, TD, &
1415 SNOA, ROFF, YICE, &
1416 UMM, VMM, QM, TM, &
1417 PM, PSUR, &
1418 SWDOWN1, SNOB, &
1419 SALB11, SALB12, SALB21, SALB22, &
1420 RADFRAC11, RADFRAC12, RADFRAC21, RADFRAC22, &
1421 XHSFLX, ELATEN, GHTFLX, XHLFLX, TGEFF, &
1422 USTAR, RIB, FM, FH, CM, &
1423 XLHF, XSHF, XGHF, & ! output
1424 XSDN, XSUP, XLDN, XLUP, & ! output
1425 XWAT, XXZ0, & ! output
1426 XVEG, & ! output
1427 DAY, CLOUD, Q2M, TA, BEDO, UV10, &
1428 sw_physics,ice_threshold &
1429 )
1430 !**********************************************
1431 !-----------------------------------------------------------------------
1432 ! THERE ARE A MAIN SSIB PROGRAM AND 12 SUBROUTINE FILES, WHICH ARE:
1433 ! VEGOUT
1434 ! CROPS
1435 ! RADAB
1436 ! ROOT1
1437 ! STOMA1
1438 ! INTERC
1439 ! TEMRS1
1440 ! UPDAT1
1441 ! RASIT5
1442 ! STRES1
1443 ! NEWTON
1444 ! YONGKANG XUE
1445 !-----------------------------------------------------------------------
1446 ! INPUT
1447 ! DDTT: TIME INTERVAL
1448 ! SUNANGLE: SOLAR ZENITH ANGLE
1449 ! SWDOWN: SHORT WAVE DOWN(W/M*M);
1450 ! RADFRAC: SHORT WAVE COMPONENTS (visible and near IR; direct and diffuse)
1451 ! RLWDOWN: LONG WAVE DOWN(W/M*M);
1452 ! PPL, PPC: LARGE SCALE AND CONVECTIVE PRECIPITATIONS AT THE TIME STEP (mm)
1453 ! TM: TEMPERETURE AT LOWEST MODEL LAYER (K)
1454 ! UMM,VMM: ZONAL AND MERIDIONAL WINDS AT LOWEST MODEL LAYER (m/S)
1455 ! QM: WATER VAPOR AT LOWEST MODEL LAYER;
1456 ! PSURF: SURFACE PRESSURE (mb)
1457 ! ZWIND: HEIGHT (m) OF LOWEST MODEL LAYER
1458 ! ITYPE: VEGETATION TYPE
1459 ! ZLAT: LATITUDE, SOUTH POLE IS -90 DEGREE AND NORTH POLE IS 90 DEGREE
1460 ! MONTH: MONTH
1461 ! DAY: CALENDER DATE
1462 ! IYEAR: YEAR
1463 ! OUTPUT
1464 ! ETMASS: EVAPORATION (mm/step)
1465 ! ELATEN: LATENT HEAT FLUX (w/m*m)
1466 ! EVAPSOIL,EVAPWC,EVAPDC,EVAPSN: LATENT HEAT FROM (SOIL, INTERCEPTION,
1467 ! TRANSPIRATION, AND SNOW SURFACE)
1468 ! HFLUX: SENSIBLE HEAT FLUX(w/m*m)
1469 ! GHTFLX: GROUND HEAT FLUX(w/m*m) = CHF+SHF
1470 ! USTAR: FRICTION VELOCITY (m/s)
1471 ! DRAG: MOMENTUM FLUX (kg/m/s**2)
1472 ! DRAGU: U COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
1473 ! DRAGV: V COMPONENT OF MOMENTUM FLUX (kg/m/s**2)
1474 ! TGEFF: RADIATIVE TEMPERATURE (K)
1475 ! BEDO: TOTAL ALBEDO
1476 ! SALB: ALBEDO FOR 4 COMPONENTS
1477 ! RADT: NET RADIATION AT CANOPY AND GROUND LEVELS
1478 ! TGS: SOIL SURFACE TEMPERATURE (K)
1479 ! TC: CANOPY TEMPERATURE (K)
1480 ! TD: DEEP SOIL TEMPERATURE (K)
1481 ! TA: TEMPERATURE AT CANOPY AIR SPACE (K)
1482 ! CAPAC: INTERCEPTION AT CANOPY (1) and SNOW DEPTH (2)
1483 ! WWW: SOIL MOISTURE
1484 ! SOILM: TOTAL SOIL WATER CONTENT
1485 ! ROFF: RUN OFF
1486 !
1487 !----------------------------------------------------------------------
1489 INTEGER, DIMENSION (12) :: IDAYS
1491 REAL, DIMENSION (2) :: CAPAC, SATCAP, GREEN, VCOVER, ZLT, CHIL, TOPT, TL, &
1492 TU, DEFAC, PH1, PH2, RST, ROOTD, RADT, PAR, PD
1493 REAL, DIMENSION (3) :: WWW, SOREF, ZDEPTH, ROOTP, PHSOIL, YMATT, YMATQ
1494 REAL, DIMENSION (2,2) :: RADFRAC, SALB
1495 REAL, DIMENSION (2,3) :: RSTPAR
1496 REAL, DIMENSION (2,4) :: RSTFAC
1497 REAL, DIMENSION (3,2) :: RADN
1498 REAL, DIMENSION (2,3,2) :: TRAN, REF, ALBEDO, EXTK
1500 REAL, DIMENSION (13) :: TD_DEPTH
1501 REAL :: ice_threshold
1502 INTEGER :: sw_physics !choice of SW radiation scheme
1503 !
1504 DATA IDAYS/31,59,90,120,151,181,212,243,273,304,334,366/
1505 !
1506 DATA TD_DEPTH/1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.0, 1.0, 1.0 &
1507 & , 0.5, 0.5, 1.5, 1.5/
1508 !**********************************************
1509 ! The final albedo=original albedo+XADJ
1510 XADJ=0.
1511 ! CTLPA controls stomatal resistance;
1512 ! Final stomatal resistance=ctlpa * stomatal resistance
1513 CTLPA=1.
1514 ! NROOT controls root distribution. nroot=1: root uniformly distributes
1515 ! in the soil layer;
1516 ! If NROOT not =1, root distribution is controled by rootp.
1517 NROOT=1
1518 ! INTG=? TIME INTEGRATION OF SURFACE PHYSICAL VARIABLE IS DONE
1519 ! INTG=2: LEAP-FROG IMPLICIT SCHEME. INTG=1 BACKWORD IMPLICIT SCHEME
1520 INTG=1 !!!!!! in MM5 version hardwired for INTG=1 !!!!!!!!!!!!!
1521 !------------------------------------------------
1522 ITYPE=13
1523 ZWIND=ZWIND2*0.5
1524 !------------------------------------------------
1525 ! set DAY in year and current month MON_COR
1526 !------------------------------------------------
1527 IMONTH=1
1528 IDAY=INT(DAY)
1529 DO I=1,12
1530 IF(IDAY.LE.IDAYS(I)) THEN
1531 IMONTH=I
1532 EXIT
1533 ENDIF
1534 ENDDO
1535 !crr correction for southern hemisphere (reverse months) Ratko, Oct 28, 2005
1536 IF(ZLAT.LT.0.0) THEN
1537 MON_COR=IMONTH+6
1538 IF(MON_COR.GT.12) MON_COR=MON_COR-12
1539 ELSE
1540 MON_COR=IMONTH
1541 ENDIF
1542 !------------------------------------------------
1543 IF (ITIME.EQ.1) TA=TC
1544 !
1545 PSURF=PSUR*0.01
1546 DTT =DDTT*FLOAT(INTG)
1547 !------------------------------------------------
1548 ! ** Read in vegetation parameters
1549 CALL VEGOUT(TRAN,REF,GREEN,VCOVER,CHIL, &
1550 RSTPAR,TOPT,TL,TU,DEFAC,PH1,PH2, &
1551 ZLT,Z0,XDD,Z2,Z1,RDC,RBC,ROOTD,SOREF, &
1552 BEE, PHSAT, POROS, SATCO,SLOPE, &
1553 ZDEPTH,MON_COR,ITYPE)
1554 !
1555 !crr ------------ STC initialization ------------------------------------
1556 IF (ITIME.EQ.1) THEN
1557 STLEV1=0.05 ! half of 10cm layer
1558 STLEV2=1.05 ! half of second + first layer
1560 DEPTH = TD_DEPTH(ITYPE)
1562 IF (DEPTH.GT.STLEV1.AND.DEPTH.LE.STLEV2)THEN ! interp.
1563 TD = ( (STLEV2-DEPTH)*TGS + (DEPTH-STLEV1)*TD ) &
1564 & /(STLEV2-STLEV1)
1565 ELSE IF(DEPTH.GT.STLEV2)THEN ! extrap.
1566 TD = ( (DEPTH-STLEV1)*TD - (DEPTH-STLEV2)*TGS) &
1567 & /(STLEV2-STLEV1)
1568 ENDIF
1569 ENDIF
1570 !------------------------------------------------------------------------
1571 WWW(1) = 1.
1572 WWW(2) = 1.
1573 WWW(3) = 1.
1574 !------------------------------------------------
1575 !cfds Convert WEASD (kg/m2) to meter
1576 SNOA = SNOA/1000.
1577 SNOB = SNOB/1000.
1578 !------------------------------------------------
1579 CAPAC(1)=SNOB
1580 CAPAC(2)=SNOA
1581 SNOWDEN = 3.75 ! mchen add for initialization
1582 ISNOW = 1
1583 IF (ITIME.EQ.1) THEN
1584 TA=TGS
1585 CAPAC(1)=0.
1586 CAPAC(2)=0.
1587 IF (SNOA.GT.0.) CAPAC(1) = ZLT(1) * 0.0001
1588 TC = AMIN1(TC ,273.15)
1589 TGS= AMIN1(TGS,273.15)
1590 TD = AMIN1(TD ,272.50)
1591 ELSE
1592 ! IF( YICE .LT. 0.5 ) THEN ! previous sea, now sea-ice
1593 IF( YICE .LT. ice_threshold ) THEN ! previously water, now sea-ice
1594 CAPAC(1)= 0.
1595 CAPAC(2)= 0.
1596 XADIA = EXP(GASR/CPAIR*LOG(PSUR/PM))
1597 XX = MIN(TM*XADIA,273.15)
1598 TC = MIN(TM*XADIA,273.15)
1599 TGS= MIN(TM*XADIA,273.15)
1600 IF(TD.EQ.0.) TD=272.5
1601 TD = MIN(TD,272.5)
1602 ENDIF
1603 ENDIF
1604 !
1605 UM=SQRT(UMM**2+VMM**2)
1606 RHOAIR=100./GASR*(PSURF+0.01*PM)/(TM+TA)
1607 AKAPPA = GASR/CPAIR
1608 BPS =1.0 / EXP ( AKAPPA * ALOG (0.01*PM/PSURF) )
1609 !
1610 ! CONVERT TO VAPOR PRES. TO MB
1611 EM=(PSURF*QM)/0.6220
1612 IF (ITIME.EQ.1) EA=EM
1613 !
1614 SUNANG=AMAX1(SUNANGLE,0.01746)
1615 !
1616 ! By Zhenxin 2011-06-20
1617 ! IF (sw_physics.eq.3) THEN
1618 IF (sw_physics.eq.3 .or. sw_physics.eq.4) THEN
1619 ! End by Zhenxin 2011-06-20
1621 !**********************************************
1622 !fds - RADFRAC from radiation scheme 3 (06/2010)
1623 !fds - Otherwise use cloud cover to calculate radfrac
1624 radfrac11 = amax1(radfrac11,0.025)
1625 radfrac12 = amax1(radfrac12,0.025)
1626 radfrac21 = amax1(radfrac21,0.025)
1627 radfrac22 = amax1(radfrac22,0.025)
1628 swdown = radfrac11 + radfrac12 + radfrac21 + radfrac22
1629 RADFRAC(1,1) = radfrac11/swdown
1630 RADFRAC(1,2) = radfrac12/swdown
1631 RADFRAC(2,1) = radfrac21/swdown
1632 RADFRAC(2,2) = radfrac22/swdown
1633 ELSE
1634 ! ** CALCULATE THE CLOUD COVER USING AN EMPIRICAL EQUATION
1635 ! ONLY USE THIS PART WHEN IT IS NEEDED
1636 ! ** ONLY USE THIS PART WHEN SW_PHYSICS = 1 IS USED ** By Zhenxin 2011-06
1637 swdown = amax1(swdown1,0.1)
1638 CLOUD = AMAX1(CLOUD,0.0)
1639 CLOUD = AMIN1(CLOUD,1.0)
1640 CLOUD = AMAX1(0.58,CLOUD)
1641 !
1642 DIFRAT = 0.0604 / ( SUNANG-0.0223 ) + 0.0683
1643 IF ( DIFRAT .LT. 0.0 ) DIFRAT = 0.0
1644 IF ( DIFRAT .GT. 1.0 ) DIFRAT = 1.0
1645 !
1646 DIFRAT = DIFRAT + ( 1.0 - DIFRAT ) * CLOUD
1647 VNRAT = ( 580.0 - CLOUD*464.0 ) / ( ( 580.0-CLOUD*499.0) &
1648 & + ( 580.0 - CLOUD*464.0 ) )
1649 !
1650 RADFRAC(1,1) = (1.0-DIFRAT)*VNRAT
1651 RADFRAC(1,2) = DIFRAT*VNRAT
1652 RADFRAC(2,1) = (1.0-DIFRAT)*(1.0-VNRAT)
1653 RADFRAC(2,2) = DIFRAT*(1.0-VNRAT)
1654 !**********************************************
1655 ENDIF
1656 !
1657 RADN(1,1) = RADFRAC(1,1) * SWDOWN
1658 RADN(1,2) = RADFRAC(1,2) * SWDOWN
1659 RADN(2,1) = RADFRAC(2,1) * SWDOWN
1660 RADN(2,2) = RADFRAC(2,2) * SWDOWN
1661 RADN(3,1) = 0.
1662 RADN(3,2) = RLWDOWN
1663 !
1664 ! END OF EMPIRICAL EQUATIONS
1665 ! *********************************************************
1666 !
1667 CALL RADAB_ICE(TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF, &
1668 TC,TGS,SATCAP,EXTK,CLOSS,GLOSS,THERMK,P1F,P2F, &
1669 RADT,PAR,PD,SALB,ALBEDO,TGEFF,SUNANG,XADJ,CAPAC, &
1670 RADN,BEDO,ZLWUP,RADFRAC,SWDOWN,SNOCV,1, &
1671 fsdown,fldown,fsup,flup)
1673 CALL ROOT1(PHSAT,BEE,WWW,PHSOIL)
1675 CALL STOMA1(GREEN,VCOVER,CHIL,ZLT,PAR,PD,EXTK,SUNANG,RST, &
1676 RSTPAR, CTLPA)
1677 !***
1678 POROSAVE=POROS
1679 POROS=0.95
1680 !***
1681 !
1682 CALL INTERC(DTT ,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL,ROFF, &
1683 ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET,EXTK,RNOFFS,FILTR, &
1684 SMELT)
1685 !
1686 CALL TEMRS1(DTT,TC,TGS,TD,TA,TM,QM,EM,PSUR,WWW,CAPAC,SATCAP, &
1687 DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,XDD,Z0,RDC,RBC,VCOVER,Z2, &
1688 ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
1689 ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP, &
1690 THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN, &
1691 BPS,rib,CU,XCT,flup,UV10)
1692 !
1693 CALL UPDAT1_ICE(DTT ,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, &
1694 EGS,EG,HC,HG,HFLUX,ETMASS,FILTR,SOILDIF,SOILDRA,ROFF, &
1695 RNOFFB,RNOFFS,NROOT,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
1696 PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF,SMELT)
1697 !***
1698 POROS=POROSAVE
1699 TD = AMIN1(TD ,273.15)
1700 TC = AMIN1(TC ,273.15)
1701 TGS = AMIN1(TGS,273.15)
1702 !***
1703 !
1704 !------------------------------------------------------------------------
1705 SOILM=(WWW(1)*ZDEPTH(1)+WWW(2)*ZDEPTH(2)+WWW(3)*ZDEPTH(3))*POROS
1706 !------------------------------------------------------------------------
1707 UMOM=RHOAIR*CU*USTAR*UMM
1708 VMOM=RHOAIR*CU*USTAR*VMM
1709 HLFLX= ETMASS/RHOAIR/DTT
1710 HSFLX= HFLUX/CPAIR/RHOAIR/DTT
1711 ULWSF1=TGEFF*TGEFF*TGEFF*TGEFF*STEFAN
1712 Q2M=0.622*EA/(PSURF-EA)
1713 EVAP=ETMASS*HLAT
1714 CM=(USTAR*USTAR)/(UM*UM)
1715 CH=1/(UM*RA)
1716 !
1717 FM=VKC/CU
1718 ! FH=VKC/CT !fds corrected (02/2012)
1719 FH=VKC/XCT
1720 !
1721 !
1722 ELATEN=EVAP/DTT
1723 XHLFLX=ELATEN/HLAT
1724 GHTFLX=CHF+SHF
1725 !=====================================================================
1726 xhsflx=(hc+hg)/dtt
1727 !=====================================================================
1728 !
1729 WWW1=WWW(1)*POROS
1730 WWW2=WWW(2)*POROS
1731 WWW3=WWW(3)*POROS
1732 SNOA = CAPAC(2)
1733 SNOB = CAPAC(1)
1734 SALB11=SALB(1,1)
1735 SALB12=SALB(1,2)
1736 SALB21=SALB(2,1)
1737 SALB22=SALB(2,2)
1738 !
1739 ! later for output
1740 !
1741 xlhf = elaten
1742 xshf = xhsflx
1743 xghf = ghtflx
1744 xsdn = fsdown
1745 xsup = fsup
1746 xldn = fldown
1747 xlup = flup
1748 xwat = soilm
1749 xxz0 = z0
1750 xveg = float(itype)
1751 !
1752 !------------------------------------------------------
1753 END SUBROUTINE SSIB_SEAICE
1754 !------------------------------------------------------
1756 !=======================================================================
1757 !
1758 SUBROUTINE CROPS(XLAT,DAY,CHIL,ZLT,GREEN,XCOVER &
1759 ,RSTPAR,TOPT,TL,TU,DEFAC,PH2,PH1)
1760 !
1761 !=======================================================================
1762 !
1763 ! A NEW CROP VERSION BY XUE. AUG., 1998
1764 !
1765 ! XLAT IS FROM -90 TO 90 DEGREES FROM S. TO N.
1766 !
1767 !----------------------------------------------------------------------
1769 REAL, DIMENSION (2) :: GREEN, XCOVER, CHIL, ZLT, TOPT, TL, TU, DEFAC, PH1, PH2
1770 REAL, DIMENSION (2,3) :: RSTPAR
1771 REAL, DIMENSION (9) :: PHENST, WLAI, WGRN
1773 !
1774 !-----------------------------------------------------------------
1775 !** E J H SD R HRV CUT PRE-E E
1776 ! SAVE WLAI,WGRN,IHEAD,IEND,DEND,IWHEAT,SYR
1777 DATA WLAI/1.0, 2.0, 6.0, 4.0, 3.0, 1.0, 0.01, 0.01, 1.0/
1778 DATA WGRN/0.6, 0.9, 0.8, 0.5, 0.2, 0.1, 0.01, 0.01, 0.6/
1779 DATA IHEAD,IEND,DEND,IWHEAT/3,9,244.,12/,SYR/365.25E0/
1780 IF (XLAT.LT.0.) THEN
1781 RDAY= DAY+184
1782 IF (RDAY.GT.365) RDAY=RDAY-365
1783 ELSE
1784 RDAY= DAY
1785 END IF
1786 JULDAY=INT(RDAY+0.2)
1787 PHI=XLAT
1788 APHI = ABS(PHI)
1789 IF (APHI.GT.55.) PHI=SIGN(55.,PHI)
1790 IF (APHI.LT.20.) PHI=SIGN(20.,PHI)
1791 !
1792 FLIP = 0.0
1793 !
1794 ! ** DETERMINE WHEAT PHENOLOGY FOR LATITUDE AND JULIAN DAY
1795 PHENST(2) = 4.50 *ABS(PHI) - 64.0 + FLIP
1796 PHENST(3) = 4.74 *ABS(PHI) - 46.2 + FLIP
1797 PHENST(4) = 4.86 *ABS(PHI) - 30.8 + FLIP
1798 PHENST(5) = 4.55 *ABS(PHI) - 3.0 + FLIP
1799 PHENST(6) = 4.35 *ABS(PHI) + 11.5 + FLIP
1800 PHENST(7) = PHENST(6) + 3.0
1801 DEMG = ABS( 5.21 *ABS(PHI) - 0.3 )
1802 PHENST(1) = PHENST(2) - DEMG
1803 PHENST(9) = PHENST(1)
1804 PHENST(8) = PHENST(9) - 5.0
1805 !
1806 DO 10 NS = 1,9
1807 IF(PHENST(NS) .LT. 0.0E0)PHENST(NS) = PHENST(NS) + 365.
1808 IF(PHENST(NS) .GT. 365. )PHENST(NS) = PHENST(NS) - 365.
1809 10 CONTINUE
1810 !
1811 ROOTGC = 1.0
1812 CHILW =-0.02
1813 TLAI = 0.5
1814 GRLF = 0.6
1815 !
1816 ! ** FIND GROWTH STAGE GIVEN LATITUDE AND DAY
1817 DO 50 NS = 1,8
1818 TOP = PHENST(NS+1)
1819 BOT = PHENST(NS)
1820 DIFF1 = TOP-BOT
1821 DIFF2 = RDAY-BOT
1822 IF(RDAY.GE. BOT .AND. RDAY .LE. TOP ) GO TO 40
1823 IF(BOT .LT. TOP ) GO TO 50
1824 !
1825 ! ** PHENOLOGY STAGES OVERLAP THE END OF YEAR?
1826 ICOND = 0
1827 IF(RDAY .GE. BOT .AND. RDAY .LE. 365.) ICOND = 1
1828 IF(RDAY .GE. 0.0 .AND. RDAY .LE. TOP ) ICOND = 2
1829 !
1830 IF(ICOND .EQ. 0)GO TO 50
1831 IF(ICOND .EQ. 2)GO TO 35
1832 DIFF1 = 365. - BOT + TOP
1833 DIFF2 = RDAY - BOT
1834 GO TO 40
1835 !
1836 35 CONTINUE
1837 DIFF1 = 365. - BOT + TOP
1838 DIFF2 = 365. - BOT + RDAY
1839 !
1840 ! ** DATE FOUND IN PHENOLOGY STAGE
1841 40 CONTINUE
1842 IF ((RDAY.GT.PHENST(IHEAD)).AND.(RDAY.LE.DEND)) THEN
1843 TLAI=WLAI(IHEAD)
1844 GRLF=WGRN(IHEAD)
1845 GO TO 77
1846 END IF
1847 IF ((RDAY.GT.DEND).AND.(RDAY.LE.PHENST(IEND))) THEN
1848 DIFF1=PHENST(IEND)-DEND
1849 DIFF2=RDAY-DEND
1850 PERC = DIFF2/DIFF1
1851 TLAI = PERC*(WLAI(IEND)-WLAI(IHEAD)) + WLAI(IHEAD)
1852 GRLF = PERC*(WGRN(IEND)-WGRN(IHEAD)) + WGRN(IHEAD)
1853 GO TO 77
1854 END IF
1855 PERC = DIFF2/DIFF1
1856 TLAI = PERC*(WLAI(NS+1)-WLAI(NS)) + WLAI(NS)
1857 GRLF = PERC*(WGRN(NS+1)-WGRN(NS)) + WGRN(NS)
1858 77 CONTINUE
1859 GO TO 95
1860 50 CONTINUE
1861 95 CONTINUE
1862 XCOVER(1)=0.90*(1.0 - EXP(-TLAI))
1863 ZLTGMX = WLAI(IHEAD)
1864 ROOTGC = 2910.0 * (0.5 +0.5 *TLAI/ZLTGMX * GRLF)
1865 IF (NS.NE.1.AND.NS.NE.2) CHILW=-0.2
1866 !
1867 ZLT (1) = TLAI
1868 GREEN (1) = GRLF
1869 CHIL (1) = CHILW
1870 !
1871 !------------------------------------------------------
1872 END SUBROUTINE CROPS
1873 !------------------------------------------------------
1875 !=======================================================================
1876 !
1877 SUBROUTINE ROOT1(PHSAT,BEE,WWW,PHSOIL)
1878 ! 12 AUG 2000
1879 !=======================================================================
1880 !
1881 ! CALCULATION OF SOIL MOISTURE POTENTIALS IN ROOT ZONE OF EACH
1882 ! VEGETATION LAYER AND SUMMED SOIL+ROOT RESISTANCE
1883 !
1884 !-----------------------------------------------------------------------
1885 !----------------------------------------------------------------------
1886 REAL, DIMENSION (3) :: WWW, PHSOIL
1887 !
1888 DO 1000 IL = 1, 3
1889 PHSOIL(IL) = PHSAT * AMAX1( 0.05, WWW(IL) ) ** ( - BEE )
1890 1000 CONTINUE
1891 !
1892 !-----------------------------------------------------------------------
1893 ! AVERAGE SOIL MOISTURE POTENTIAL IN ROOT ZONE USED FOR SOURCE
1894 !-----------------------------------------------------------------------
1895 !
1896 !
1897 ! PHROOT(1) = PHSOIL(1)-0.01
1898 !
1899 ! DO 1200 I = 2 ,3
1900 !1200 PHROOT(1) = AMAX1( PHROOT(1), PHSOIL(I) )
1901 ! PHROOT(2) = PHROOT(1)
1902 !
1903 !
1904 !------------------------------------------------------
1905 END SUBROUTINE ROOT1
1906 !------------------------------------------------------
1908 !=======================================================================
1909 !
1910 SUBROUTINE STOMA1(GREEN,VCOVER,CHIL,ZLT,PAR,PD,EXTK,SUNANG,RST, &
1911 RSTPAR,CTLPA)
1912 ! 12 AUG 2000
1913 !=======================================================================
1914 !
1915 ! CALCULATION OF PAR-LIMITED STOMATAL RESISTANCE
1916 !
1917 !-----------------------------------------------------------------------
1918 !----------------------------------------------------------------------
1920 REAL, DIMENSION (2) :: GREEN, VCOVER, ZLT, CHIL, PAR, PD, RST
1921 REAL, DIMENSION (2,3) :: RSTPAR
1922 REAL, DIMENSION (2,3,2) :: EXTK
1924 !
1925 DO 1000 IVEG = 1, 2
1926 !
1927 AT = ZLT(IVEG) / VCOVER(IVEG)
1928 !
1929 IF (SUNANG .LE. 0.02) THEN
1930 XABC = RSTPAR(IVEG,1) / RSTPAR(IVEG,2) + RSTPAR(IVEG,3)
1931 RST(IVEG) = 0.5 / XABC * AT
1932 IF (RST(IVEG) .LT. 0.) RST(IVEG) = 0.00001
1933 GO TO 1010
1934 END IF
1935 !
1936 GAMMA = ( RSTPAR(IVEG,1) + RSTPAR(IVEG,2) * RSTPAR(IVEG,3) ) / &
1937 RSTPAR(IVEG,3)
1938 !
1939 POWER1 = AMIN1( 50., AT * EXTK(IVEG,1,1) )
1940 POWER2 = AMIN1( 50., AT * EXTK(IVEG,1,2) )
1941 !
1942 !-----------------------------------------------------------------------
1943 ! ROSS INCLINATION FUNCTION
1944 !-----------------------------------------------------------------------
1945 !
1946 AA = 0.5 - 0.633 * CHIL(IVEG)- 0.33 * CHIL(IVEG)* CHIL(IVEG)
1947 BB = 0.877 * ( 1. - 2. * AA )
1948 !
1949 !-----------------------------------------------------------------------
1950 ! COMBINED ESTIMATE OF K-PAR USING WEIGHTS FOR DIFFERENT COMPONENTS
1951 !-----------------------------------------------------------------------
1952 !
1953 ZAT = ALOG( ( EXP(-POWER1) + 1. )/2. ) * PD(IVEG) &
1954 / ( POWER1/AT )
1955 ZAT = ZAT + ALOG( ( EXP(-POWER2) + 1. )/2. ) &
1956 * ( 1. - PD(IVEG) ) / ( POWER2/AT )
1957 !
1958 POW1 = AMIN1( 50., (POWER1*ZAT/AT) )
1959 POW2 = AMIN1( 50., (POWER2*ZAT/AT) )
1960 !
1961 ZK = 1. / ZAT * ALOG( PD(IVEG) * EXP ( POW1 ) &
1962 + ( 1. - PD(IVEG) ) * EXP ( POW2 ) )
1963 !
1964 !
1965 POW = AMIN1( 50., ZK*AT )
1966 EKAT = EXP ( POW )
1967 !
1968 AVFLUX = PAR(IVEG) * ( PD(IVEG) / SUNANG * ( AA + BB * SUNANG ) &
1969 + ( 1. - PD(IVEG) )*( BB / 3. + AA * 1.5 &
1970 + BB / 4. * PIE ))
1971 !
1972 RHO4 = GAMMA / AVFLUX
1973 !
1974 RST(IVEG) = RSTPAR(IVEG,2)/GAMMA * ALOG(( RHO4 * EKAT + 1. ) / &
1975 ( RHO4 + 1. ) )
1976 RST(IVEG) = RST(IVEG) - ALOG (( RHO4 + 1. / EKAT ) / &
1977 ( RHO4 + 1. ) )
1978 RST(IVEG) = RST(IVEG) / ( ZK * RSTPAR(IVEG,3) )
1979 !
1980 !----------------------------------------------------------------------
1981 ! MODIFICATIONS FOR GREEN FRACTION : RST UPRIGHT
1982 !----------------------------------------------------------------------
1983 !
1984 1010 RST(IVEG) = 1. / ( RST(IVEG) * GREEN(IVEG) + 0.0000001)
1985 1000 CONTINUE
1986 !
1987 RST(1) = RST(1) * CTLPA
1988 !
1989 !------------------------------------------------------
1990 END SUBROUTINE STOMA1
1991 !------------------------------------------------------
1993 !=======================================================================
1994 !
1995 SUBROUTINE VEGOUT(XTRAN,XREF,XGREEN,XVCOVER,XCHIL, &
1996 XRSTPAR,XTOPT,XTL,XTU,XDEFAC,XPH1,XPH2, &
1997 XZLT,XZ0,XDD,XZ2,XZ1,XRDC,XRBC,XROOTD,XSOREF, &
1998 XBEE, XPHSAT, XPOROS, XSATCO,XSLOPE, &
1999 XDEPTH,MONTH,ITYPE)
2000 ! 12 AUGUSTY 2000
2001 !=======================================================================
2002 !
2003 ! ASSIGN VEGETATION PHYSIOLOGY
2004 !
2005 ! SURFACE PARAMETERS ARE READ IN SAME ORDER AS IN GCM
2006 ! SUBROUTINE SIBINP. ONLY EXCEPTION IS THAT 1-D VERSION READS IN
2007 ! SITE SPECIFIC PARAMETERS CORB1 ... ZMET .
2008 !
2009 ! VARIABLES THAT ENTER THROUGH COMSIB:
2010 ! SUBSCRIPTS (IV, IW, IL) :
2011 ! IV = VEGETATION STORY; 1 = TOP AND 2 = BOTTOM
2012 ! IW = RADIATION WAVELENGTH; 1 = VISIBLE, 2 = NEAR
2013 ! INFRARED AND 3 = THERMAL INFRARED
2014 ! IL = VEGETATION STATE; 1 = LIVE (GREEN) AND
2015 ! 2 = DEAD (STEMS AND TRUNK)
2016 !
2017 ! TRAN(IV,IW,IL): LEAF TRANSMITTANCE
2018 ! REF (IV,IW,IL): LEAF REFLECTANCE
2019 ! RSTPAR(IV,IW) : PAR-DEPENDENT LEAF STOMATAL RESISTANCE COEFFICIENTS
2020 ! A =(J/M**3) B = 2(W/M**2) C = 3(S/M)
2021 ! SOREF(IW) : SOIL REFLECTANCE
2022 ! CHIL(IV) : LEAF ANGLE DISTRIBUTION FACTOR
2023 ! TOPT(IV) : OPTIMUM TEMPERATURE FOR STOMATAL FUNCTIONING
2024 ! TL(IV) : LOWER TEMPERATURE LIMIT FOR STOMATAL FUNCTIONING
2025 ! TU(IV) : UPPER TEMPERATURE LIMIT FOR STOMATAL FUNCTIONING
2026 ! DEFAC(IV) : VAPOR PRESSURE DEFICIT PARAMETER
2027 ! PH1(IV) :
2028 ! PH2(IV) :
2029 ! ROOTD(IV) : ROOTING DEPTH
2030 ! BEE : SOIL WETNESS EXPONENT
2031 ! PHSAT : SOIL TENSION AT SATURATION
2032 ! SATCO : HYDRAULIC CONDUCTIVITY AT SATURATION
2033 ! POROS : SOIL POROSITY
2034 ! ZDEPTH : DEPTH OF 3 SOIL MOISTURE LAYERS
2035 ! Z0 : ROUGHNESS LENGTH
2036 ! XDD : ZERO PLANE DISPLACEMENT
2037 ! ZLT(IV) : LEAF AREA INDEX
2038 ! GREEN(IV) : GREEN LEAF FRACTION
2039 ! VCOVER(IV) : VEGETATION COVER FRACTION
2040 !
2041 ! VARIABLES ( SPECIFIC TO SIB 1-D VERSION ONLY ) FROM COMSIB
2042 !
2043 ! ZWIND : REFERENCE HEIGHT FOR WIND MEASUREMENT
2044 ! ZMET : REFERENCE HEIGHT FOR TEMPERATURE, HUMIDITY MEASUREMENT
2045 ! THE ABOVE ARE GENERATED FROM SIBX + MOMOPT OUTPUT
2046 !
2047 !----------------------------------------------------------------------
2048 !----------------------------------------------------------------------
2049 ! USE module_ssib_veg
2050 !----------------------------------------------------------------------
2051 !
2052 REAL, DIMENSION (2) :: XGREEN, XVCOVER, XZLT, XCHIL, XTOPT, XTL, &
2053 XTU, XDEFAC, XPH1, XPH2, XROOTD
2054 REAL, DIMENSION (3) :: XSOREF, XDEPTH
2055 REAL, DIMENSION (2,3) :: XRSTPAR
2056 REAL, DIMENSION (2,3,2) :: XTRAN, XREF
2058 !-----------------------------------------------------------------------
2059 !
2060 DO IW=1,3
2061 XTRAN(1,IW,1)=TRAN0(ITYPE,1,IW,1)
2062 XTRAN(1,IW,2)=TRAN0(ITYPE,1,IW,2)
2063 XTRAN(2,IW,1)=TRAN0(ITYPE,2,IW,1)
2064 XTRAN(2,IW,2)=TRAN0(ITYPE,2,IW,2)
2065 XREF (1,IW,1)= REF0(ITYPE,1,IW,1)
2066 XREF (1,IW,2)= REF0(ITYPE,1,IW,2)
2067 XREF (2,IW,1)= REF0(ITYPE,2,IW,1)
2068 XREF (2,IW,2)= REF0(ITYPE,2,IW,2)
2069 XRSTPAR(1,IW)=RSTPAR0(ITYPE,1,IW)
2070 XRSTPAR(2,IW)=RSTPAR0(ITYPE,2,IW)
2071 XSOREF (IW) =SOREF0(ITYPE,IW)
2072 END DO
2073 DO IV=1,2
2074 XCHIL(IV)=CHIL0(ITYPE,IV)
2075 XTOPT(IV)=TOPT0(ITYPE,IV)
2076 XTL(IV)=TL0(ITYPE,IV)
2077 XTU(IV)=TU0(ITYPE,IV)
2078 XDEFAC(IV)=DEFAC0(ITYPE,IV)
2079 XPH1(IV)=PH10(ITYPE,IV)
2080 XPH2(IV)=PH20(ITYPE,IV)
2081 XROOTD(IV)=ROOTD0(ITYPE,IV)
2082 XZLT(IV)=ZLT0(ITYPE,MONTH,IV)
2083 XGREEN(IV)=GREEN0(ITYPE,MONTH,IV)
2084 XVCOVER(IV)=VCOVER0(ITYPE,MONTH,IV)
2085 END DO
2086 DO IDEP=1,3
2087 XDEPTH(IDEP)=DEPTH0(ITYPE,IDEP)
2088 END DO
2089 !
2090 XBEE=BEE0(ITYPE)
2091 XPHSAT=PHSAT0(ITYPE)
2092 XSATCO=SATCO0(ITYPE)
2093 XPOROS=POROS0(ITYPE)
2094 XSLOPE=SLOPE0(ITYPE)
2095 XZ2=Z20(ITYPE,MONTH)
2096 XZ1=Z10(ITYPE,MONTH)
2097 XZ0= Z000(ITYPE,MONTH)
2098 XDD= D0(ITYPE,MONTH)
2099 XRBC=RBC0 (ITYPE,MONTH)
2100 XRDC=RDC0 (ITYPE,MONTH)
2101 !
2102 !------------------------------------------------------
2103 END SUBROUTINE VEGOUT
2104 !------------------------------------------------------
2106 !=======================================================================
2107 !
2108 SUBROUTINE COMBO (DDZ2,DZP,DZM,WP,WM,HP,HM,TP,TM,BWP,BWM,BIP, &
2109 BIM,BLP,BLM,BTP,BTM,FIP,FIM,FLP,FLM,CTP,CTM, &
2110 DLIQVOLP,DLIQVOLM,DICEVOLP,DICEVOLM)
2111 !
2112 !=======================================================================
2113 !
2114 RATIO= DDZ2/dzm
2115 dzp=dzp + RATIO*dzm
2116 wp = wp + RATIO*wm
2117 hp = hp + RATIO*hm
2118 bwp= wp*rhowater/dzp
2119 btp= bwp
2120 ctp= (1.9e6)*(bwp/920.0)
2121 dmlt=wp*rhowater*dlm
2122 if(hp.ge.(-1.0)*dmlt)then
2123 tp=273.16
2124 fip=(-1.0)*hp/dmlt
2125 flp=1.0-fip
2126 blp=bwp*flp
2127 bip=bwp*fip
2128 dliqvolp = blp/rhowater
2129 dicevolp = bip/dice
2130 else
2131 flp=0.0
2132 fip=1.0
2133 tp=(hp+dmlt)/(ctp*dzp)+273.16
2134 bip=bwp
2135 blp=0.0
2136 dliqvolp = 0.0
2137 dicevolp = bip/dice
2138 endif
2139 !
2140 dzm=dzm - RATIO*dzm
2141 wm = wm - RATIO*wm
2142 hm = hm - RATIO*hm
2143 !
2144 !------------------------------------------------------
2145 END SUBROUTINE COMBO
2146 !------------------------------------------------------
2148 !=======================================================================
2149 !
2150 SUBROUTINE COMPACT(BI,T,BL,OVERBURDEN,PDZDT,SS,DICE)
2151 !
2152 !=======================================================================
2153 !clwp 12/11/2000, change the subroutine back to NO DATE form.
2154 data c2,c3,c4,c5/23d-3,2.777d-6,0.04,2.0/
2155 data dm/150/
2156 data eta0/0.9d6/
2157 if(bi .ge. dice .or. ss .ge. 1.) return
2159 ddz1=-c3*exp(-c4*(273.15-t))
2160 if(bi .gt. dm) ddz1=ddz1*exp(-46.0d-3*(bi-dm))
2162 if(bl .gt. 0.01) ddz1=ddz1*c5
2163 !cl compaction due to overburden
2164 ddz2=-overburden*exp(-0.08*(273.15-t)-c2*bi)/eta0
2165 !cl compaction occurring during melt has been taken into account in thermal.f
2166 ddz3=0d0
2167 pdzdt=ddz1+ddz2+ddz3
2168 !
2169 !------------------------------------------------------
2170 END SUBROUTINE COMPACT
2171 !------------------------------------------------------
2173 !=======================================================================
2174 !
2175 SUBROUTINE GETMET(IPTYPE,PRCP_TOTAL,TAIR, &
2176 PRCP_S,PRCP_W,FI_FALL,FL_FALL,BI_FALL,BL_FALL)
2177 !
2178 !=======================================================================
2179 IF (PRCP_TOTAL.gt.0.) THEN
2180 IF(IPTYPE.EQ.2)THEN
2181 PRCP_S=PRCP_TOTAL
2182 PRCP_W=0.0
2183 ELSE IF(IPTYPE.EQ.1)THEN
2184 PRCP_W=PRCP_TOTAL
2185 PRCP_S=0.0
2186 FL_FALL=1.0
2187 FI_FALL=0.
2188 BL_FALL=1000.0
2189 BI_FALL=0.0
2190 ENDIF
2191 ELSE
2192 PRCP_W=0.0
2193 PRCP_S=0.0
2194 IPTYPE = 0
2195 RETURN
2196 END IF
2197 IF (IPTYPE.NE.1) THEN
2198 IF (TAIR .GT. 275.15) THEN
2199 BI_FALL =189
2200 ELSE IF (TAIR.GT.258.16)THEN
2201 BI_FALL=50+1.7*(TAIR-258.16)**1.5d0
2202 ELSE
2203 BI_FALL=50
2204 ENDIF
2206 FL_FALL = 0
2207 FI_FALL=1.0
2208 BL_FALL=0.0
2209 ENDIF
2210 !
2211 !------------------------------------------------------
2212 END SUBROUTINE GETMET
2213 !------------------------------------------------------
2215 !=======================================================================
2216 !
2217 SUBROUTINE INTERCS (DTT,VCOVER,ZLAI,TM,TC,TGS,CAPAC,WWW,PPC,PPL, &
2218 ROFF,ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET, &
2219 EXTK,ISNOW,P0,CSOIL,DZSOIL, &
2220 CHISL,SMELT)
2221 ! 1 AUGUST 1988
2222 !=======================================================================
2223 !
2224 ! CALCULATION OF (1) INTERCEPTION AND DRAINAGE OF RAINFALL AND SNOW
2225 ! (2) SPECIFIC HEAT TERMS FIXED FOR TIME STEP
2226 !
2227 ! MODIFICATION 30 DEC 1985 : NON-UNIFORM PRECIPITATION
2228 ! ------------ CONVECTIVE PPN. IS DESCRIBED BY AREA-INTENSITY
2229 ! RELATIONSHIP :-
2230 !
2231 ! F(X) = A*EXP(-B*X)+C
2232 !
2233 ! THROUGHFALL, INTERCEPTION AND INFILTRATION
2234 ! EXCESS ARE FUNCTIONAL ON THIS RELATIONSHIP
2235 ! AND PROPORTION OF LARGE-SCALE PPN.
2236 !----------------------------------------------------------------------
2237 !
2238 DIMENSION CAPACP(2), SNOWP(2), PCOEFS(2,2)
2239 DATA PCOEFS(1,1)/ 20. /, PCOEFS(1,2)/ .206E-8 /, &
2240 PCOEFS(2,1)/ 0.0001 /, PCOEFS(2,2)/ 0.9999 /, BP /20. /
2241 DIMENSION VCOVER(2),ZLAI(2),WWW(3),CAPAC(2),SATCAP(2),EXTK(2,3,2)
2242 DIMENSION ZDEPTH(3),SNOWW(2)
2243 !
2244 AP = PCOEFS(2,1)
2245 CP = PCOEFS(2,2)
2246 TOTALP = PPC + PPL
2247 IF(TOTALP.LT.1.E-8)GO TO 6000
2248 AP = PPC/TOTALP * PCOEFS(1,1) + PPL/TOTALP * PCOEFS(2,1)
2249 CP = PPC/TOTALP * PCOEFS(1,2) + PPL/TOTALP * PCOEFS(2,2)
2250 6000 CONTINUE
2251 ROFF = 0.
2252 THRU = 0.
2253 FPI = 0.
2254 !
2255 !----------------------------------------------------------------------
2256 ! THERMAL CONDUCTIVITY OF THE SOIL, TAKING INTO ACCOUNT POROSITY
2257 !----------------------------------------------------------------------
2258 !
2259 THETA=WWW(1)*POROS
2260 CHISL=( 9.8E-4+1.2E-3*THETA )/( 1.1-0.4*THETA )
2261 CHISL=CHISL*4.186E2
2262 !
2263 !----------------------------------------------------------------------
2264 ! THERMAL DIFFUSIVITY AND HEAT CAPACITY OF THE SOIL
2265 !----------------------------------------------------------------------
2266 !
2267 DIFSL=5.E-7
2268 !
2269 ROCS =CHISL/DIFSL
2270 D1 =SQRT(DIFSL*86400.0)
2271 CSOIL=ROCS*D1/SQRT(PIE)/2.0
2272 ! YX2002 (test2)
2273 dzsoil=D1/SQRT(PIE)/2.0
2274 THALAS=0.
2275 OCEANS=0.
2276 POLAR=0.
2277 CSOIL=CSOIL*(1.0-THALAS)+10.E10*OCEANS+POLAR*3.6*4.2E4
2278 !
2279 P0 = TOTALP * 0.001
2280 !
2281 !----------------------------------------------------------------------
2282 ! INPUT PRECIPITATION IS GIVEN IN MM, CONVERTED TO M TO GIVE P0.
2283 !----------------------------------------------------------------------
2284 !
2285 DO 1000 IVEG = 1, 2
2286 !
2287 SPWET1 = AMIN1 ( 0.05, CAPAC(IVEG))*CW
2288 !
2289 TS = TC
2290 SPECHT = ZLAI(1) * CLAI
2291 IF ( IVEG .EQ. 1 ) GO TO 1100
2292 TS = TGS
2293 SPECHT = CSOIL
2294 1100 CONTINUE
2295 !
2296 XSC = AMAX1(0., CAPAC(IVEG) - SATCAP(IVEG) )
2297 IF(IVEG.EQ.2 .AND. TS.LE.TF )GO TO 1170
2298 CAPAC(IVEG) = CAPAC(IVEG) - XSC
2299 ROFF = ROFF + XSC
2300 1170 CONTINUE
2301 CAPACP(IVEG) = 0.
2302 SNOWP(IVEG) = 0.
2303 !
2304 IF( TS .GT. TF ) CAPACP(IVEG) = CAPAC(IVEG)
2305 IF( TS .LE. TF ) SNOWP(IVEG) = CAPAC(IVEG)
2306 CAPAC(IVEG) = CAPACP(IVEG)
2307 SNOWW(IVEG) = SNOWP(IVEG)
2308 ZLOAD = CAPAC(IVEG) + SNOWW(IVEG)
2309 !
2310 FPI = ( 1.-EXP( - EXTK(IVEG,3,1) * ZLAI(IVEG)/VCOVER(IVEG) ) ) &
2311 * VCOVER(IVEG)
2312 TTI = P0 * ( 1.-FPI )
2313 !
2314 !----------------------------------------------------------------------
2315 ! PROPORTIONAL SATURATED AREA (XS) AND LEAF DRAINAGE(TEX)
2316 !----------------------------------------------------------------------
2317 !
2318 XS = 1.
2319 IF ( P0 .LT. 1.E-9 ) GO TO 1150
2320 ARG = ( SATCAP(IVEG)-ZLOAD )/( P0*FPI*AP ) -CP/AP
2321 IF ( ARG .LT. 1.E-9 ) GO TO 1150
2322 XS = -1./BP * ALOG( ARG )
2323 XS = AMIN1( XS, 1. )
2324 XS = AMAX1( XS, 0. )
2325 1150 TEX = P0*FPI * ( AP/BP*( 1.- EXP( -BP*XS )) + CP*XS ) - &
2326 ( SATCAP(IVEG) - ZLOAD ) * XS
2327 TEX = AMAX1( TEX, 0. )
2328 !
2329 !----------------------------------------------------------------------
2330 ! TOTAL THROUGHFALL (THRU) AND STORE AUGMENTATION
2331 !----------------------------------------------------------------------
2332 !
2333 THRU = TTI + TEX
2334 IF(IVEG.EQ.2.AND.TGS.LE.TF)THRU = 0.
2335 !
2336 PINF = P0 - THRU
2337 IF( TM .GT. TF ) CAPAC(IVEG) = CAPAC(IVEG) + PINF
2338 IF( TM .LE. TF ) SNOWW(IVEG) = SNOWW(IVEG) + PINF
2339 !
2340 IF( IVEG .EQ. 1 ) GO TO 1300
2341 IF( TM .GT. TF ) GO TO 1200
2342 SNOWW(IVEG) = SNOWP(IVEG) + P0
2343 THRU = 0.
2344 GO TO 1300
2345 !
2346 !----------------------------------------------------------------------
2347 ! INSTANTANEOUS OVERLAND FLOW CONTRIBUTION ( ROFF )
2348 !----------------------------------------------------------------------
2349 !
2350 1200 EQUDEP = SATCO * DTT
2351 !
2352 XS = 1.
2353 IF ( THRU .LT. 1.E-9 ) GO TO 1250
2354 ARG = EQUDEP / ( THRU * AP ) -CP/AP
2355 IF ( ARG .LT. 1.E-9 ) GO TO 1250
2356 XS = -1./BP * ALOG( ARG )
2357 XS = AMIN1( XS, 1. )
2358 XS = AMAX1( XS, 0. )
2359 1250 ROFFO = THRU * ( AP/BP * ( 1.-EXP( -BP*XS )) + CP*XS ) &
2360 -EQUDEP*XS
2361 ROFFO = AMAX1 ( ROFFO, 0. )
2362 ROFF = ROFF + ROFFO
2363 WWW(1) = WWW(1) + (THRU - ROFFO) / ( POROS*ZDEPTH(1) )
2364 1300 CONTINUE
2365 !
2366 !----------------------------------------------------------------------
2367 ! TEMPERATURE CHANGE DUE TO ADDITION OF PRECIPITATION
2368 !----------------------------------------------------------------------
2369 !
2370 DIFF = ( CAPAC(IVEG)+SNOWW(IVEG) - CAPACP(IVEG)-SNOWP(IVEG) )*CW
2371 CCP = SPECHT + SPWET1
2372 CCT = SPECHT + SPWET1 + DIFF
2373 !
2374 TSD = ( TS * CCP + TM * DIFF ) / CCT
2375 !
2376 FREEZE = 0.
2377 IF ( TS .GT. TF .AND. TM .GT. TF ) GO TO 2000
2378 IF ( TS .LE. TF .AND. TM .LE. TF ) GO TO 2000
2379 !
2380 TTA = TS
2381 TTB = TM
2382 CCA = CCP
2383 CCB = DIFF
2384 IF ( TSD .GT. TF ) GO TO 2100
2385 !
2386 !----------------------------------------------------------------------
2387 ! FREEZING OF WATER ON CANOPY OR GROUND
2388 !----------------------------------------------------------------------
2389 !
2390 CCC = CAPACP(IVEG) * SNOMEL
2391 IF ( TS .LT. TM ) CCC = DIFF * SNOMEL / CW
2392 TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
2393 !
2394 FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
2395 FREEZE = (AMIN1 ( CCC, FREEZE )) / SNOMEL
2396 IF(TSD .GT. TF)TSD = TF - 0.1
2397 !
2398 GO TO 2000
2399 !
2400 2100 CONTINUE
2401 !
2402 !----------------------------------------------------------------------
2403 ! MELTING OF SNOW ON CANOPY OR GROUND
2404 !----------------------------------------------------------------------
2405 !
2406 CCC = - SNOWW(IVEG) * SNOMEL
2407 IF ( TS .GT. TM ) CCC = - DIFF * SNOMEL / CW
2408 !
2409 TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
2410 !
2411 FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
2412 FREEZE = (AMAX1( CCC, FREEZE )) / SNOMEL
2413 IF(TSD .LE. TF)TSD = TF - 0.1
2414 !
2415 2000 CONTINUE
2416 !crr
2417 SMELT = FREEZE
2418 !crr
2419 SNOWW(IVEG) = SNOWW(IVEG) + FREEZE
2420 CAPAC(IVEG) = CAPAC(IVEG) - FREEZE
2421 !
2422 IF( IVEG .EQ. 1 ) TC = TSD
2423 IF( IVEG .EQ. 2 ) TGS = TSD
2424 IF( SNOWW(IVEG) .LT. 0.0000001 ) GO TO 3000
2425 ! modeified to force water into soil Xue Feb. 1994
2426 ! ZMELT = 0.
2427 ! IF ( TD .GT. TF ) ZMELT = CAPAC(IVEG)
2428 ! IF ( TD .LE. TF ) ROFF = ROFF + CAPAC(IVEG)
2429 ZMELT = CAPAC(IVEG)
2430 CAPAC(IVEG) = 0.
2431 WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
2432 !
2433 3000 CONTINUE
2434 !
2435 CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
2436 SNOWW(IVEG) = 0.
2437 !
2438 P0 = THRU
2439 IF (ISNOW.eq.0) go to 1001
2440 1000 CONTINUE
2441 !
2442 !----------------------------------------------------------------------
2443 ! CALCULATION OF CANOPY AND GROUND HEAT CAPACITIES.
2444 ! N.B. THIS SPECIFICATION DOES NOT NECESSARILY CONSERVE ENERGY WHEN
2445 ! DEALING WITH VERY LATGE SNOWPACKS.
2446 !----------------------------------------------------------------------
2447 !
2448 1001 CCX = ZLAI(1) * CLAI + CAPAC(1) * CW
2449 SPWET = AMIN1 ( 0.05, CAPAC(2)) * CW
2450 CG = (CSOIL + SPWET)
2451 !
2452 !------------------------------------------------------
2453 END SUBROUTINE INTERCS
2454 !------------------------------------------------------
2455 !=======================================================================
2456 !
2457 SUBROUTINE INTERC(DTT,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL,ROFF, &
2458 ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET,EXTK,RNOFFS,FILTR,SMELT)
2459 ! 12 AUGUST 2000
2460 !=======================================================================
2461 !
2462 ! CALCULATION OF (1) INTERCEPTION AND DRAINAGE OF RAINFALL AND SNOW
2463 ! (2) SPECIFIC HEAT TERMS FIXED FOR TIME STEP
2464 !
2465 ! MODIFICATION 30 DEC 1985 : NON-UNIFORM PRECIPITATION
2466 ! ------------ CONVECTIVE PPN. IS DESCRIBED BY AREA-INTENSITY
2467 ! RELATIONSHIP :-
2468 !
2469 ! F(X) = A*EXP(-B*X)+C
2470 !
2471 ! THROUGHFALL, INTERCEPTION AND INFILTRATION
2472 ! EXCESS ARE FUNCTIONAL ON THIS RELATIONSHIP
2473 ! AND PROPORTION OF LARGE-SCALE PPN.
2474 !----------------------------------------------------------------------
2475 !----------------------------------------------------------------------
2476 !
2477 REAL, DIMENSION (2) :: VCOVER, ZLT, CAPAC, SATCAP, SNOWW, CAPACP, SNOWP
2478 REAL, DIMENSION (3) :: WWW, ZDEPTH
2479 REAL, DIMENSION (2,2) :: PCOEFS
2480 REAL, DIMENSION (2,3,2) :: EXTK
2482 DATA PCOEFS(1,1)/ 20. /, PCOEFS(1,2)/ .206E-8 /, &
2483 PCOEFS(2,1)/ 0.0001 /, PCOEFS(2,2)/ 0.9999 /, BP /20. /
2484 !
2485 AP = PCOEFS(2,1)
2486 CP = PCOEFS(2,2)
2487 TOTALP = PPC + PPL
2488 IF(TOTALP.LT.1.E-8)GO TO 6000
2489 AP = PPC/TOTALP * PCOEFS(1,1) + PPL/TOTALP * PCOEFS(2,1)
2490 CP = PPC/TOTALP * PCOEFS(1,2) + PPL/TOTALP * PCOEFS(2,2)
2491 6000 CONTINUE
2492 !
2493 ROFF = 0.
2494 THRU = 0.
2495 FPI = 0.
2496 !
2497 !----------------------------------------------------------------------
2498 ! THERMAL CONDUCTIVITY OF THE SOIL, TAKING INTO ACCOUNT POROSITY
2499 !----------------------------------------------------------------------
2500 !
2501 THETA=WWW(1)*POROS
2502 CHISL=( 9.8E-4+1.2E-3*THETA )/( 1.1-0.4*THETA )
2503 CHISL=CHISL*4.186E2
2504 !
2505 !
2506 !----------------------------------------------------------------------
2507 ! THERMAL DIFFUSIVITY AND HEAT CAPACITYOF THE SOIL
2508 !----------------------------------------------------------------------
2509 !
2510 DIFSL=5.E-7
2511 !
2512 ROCS =CHISL/DIFSL
2513 D1 =SQRT(DIFSL*86400.0)
2514 CSOIL=ROCS*D1/SQRT(PIE)/2.0
2515 THALAS=0.
2516 OCEANS=0.
2517 POLAR=0.
2518 CSOIL=CSOIL*(1.0-THALAS)+10.E10*OCEANS+POLAR*3.6*4.2E4
2519 !
2520 P0 = TOTALP * 0.001
2521 !
2522 !----------------------------------------------------------------------
2523 ! INPUT PRECIPITATION IS GIVEN IN MM, CONVERTED TO M TO GIVE P0.
2524 !----------------------------------------------------------------------
2525 !
2526 DO 1000 IVEG = 1, 2
2527 !
2528 SPWET1 = AMIN1 ( 0.05, CAPAC(IVEG))*CW
2529 !
2530 TS = TC
2531 SPECHT = ZLT(1) * CLAI
2532 IF ( IVEG .EQ. 1 ) GO TO 1100
2533 TS = TGS
2534 SPECHT = CSOIL
2535 1100 CONTINUE
2536 !
2537 XSC = AMAX1(0., CAPAC(IVEG) - SATCAP(IVEG) )
2538 IF(IVEG.EQ.2 .AND. TS.LE.TF )GO TO 1170
2539 CAPAC(IVEG) = CAPAC(IVEG) - XSC
2540 ROFF = ROFF + XSC
2541 RNOFFS = XSC*1000. + RNOFFS
2542 1170 CONTINUE
2543 CAPACP(IVEG) = 0.
2544 SNOWP(IVEG) = 0.
2545 !
2546 IF( TS .GT. TF ) CAPACP(IVEG) = CAPAC(IVEG)
2547 IF( TS .LE. TF ) SNOWP(IVEG) = CAPAC(IVEG)
2548 CAPAC(IVEG) = CAPACP(IVEG)
2549 SNOWW(IVEG) = SNOWP(IVEG)
2550 ZLOAD = CAPAC(IVEG) + SNOWW(IVEG)
2551 !
2552 FPI = ( 1.-EXP( - EXTK(IVEG,3,1) * ZLT(IVEG)/VCOVER(IVEG) ) ) &
2553 * VCOVER(IVEG)
2554 TTI = P0 * ( 1.-FPI )
2555 !
2556 !----------------------------------------------------------------------
2557 ! PROPORTIONAL SATURATED AREA (XS) AND LEAF DRAINAGE(TEX)
2558 !----------------------------------------------------------------------
2559 !
2560 XS = 1.
2561 IF ( P0 .LT. 1.E-9 ) GO TO 1150
2562 ARG = ( SATCAP(IVEG)-ZLOAD )/( P0*FPI*AP ) -CP/AP
2563 IF ( ARG .LT. 1.E-9 ) GO TO 1150
2564 XS = -1./BP * ALOG( ARG )
2565 XS = AMIN1( XS, 1. )
2566 XS = AMAX1( XS, 0. )
2567 1150 TEX = P0*FPI * ( AP/BP*( 1.- EXP( -BP*XS )) + CP*XS ) - &
2568 ( SATCAP(IVEG) - ZLOAD ) * XS
2569 TEX = AMAX1( TEX, 0. )
2570 !
2571 !----------------------------------------------------------------------
2572 ! TOTAL THROUGHFALL (THRU) AND STORE AUGMENTATION
2573 !----------------------------------------------------------------------
2574 !
2575 THRU = TTI + TEX
2576 IF(IVEG.EQ.2.AND.TGS.LE.TF)THRU = 0.
2577 !
2578 PINF = P0 - THRU
2579 IF( TM .GT. TF ) CAPAC(IVEG) = CAPAC(IVEG) + PINF
2580 IF( TM .LE. TF ) SNOWW(IVEG) = SNOWW(IVEG) + PINF
2581 !
2582 IF( IVEG .EQ. 1 ) GO TO 1300
2583 IF( TM .GT. TF ) GO TO 1200
2584 SNOWW(IVEG) = SNOWP(IVEG) + P0
2585 THRU = 0.
2586 GO TO 1300
2587 !
2588 !----------------------------------------------------------------------
2589 ! INSTANTANEOUS OVERLAND FLOW CONTRIBUTION ( ROFF )
2590 !----------------------------------------------------------------------
2591 !
2592 1200 EQUDEP = SATCO * DTT
2593 !
2594 XS = 1.
2595 IF ( THRU .LT. 1.E-9 ) GO TO 1250
2596 ARG = EQUDEP / ( THRU * AP ) -CP/AP
2597 IF ( ARG .LT. 1.E-9 ) GO TO 1250
2598 XS = -1./BP * ALOG( ARG )
2599 XS = AMIN1( XS, 1. )
2600 XS = AMAX1( XS, 0. )
2601 1250 ROFFO = THRU * ( AP/BP * ( 1.-EXP( -BP*XS )) + CP*XS ) &
2602 -EQUDEP*XS
2603 ROFFO = AMAX1 ( ROFFO, 0. )
2604 ROFF = ROFF + ROFFO
2605 RNOFFS = RNOFFS + ROFFO*1000.
2606 FILTR = FILTR + (THRU - ROFFO)
2607 WWW(1) = WWW(1) + (THRU - ROFFO) / ( POROS*ZDEPTH(1) )
2608 1300 CONTINUE
2609 !
2610 !----------------------------------------------------------------------
2611 ! TEMPERATURE CHANGE DUE TO ADDITION OF PRECIPITATION
2612 !----------------------------------------------------------------------
2613 !
2614 DIFF = ( CAPAC(IVEG)+SNOWW(IVEG) - CAPACP(IVEG)-SNOWP(IVEG) )*CW
2615 CCP = SPECHT + SPWET1
2616 CCT = SPECHT + SPWET1 + DIFF
2617 !
2618 TSD = ( TS * CCP + TM * DIFF ) / CCT
2619 !
2620 FREEZE = 0.
2621 IF ( TS .GT. TF .AND. TM .GT. TF ) GO TO 2000
2622 IF ( TS .LE. TF .AND. TM .LE. TF ) GO TO 2000
2623 !
2624 TTA = TS
2625 TTB = TM
2626 CCA = CCP
2627 CCB = DIFF
2628 IF ( TSD .GT. TF ) GO TO 2100
2629 !
2630 !----------------------------------------------------------------------
2631 ! FREEZING OF WATER ON CANOPY OR GROUND
2632 !----------------------------------------------------------------------
2633 !
2634 CCC = CAPACP(IVEG) * SNOMEL
2635 IF ( TS .LT. TM ) CCC = DIFF * SNOMEL / CW
2636 TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
2637 !
2638 FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
2639 FREEZE = (AMIN1 ( CCC, FREEZE )) / SNOMEL
2640 IF(TSD .GT. TF)TSD = TF - 0.1
2641 !
2642 GO TO 2000
2643 !
2644 2100 CONTINUE
2645 !
2646 !----------------------------------------------------------------------
2647 ! MELTING OF SNOW ON CANOPY OR GROUND
2648 !----------------------------------------------------------------------
2649 !
2650 CCC = - SNOWW(IVEG) * SNOMEL
2651 IF ( TS .GT. TM ) CCC = - DIFF * SNOMEL / CW
2652 !
2653 TSD = ( TTA * CCA + TTB * CCB + CCC ) / CCT
2654 !
2655 FREEZE = ( TF * CCT - ( TTA * CCA + TTB * CCB ) )
2656 FREEZE = (AMAX1( CCC, FREEZE )) / SNOMEL
2657 IF(TSD .LE. TF)TSD = TF - 0.1
2658 !
2659 2000 CONTINUE
2660 SMELT = FREEZE
2661 SNOWW(IVEG) = SNOWW(IVEG) + FREEZE
2662 CAPAC(IVEG) = CAPAC(IVEG) - FREEZE
2663 !
2664 IF( IVEG .EQ. 1 ) TC = TSD
2665 IF( IVEG .EQ. 2 ) TGS = TSD
2666 IF( SNOWW(IVEG) .LT. 0.0000001 ) GO TO 3000
2667 ZMELT = 0.
2668 ! modified to force water into soil. Xue Feb. 1994
2669 ZMELT = CAPAC(IVEG)
2670 ! IF ( TD .GT. TF ) ZMELT = CAPAC(IVEG)
2671 ! IF ( TD .LE. TF ) ROFF = ROFF + CAPAC(IVEG)
2672 CAPAC(IVEG) = 0.
2673 WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
2674 FILTR = FILTR + ZMELT
2675 !
2676 3000 CONTINUE
2677 !
2678 CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
2679 SNOWW(IVEG) = 0.
2680 !
2681 ! **** LOAD PILPS PARAMETER
2682 !
2683 ! if (freeze.lt.0) snm(istat)=snm(istat)-freeze
2684 freeze=0.0
2685 !
2686 P0 = THRU
2687 !
2688 1000 CONTINUE
2689 !
2690 !----------------------------------------------------------------------
2691 ! CALCULATION OF CANOPY AND GROUND HEAT CAPACITIES.
2692 ! N.B. THIS SPECIFICATION DOES NOT NECESSARILY CONSERVE ENERGY WHEN
2693 ! DEALING WITH VERY LATGE SNOWPACKS.
2694 !----------------------------------------------------------------------
2695 !
2696 CCX = ZLT(1) * CLAI + CAPAC(1) * CW
2697 SPWET = AMIN1 ( 0.05, CAPAC(2))*CW
2698 CG = (CSOIL + SPWET)
2699 !
2700 !------------------------------------------------------
2701 END SUBROUTINE INTERC
2702 !------------------------------------------------------
2703 !=======================================================================
2704 !
2705 SUBROUTINE LAYER1 (CSOIL,TGS,DZSOIL,H,W,SNOWDEPTH,SWE,STEMP,ND)
2706 !
2707 !=======================================================================
2708 parameter (dice=920.0, rhowater=1000.0,dlm=3.335d5)
2709 dimension h(nd),w(nd)
2710 swe=w(1)+w(2)+w(3)
2711 ! YX2002 (test2)
2712 snh=h(1)+h(2)+h(3)+csoil*(tgs-273.16)
2713 ! snh=h(1)+h(2)+h(3)+csoil*(tgs-273.16)*dzsoil
2714 dmlto=swe*dlm*rhowater
2715 scv=1.9e+6*(swe/snowdepth)/dice
2716 if (snh.gt.0.0) then
2717 ! YX2002 (test2)
2718 stemp=snh/(swe*4.18*10**6.+csoil)+273.16
2719 ! stemp=snh/(swe*4.18*10**6.+csoil*dzsoil)+273.16
2720 else if (snh.gt.-dmlto) then
2721 stemp=273.16
2722 else
2723 ! YX2002 (test2)
2724 stemp=(snh+dmlto)/(scv*snowdepth+csoil)+273.16
2725 ! stemp=(snh+dmlto)/(scv*snowdepth+csoil*dzsoil)+273.16
2726 end if
2727 !
2728 !------------------------------------------------------
2729 END SUBROUTINE LAYER1
2730 !------------------------------------------------------
2732 !=======================================================================
2733 !
2734 SUBROUTINE LAYERN (TG,SNOW_WE,SNOW_DEPTH, DZ0,BW0,W0,BT0,CT0, &
2735 FL0,FI0,H0,BL0,BI0,DLIQV0,DICEV0,TSSN0,DMLT0)
2736 !
2737 !=======================================================================
2738 DIMENSION DZ0(4),W0(4),BW0(4),BT0(4),CT0(4),FL0(4),FI0(4),H0(4), &
2739 BL0(4),BI0(4),DLIQV0(4),DICEV0(4),TSSN0(4),DMLT0(4)
2740 ! ------------------------------------------------------------------7272
2741 IF(SNOW_DEPTH.GT.0.05.AND.SNOW_DEPTH.LE.0.06) THEN
2742 DZ0(1)=0.02
2743 DZ0(2)=0.02
2744 DZ0(3)=SNOW_DEPTH- DZ0(1)- DZ0(2)
2745 ELSE IF ( SNOW_DEPTH.GT.0.06.AND.SNOW_DEPTH.LE.0.08) THEN
2746 DZ0(3)=0.02
2747 DZ0(2)=0.02
2748 DZ0(1)=SNOW_DEPTH- DZ0(3)- DZ0(2)
2749 ELSE IF ( SNOW_DEPTH.GT.0.08.AND.SNOW_DEPTH.LE.0.62) THEN
2750 DZ0(3)=0.02
2751 DZ0(2)=(SNOW_DEPTH- DZ0(3))*0.33333333
2752 DZ0(1)=(SNOW_DEPTH- DZ0(3))*0.66666667
2753 ELSE IF ( SNOW_DEPTH.GT.0.62) THEN
2754 DZ0(3)=0.02
2755 DZ0(2)=0.20
2756 DZ0(1)=SNOW_DEPTH- DZ0(3)- DZ0(2)
2757 End IF
2758 do 777 i=1,N
2759 TSSN0(I)=TG
2760 BW0(I)=SNOW_WE*RHOWATER/SNOW_DEPTH
2761 777 continue
2762 !---------------------------------------------------------------------
2763 ! Next we will calculate the initial variables for time step going on
2764 !---------------------------------------------------------------------
2765 do 666 i=1,N
2766 W0(I)=(BW0(I)*DZ0(I))/RHOWATER
2767 BT0(I)=BW0(I)
2768 CT0(I)=(BW0(I)/920.0)*1.9e+6
2769 IF (TSSN0(I).EQ.273.16)THEN
2770 FL0(I)= FLMIN
2771 FI0(I)=1.0- FLMIN
2772 H0(I)=(-1.0)*W0(I)*FI0(I)*DLM*RHOWATER
2773 BL0(I)=BW0(I)*FL0(I)
2774 BI0(I)=BW0(I)*FI0(I)
2775 DLIQV0(I) = BL0(I)/RHOWATER
2776 DICEV0(I) = BI0(I)/DICE
2777 ELSE IF(TSSN0(I).LT.273.16) THEN
2778 FL0(I)=0.0
2779 FI0(I)=1.0
2780 DMLT0(I)=W0(I)*DLM*RHOWATER
2781 H0(I)=(TSSN0(I)-273.16)*CT0(I)*DZ0(I)-DMLT0(I)
2782 BL0(I)=0.0
2783 BI0(I)=BW0(I)
2784 DLIQV0(I)=0.0
2785 DICEV0(I) = BI0(I)/DICE
2786 ENDIF
2787 666 continue
2788 !
2789 !------------------------------------------------------
2790 END SUBROUTINE LAYERN
2791 !------------------------------------------------------
2793 !=======================================================================
2794 !
2795 SUBROUTINE MODNODE(SNOWDEPTH,DZO,WO,HO,TSSNO,BWO,BIO, &
2796 BLO,BTO,FIO,FLO,CTO,DLIQVOL,DICEVOL)
2797 !
2798 !=======================================================================
2799 DIMENSION DZO(N1),WO(N1),HO(N1),TSSNO(N1),BWO(N1),BIO(N1),BLO(N1), &
2800 BTO(N1),FIO(N1),FLO(N1),CTO(N1),DLIQVOL(N1),DICEVOL(N1)
2802 !clwp 10/30/2000, for the adjustment of layers 2,3
2803 IF (SNOWDEPTH.le.0.06) then
2804 DZ1=0.02
2805 DZ2=0.02
2806 DZ3=SNOWDEPTH-( DZ2+DZ1)
2807 ELSE IF (SNOWDEPTH.gt.0.06) then
2808 DZ3=0.02
2809 ENDIF
2810 ! to get the expected change of top layer of snow
2811 DDZ3=DZ3-dzo(3)
2812 ! to get the expected change of top layer of snow
2813 IF (DDZ3.GT.0.0) THEN
2814 DDZ3=MIN(DDZ3,dzo(2))
2815 CALL COMBO (DDZ3,dzo(3),dzo(2),wo(3),wo(2),ho(3),ho(2), &
2816 tssno(3),tssno(2),bwo(3),bwo(2),bio(3),bio(2),blo(3),blo(2), &
2817 bto(3),bto(2),fio(3),fio(2),flo(3),flo(2),cto(3),cto(2), &
2818 dliqvol(3),dliqvol(2),dicevol(3),dicevol(2))
2819 ELSE
2820 DDZ3=-DDZ3
2821 CALL COMBO (DDZ3,dzo(2),dzo(3),wo(2),wo(3),ho(2),ho(3), &
2822 tssno(2),tssno(3),bwo(2),bwo(3),bio(2),bio(3),blo(2),blo(3), &
2823 bto(2),bto(3),fio(2),fio(3),flo(2),flo(3),cto(2),cto(3), &
2824 dliqvol(2),dliqvol(3),dicevol(2),dicevol(3))
2825 END IF
2826 !clwp 10/30/2000, for the adjustment of layers 1,2
2827 SUM12=dzo(1)+dzo(2)
2828 IF (SNOWDEPTH.le.0.06) THEN
2829 DZ2=0.5*SUM12
2830 ELSE IF (SNOWDEPTH.gt.0.06.and.SNOWDEPTH.le.0.08) THEN
2831 DZ2=0.02
2832 ELSE IF (SNOWDEPTH.gt.0.08.and.SNOWDEPTH.le.0.62) THEN
2833 DZ2=0.33333333*SUM12
2834 ELSE IF (SNOWDEPTH.gt.0.62) THEN
2835 DZ2=0.20
2836 ENDIF
2837 ! to get the expected change of middle layer of snow
2838 DDZ2=DZ2-dzo(2)
2839 ! to get the expected change of middle layer of snow
2840 IF (DDZ2.GT.0.0) THEN
2841 CALL COMBO (DDZ2,dzo(2),dzo(1),wo(2),wo(1),ho(2),ho(1), &
2842 tssno(2),tssno(1),bwo(2),bwo(1),bio(2),bio(1),blo(2),blo(1), &
2843 bto(2),bto(1),fio(2),fio(1),flo(2),flo(1),cto(2),cto(1), &
2844 dliqvol(2),dliqvol(1),dicevol(2),dicevol(1))
2845 ELSE
2846 DDZ2=-DDZ2
2847 CALL COMBO (DDZ2,dzo(1),dzo(2),wo(1),wo(2),ho(1),ho(2), &
2848 tssno(1),tssno(2),bwo(1),bwo(2),bio(1),bio(2),blo(1),blo(2), &
2849 bto(1),bto(2),fio(1),fio(2),flo(1),flo(2),cto(1),cto(2), &
2850 dliqvol(1),dliqvol(2),dicevol(1),dicevol(2))
2851 END IF
2852 SNOWDEPTH=dzo(1)+dzo(2)+dzo(3)
2853 !
2854 !------------------------------------------------------
2855 END SUBROUTINE MODNODE
2856 !------------------------------------------------------
2858 !=======================================================================
2859 !
2860 SUBROUTINE NEWSNOW(PRCP,BIFALL,BLFALL,FLFALL,TKAIR, &
2861 DZO,WO,BWO,CTO,HO,DMLTO,FIO,FLO,BIO,BLO,DLIQVOL,DICEVOL,TSSNO,WF)
2862 !
2863 !=======================================================================
2864 ! ------------------------------------------------------------------7272
2865 !! calculate rate of change in element thickness due to snow falling
2866 !! Precip has just started or previous top node is full. Initiate a
2867 !! new node.
2868 !clwp 12/08/2000, since this subroutine only deals with the top layer,
2869 !clwp change the original AA(n) to AA, in other words replace arrays.
2870 ! ------------------------------------------------------------------7272
2871 dzfall=prcp*rhowater/bifall
2872 dzo=dzo+dzfall
2873 wo=wo+prcp
2874 bwo=(wo*rhowater)/dzo
2875 cto=1.9e+6*(bwo/920.0)
2876 dum=(tkair-273.16)*cto*dzfall &
2877 -(1.0-flfall)*(blfall+bifall)*dlm*dzfall
2878 ho=ho+dum
2879 dmlto=wo*rhowater*dlm
2880 if (ho.ge.-dmlto) then
2881 tssno=273.16
2882 fio=-ho/dmlto
2883 flo=1.0-fio
2884 blo=bwo*flo
2885 bio=bwo*fio
2886 dliqvol=blo/rhowater
2887 dicevol=bio/dice
2888 else
2889 !!!!! when snow temperature is below 273.16
2890 fio=1.0
2891 flo=0.0
2892 bio=bwo
2893 blo=0.0
2894 dliqvol=0.0
2895 dicevol=bio/dice
2896 wf=0.0
2897 tssno=(ho+dmlto)/(cto*dzo)+273.16
2898 end if
2899 !
2900 !------------------------------------------------------
2901 END SUBROUTINE NEWSNOW
2902 !------------------------------------------------------
2904 !=======================================================================
2905 !
2906 SUBROUTINE NEWTON(A1,Y,FINC,NOX,NONPOS,IWOLK,L,ZINC,A2,Y1,ITER)
2907 !
2908 !=======================================================================
2909 !
2910 !-----------------------------------------------------------------------
2911 ! ** VERSION ACQUIRED FROM EROS 2/19/86.
2912 !
2913 ! ** THE NEWTON RAPHSON ITERATIVE ROUTINE WILL BE USED TO GENERATE NEW
2914 ! ** VALUES OF A1 IF DABSOLUTE VALUE OF Y IS GREATER THAN ERTOL;
2915 ! ** A1 IS ESTIMATE, Y IS RESULTANT ERROR
2916 ! ** NEX IS EXIT CONDITION (0=NO EXIT) OR (1 WHEN DABS(Y) LT ERTOL)
2917 ! ** ERTOL IS THE DABSOLUTE VALUE OF Y NECESSARY TO OBTAIN AN EXIT
2918 ! ** FINC IS INITIAL INCREMENT SIZE FOR SECOND ESTIMATE OF A1
2919 ! ** NONPOS=0 IF QUANTITY TO BE MINIMIZED CAN BE LESS THAN ZERO;
2920 ! ** NONPOS=1 IF QUANTITY CAN ONLY BE POSITIVE
2921 ! ** L IDENTIFIES WHICH QUANTITY IS BEING CALCULATED.
2922 !
2923 ! ** CONTROL VALUES: FINC,ERTOL,NOX,NONPOS,L:MUST BE SET BY USER
2924 !-----------------------------------------------------------------------
2925 !
2926 !fds Changes according to Jack (Feb/2008)
2927 REAL, DIMENSION (3) :: IWALK, NEX, ITER
2928 REAL, DIMENSION (3) :: ZINC, A2, Y1
2930 !fds DIMENSION IWALK(3), NEX(3)
2931 !fds DIMENSION ZINC(3), A2(3), Y1(3),ITER3(3)
2932 DATA CONS/1.0/
2933 !
2934 ERTOL = 0.05 * FINC
2935 IWALK(L) = IWOLK
2936 NEX(L)=NOX
2937 !
2938 IF ( ITER(L) .GE. 490 ) GO TO 160
2939 IF (ERTOL .LT. 0.00000001) ERTOL=0.000001
2940 IF (ABS(Y) .LE. ERTOL) GO TO 150
2941 IF((ABS(Y-Y1(L))).LE.0.01*ERTOL .AND. IWALK(L).EQ.0 ) GO TO 8
2942 !
2943 IF(ABS(Y1(L)).GT.ERTOL) GO TO 1
2944 A2(L)=A1
2945 A1=A1-Y
2946 NEX(L)=0
2947 Y1(L)=Y
2948 ITER(L)=1
2949 IF (IWALK(L) .EQ. 3) GO TO 101
2950 IWALK(L)=0
2951 GO TO 101
2952 1 ITER(L)=ITER(L)+1
2953 IF(ITER(L) .EQ. 10) IWALK(L)=1
2954 IF(IWALK(L) .NE. 0) GO TO 2
2955 IF(ABS(Y) .GT. ERTOL) GO TO 3
2956 NEX(L)=1
2957 GO TO 150
2958 3 A=A1-Y*(A1-A2(L))/(Y-Y1(L))
2959 IF(ABS(A-A1).GT.(10.0*FINC)) &
2960 A=A1+10.0*FINC*SIGN(CONS,(A-A1))
2961 A2(L)=A1
2962 A1=A
2963 Y1(L)=Y
2964 GO TO 101
2965 2 IF(IWALK(L).EQ.2)GO TO 4
2966 IF(IWALK(L).EQ.3) GO TO 6
2967 IF(SIGN(CONS,Y).EQ.SIGN(CONS,Y1(L))) GO TO 3
2968 ZINC(L)=(A1-A2(L))/4.0
2969 A1=A2(L)+ZINC(L)
2970 IWALK(L)=2
2971 NEX(L)=0
2972 GO TO 101
2973 4 IF(SIGN(CONS,Y) .EQ.SIGN(CONS,Y1(L))) GO TO 5
2974 ZINC(L)=-ZINC(L)/4.0
2975 A2(L)=A1
2976 A1=A1+ZINC(L)
2977 NEX(L)=0
2978 Y1(L)=Y
2979 GO TO 101
2980 5 A2(L)=A1
2981 A1=A1+ZINC(L)
2982 Y1(L)=Y
2983 NEX(L)=0
2984 GO TO 101
2985 6 IF(SIGN(CONS,Y).EQ.SIGN(CONS,Y1(L))) GO TO 7
2986 IWALK(L)=1
2987 GO TO 2
2988 7 A2(L) = A1
2989 A1 = A1+FINC
2990 Y1(L)=Y
2991 NEX(L) = 0
2992 GO TO 101
2993 8 A1 = A1 + FINC*2.0
2994 NEX(L)=0
2995 GO TO 101
2996 160 CONTINUE
2997 900 FORMAT ( 3X,' FAILURE TO CONVERGE AFTER 490 ITERATIONS', &
2998 /, 3X,' Y = ',2G12.5,2X,I14)
2999 150 NEX(L) = 1
3000 ZINC(L)=0.0
3001 ITER(L) = 0
3002 IWALK(L)=0
3003 Y1(L)=0.0
3004 Y=0.0
3005 A2(L)=0.0
3006 101 CONTINUE
3007 IF(NONPOS.EQ.1.AND.A1.LT.0.0) A1=A2(L)/2.0
3008 NOX = NEX(L)
3009 IWOLK = IWALK(L)
3010 !
3011 !------------------------------------------------------
3012 END SUBROUTINE NEWTON
3013 !------------------------------------------------------
3015 !=======================================================================
3016 !
3017 SUBROUTINE OLD(TSSN,BW,BL,BI,H,FL,FI,W,DZ,SS,CT,BT,DMLT, &
3018 TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO,SSO,CTO,BTO,DMLTO)
3019 !
3020 !=======================================================================
3021 DIMENSION TSSN(N1),BW(N1),BL(N1),BI(N1),H(N1),FL(N1),FI(N1), &
3022 W(N1),DZ(N1),SS(N1),CT(N1),BT(N1),DMLT(N1), TSSNO(N1), &
3023 BWO(N1),BLO(N1),BIO(N1),HO(N1),FLO(N1),FIO(N1), &
3024 WO(N1),DZO(N1),SSO(N1),CTO(N1),BTO(N1),DMLTO(N1)
3025 DO 20 I=1,N
3026 TSSNO(I)=TSSN(I)
3027 BWO(I)=BW(I)
3028 BLO(I)=BL(I)
3029 BIO(I)=BI(I)
3030 HO(I)=H(I)
3031 FLO(I)=FL(I)
3032 FIO(I)=FI(I)
3033 WO(I)=W(I)
3034 DZO(I)=DZ(I)
3035 SSO(I)=SS(I)
3036 CTO(I)=CT(I)
3037 BTO(I)=BT(I)
3038 DMLTO(I)=DMLT(I)
3039 20 CONTINUE
3040 !
3041 !------------------------------------------------------
3042 END SUBROUTINE OLD
3043 !------------------------------------------------------
3045 !=======================================================================
3046 !
3047 SUBROUTINE RADAB (TRAN,REF,GREEN,VCOVER,CHIL,ZLAI,Z2,Z1,SOREF,TC, &
3048 TGS,SATCAP,EXTK,RADFAC,THERMK,RADT,PAR,PD,ALBEDO,SALB, &
3049 TGEFF,SUNANG,XADJ,CAPAC,RADN,ZLWUP,FRAC, &
3050 ISNOW,SNOWDEN,SNOWDEPTH,SWDOWN,XALBEDO,SCOV2,ISICE, &
3051 fsdown,fldown,fsup,flup)
3052 ! 1 AUGUST 1988
3053 !=======================================================================
3054 !
3055 ! CALCULATION OF ALBEDOS VIA TWO STREAM APPROXIMATION( DIRECT
3056 ! AND DIFFUSE ) AND PARTITION OF RADIANT ENERGY
3057 !
3058 !cl CLOSS=2.*VCOVER(1)*(1.-THERMK)*STEFAN*TC**4
3059 !cl -VCOVER(1)*(1.-THERMK)*STEFAN*TGS**4
3060 !cl GLOSS=STEFAN*TGS**4 - VCOVER(1)*(1.-THERMK)*STEFAN*TC**4
3061 !-----------------------------------------------------------------------
3062 DIMENSION TRANC1(2), TRANC2(2), TRANC3(2)
3063 DIMENSION CAPAC(2), SATCAP(2), TRAN(2,3,2), REF(2,3,2), SOREF(3)
3064 DIMENSION GREEN(2), VCOVER(2), ZLAI(2), CHIL(2), RADN(3,2),RADT(2)
3065 DIMENSION RADFAC(2,2,2), RADSAV(12), PAR(2), PD(2), ALBEDO(2,3,2)
3066 DIMENSION SALB(2,2), EXTK(2,3,2), FRAC(2,2)
3067 DIMENSION sr(2)
3068 data sr/0.85,0.65/
3069 ! dimension sibalbedo(12,31,24),sibswup(12,31,24)
3070 !
3071 !crr F = SUNANG
3072 f=max(sunang,0.01746)
3073 !crr ratko, 08/03/2004
3074 !crr xref1=1.20
3075 !crr xref2=0.40
3076 xref1=1.05
3077 xref2=0.20
3078 !
3079 !----------------------------------------------------------------------
3080 ! CALCULATION OF MAXIMUM WATER STORAGE VALUES.
3081 !----------------------------------------------------------------------
3082 !
3083 FMELT = 1.
3084 IF ( ABS(TF-TGS) .LT. 0.5 ) FMELT = 0.6
3085 SATCAP(1) = ZLAI(1) * 0.0001
3086 SATCAP(2) = ZLAI(2) * 0.0001
3087 !CS------------------------- Sun change following DEPCOV 10/13/98
3088 IF (ISNOW.eq.0) THEN
3089 DEPCOV = AMAX1( 0., (SNOWDEPTH-Z1))
3090 ELSE
3091 DEPCOV = AMAX1( 0., (CAPAC(2)*SNOWDEN-Z1))
3092 END IF
3093 !CS-----------------------------------------------------------10/13/98
3094 DEPCOV = AMIN1( DEPCOV, (Z2-Z1)*0.95 )
3095 SATCAP(1) = SATCAP(1) * ( 1. - DEPCOV / ( Z2 - Z1 ) )
3096 !crr - thermal part is in use in temrs1 & temrs2
3097 do 202 iveg = 1, 2
3098 do 202 iwave = 1, 3
3099 do 202 irad = 1, 2
3100 albedo(iveg,iwave,irad)=0.
3101 202 continue
3102 !crr
3103 !----------------------------------------------------------------------
3104 !
3105 DO 1000 IWAVE = 1, 2
3106 !
3107 DO 2000 IVEG = 2, 1,-1
3108 !----------------------------------------------------------------------
3109 ! MODIFICATION FOR EFFECT OF SNOW ON UPPER STOREY ALBEDO
3110 ! SNOW REFLECTANCE = 0.80, 0.40 . MULTIPLY BY 0.6 IF MELTING
3111 ! SNOW TRANSMITTANCE = 0.20, 0.54
3112 !crr snow reflectance now 0.85, 0.65 (see xref1, xref2)
3113 !
3114 !----------------------------------------------------------------------
3115 SCOV = 0.
3116 IF( IVEG .EQ. 2 ) GO TO 100
3117 IF( TC .LE. TF ) SCOV = AMIN1( 0.5, CAPAC(1) / SATCAP(1) )
3118 100 CONTINUE
3119 REFF1 = ( 1. - SCOV ) * REF(IVEG,IWAVE,1) + SCOV * ( xref1 - &
3120 IWAVE * xref2 ) * FMELT
3121 REFF2 = ( 1. - SCOV ) * REF(IVEG,IWAVE,2) + SCOV * ( xref1 - &
3122 IWAVE * xref2 ) * FMELT
3123 TRAN1 = TRAN(IVEG,IWAVE,1) * ( 1. - SCOV ) &
3124 + SCOV * ( 1.- ( xref1 - IWAVE * xref2 ) * FMELT ) &
3125 * TRAN(IVEG,IWAVE,1)
3126 TRAN2 = TRAN(IVEG,IWAVE,2) * ( 1. - SCOV ) &
3127 + SCOV * ( 1.- ( xref1 - IWAVE * xref2 ) * FMELT ) * 0.9 &
3128 * TRAN(IVEG,IWAVE,2)
3129 !
3130 !----------------------------------------------------------------------
3131 !
3132 SCAT = GREEN(IVEG)*( TRAN1 + REFF1 ) +( 1. - GREEN(IVEG) ) * &
3133 ( TRAN2 + REFF2)
3134 CHIV = CHIL(IVEG)
3135 !
3136 IF ( ABS(CHIV) .LE. 0.01 ) CHIV = 0.01
3137 AA = 0.5 - 0.633 * CHIV - 0.33 * CHIV * CHIV
3138 BB = 0.877 * ( 1. - 2. * AA )
3139 !
3140 PROJ = AA + BB * F
3141 EXTKB = ( AA + BB * F ) / F
3142 ZMEW = 1. / BB * ( 1. - AA / BB * ALOG ( ( AA + BB ) / AA ) )
3143 ACSS = SCAT / 2. * PROJ / ( PROJ + F * BB )
3144 ACSS = ACSS * ( 1. - F * AA / ( PROJ + F * BB ) * ALOG ( ( PROJ &
3145 + F * BB + F * AA ) / ( F * AA ) ) )
3146 !
3147 EXTK( IVEG, IWAVE, 1 ) = PROJ / F * SQRT( 1.-SCAT )
3148 EXTK( IVEG, IWAVE, 2 ) = 1. / ZMEW * SQRT( 1.-SCAT )
3149 EXTK( IVEG, 3, 1 ) = AA + BB
3150 EXTK( IVEG, 3, 2 ) = 1./ZMEW
3151 !
3152 UPSCAT = GREEN(IVEG) * TRAN1 + ( 1. - GREEN(IVEG) ) * TRAN2
3153 UPSCAT = 0.5 * ( SCAT + ( SCAT - 2. * UPSCAT ) * &
3154 (( 1. - CHIV ) / 2. ) ** 2 )
3155 !
3156 BETAO = ( 1. + ZMEW * EXTKB ) / ( SCAT * ZMEW * EXTKB ) * ACSS
3157 !
3158 !----------------------------------------------------------------------
3159 !
3160 ! DICKINSON'S VALUES
3161 !
3162 BE = 1. - SCAT + UPSCAT
3163 CE = UPSCAT
3164 BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
3165 IF ( ABS(BOT) .GT. 1.E-10) GO TO 200
3166 SCAT = SCAT* 0.98
3167 BE = 1. - SCAT + UPSCAT
3168 BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
3169 200 CONTINUE
3170 DE = SCAT * ZMEW * EXTKB * BETAO
3171 FE = SCAT * ZMEW * EXTKB * ( 1. - BETAO )
3172 !----------------------------------------------------------------------
3173 !
3174 CCE = DE * BE - ZMEW * DE * EXTKB + CE * FE
3175 FFE = BE * FE + ZMEW * FE * EXTKB + CE * DE
3176 !
3177 TORE = -CCE / BOT
3178 SIGE = -FFE / BOT
3179 !
3180 PSI = SQRT(BE**2 - CE**2)/ZMEW
3181 !
3182 !----------------------------------------------------------------------
3183 ! REDUCTION IN EXPOSED HEIGHT OF UPPER STOREY AS SNOW ACCUMULATES
3184 !
3185 !CS Sun Change following SDEP to SDEP=snowdepth on 10/13/98
3186 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
3187 IF (ISNOW.eq.0) THEN
3188 SDEP=SNOWDEPTH
3189 ELSE
3190 SDEP = CAPAC(2) *SNOWDEN
3191 END IF
3192 !CS
3193 FAC = ( SDEP - Z1 ) / ( Z2 - Z1 )
3194 FAC = AMAX1( 0., FAC )
3195 FAC = AMIN1( 0.99, FAC )
3196 !
3197 ZAT = ZLAI(IVEG) / VCOVER(IVEG)
3198 IF ( IVEG .EQ. 1 ) ZAT = ZAT * (1.-FAC)
3199 !
3200 POWER1 = AMIN1( PSI*ZAT, 50. )
3201 POWER2 = AMIN1( EXTKB*ZAT, 50. )
3202 EPSI = EXP( - POWER1 )
3203 EK = EXP ( - POWER2 )
3204 !
3205 ROSB = SOREF(IWAVE)
3206 ROSD = SOREF(IWAVE)
3207 IF ( IVEG .EQ. 2 ) GO TO 300
3208 ROSB = ALBEDO(2,IWAVE,1)
3209 ROSD = ALBEDO(2,IWAVE,2)
3210 300 CONTINUE
3211 !
3212 GE = ROSB / ROSD
3213 !
3214 !-----------------------------------------------------------------------
3215 ! CALCULATION OF DIFFUSE ALBEDOS
3216 !-----------------------------------------------------------------------
3217 !
3218 F1 = BE - CE / ROSD
3219 ZP = ZMEW * PSI
3220 !
3221 DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
3222 ( BE - ZP ) * ( F1 + ZP ) * EPSI
3223 ALPHA = CE * ( F1 - ZP ) / EPSI / DEN
3224 BETA = -CE * ( F1 + ZP ) * EPSI / DEN
3225 F1 = BE - CE * ROSD
3226 DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
3227 !
3228 GAMMA = ( F1 + ZP ) / EPSI / DEN
3229 DELTA = - ( F1 - ZP ) * EPSI / DEN
3230 !
3231 ALBEDO(IVEG,IWAVE,2) = ALPHA + BETA
3232 ! XQQ(IVEG,IWAVE,2) = ALBEDO(IVEG, IWAVE, 2)
3233 !
3234 IF ( IVEG .EQ. 1 ) GO TO 400
3235 SCOV2 = 0.
3236 IF ( TGS .LE. TF ) SCOV2 = AMIN1( 1., CAPAC(2) / 0.004 )
3237 !crr CORRECTION FOR KEEPING ALBEDO HIGH OVER SNOW
3238 IF (ISICE.EQ.1) SCOV2=1.
3239 !crr
3240 ALBEDO(2,IWAVE,2) = &
3241 ROSD * ( 1. - VCOVER(2) ) + ALBEDO(2,IWAVE,2) * VCOVER(2)
3242 ALBEDO(2,IWAVE,2) = &
3243 ( 1. - SCOV2 ) * ALBEDO(2,IWAVE,2) + SCOV2 * &
3244 ( xref1-IWAVE*xref2 ) * &
3245 FMELT
3246 400 CONTINUE
3247 !
3248 TRANC2(IWAVE) = GAMMA * EPSI + DELTA / EPSI
3249 !
3250 !-----------------------------------------------------------------------
3251 ! CALCULATION OF DIRECT ALBEDOS
3252 !-----------------------------------------------------------------------
3253 !
3254 F1 = BE - CE / ROSD
3255 ZMK = ZMEW * EXTKB
3256 !
3257 DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
3258 ( BE - ZP ) * ( F1 + ZP ) * EPSI
3259 ALPHA = ( DE - TORE * ( BE + ZMK ) ) * ( F1 - ZP ) / EPSI - &
3260 ( BE - ZP ) * ( DE - CE*GE - TORE * ( F1 + ZMK ) ) * EK
3261 ALPHA = ALPHA / DEN
3262 BETA = ( BE + ZP ) * (DE - CE*GE - TORE * ( F1 + ZMK ))* EK - &
3263 ( DE - TORE * ( BE + ZMK ) ) * ( F1 + ZP ) * EPSI
3264 BETA = BETA / DEN
3265 F1 = BE - CE * ROSD
3266 DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
3267 GAMMA = - SIGE * ( F1 + ZP ) / EPSI - &
3268 ( FE + CE * GE * ROSD + SIGE * ( ZMK - F1 ) ) * EK
3269 GAMMA = GAMMA / DEN
3270 DELTA = ( CE * GE * ROSD + FE + SIGE * ( ZMK - F1 ) ) * EK &
3271 + SIGE * ( F1 - ZP ) * EPSI
3272 DELTA = DELTA / DEN
3273 !
3274 ALBEDO(IVEG,IWAVE,1) = TORE + ALPHA + BETA
3275 ! XQQ(IVEG,IWAVE,1) = ALBEDO(IVEG, IWAVE, 1)
3276 !----------------------------------------------------------------------
3277 !
3278 IF( IVEG .EQ. 1 ) GO TO 500
3279 ALBEDO(2,IWAVE,1) = ROSB * ( 1. - VCOVER(2) ) &
3280 + ALBEDO(2,IWAVE,1) * VCOVER(2)
3281 ALBEDO(2,IWAVE,1) = ( 1. - SCOV2 ) * ALBEDO(2,IWAVE,1) + &
3282 SCOV2 * ( xref1-IWAVE*xref2 ) * FMELT
3283 !
3284 500 CONTINUE
3285 !
3286 TRANC1(IWAVE) = EK
3287 TRANC3(IWAVE) = SIGE * EK + GAMMA * EPSI + DELTA / EPSI
3288 !
3289 2000 CONTINUE
3290 !----------------------------------------------------------------------
3291 ! CALCULATION OF TERMS WHICH MULTIPLY INCOMING SHORT WAVE FLUXES
3292 ! TO GIVE ABSORPTION OF RADIATION BY CANOPY AND GROUND
3293 !----------------------------------------------------------------------
3294 !
3295 RADFAC(2,IWAVE,1) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,1) ) &
3296 + VCOVER(1) * ( TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
3297 + TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
3298 !
3299 RADFAC(2,IWAVE,2) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,2) ) &
3300 + VCOVER(1) * TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) )
3301 !
3302 RADFAC(1,IWAVE,1) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,1) ) &
3303 - TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
3304 - TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
3305 !
3306 RADFAC(1,IWAVE,2) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,2) ) &
3307 - TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
3308 !
3309 ! XQQ(1,IWAVE,1) = RADFAC(1,IWAVE,1)
3310 ! XQQ(1,IWAVE,2) = RADFAC(1,IWAVE,2)
3311 ! XQQ(2,IWAVE,1) = RADFAC(2,IWAVE,1)
3312 ! XQQ(2,IWAVE,2) = RADFAC(2,IWAVE,2)
3313 !----------------------------------------------------------------------
3314 ! CALCULATION OF TOTAL SURFACE ALBEDOS ( SALB )
3315 !----------------------------------------------------------------------
3316 !
3317 DO 3000 IRAD = 1, 2
3318 SALB(IWAVE,IRAD) = ( 1.-VCOVER(1) ) * ALBEDO(2,IWAVE,IRAD) + &
3319 VCOVER(1) * ALBEDO(1,IWAVE,IRAD)
3320 3000 CONTINUE
3321 !----------------------------------------------------------------------
3322 ! SAVING OF EXTINCTION COEFFICIENTS ( PAR ) FOR STOMAT CALCULATION
3323 !----------------------------------------------------------------------
3324 IF ( IWAVE .EQ. 2 ) GO TO 600
3325 RADSAV(1) = 1. - VCOVER(1) &
3326 + VCOVER(1) * ( TRANC1(IWAVE) + TRANC3(IWAVE) )
3327 RADSAV(2) = 1. - VCOVER(1) + VCOVER(1) * TRANC2(IWAVE)
3328 ! XQQ(1,1,1) = RADSAV(1)
3329 ! XQQ(1,2,1) = RADSAV(2)
3330 600 CONTINUE
3331 !
3332 1000 CONTINUE
3333 !
3334 ! albedo adjustment ==============================================
3335 if (xadj.eq.0.) go to 730
3336 xx = radfac(1,1,2) + radsav(2)
3337 xy = radfac(1,1,1) + radsav(1)
3338 ssum = salb(1,1)*frac(1,1) + salb(1,2)*frac(1,2)+ &
3339 salb(2,1)*frac(2,1) + salb(2,2)*frac(2,2)
3340 ! for diffuse albedo
3341 do 650 iwave = 1, 2
3342 salb(iwave,2) = salb(iwave,2) + xadj * salb(iwave,2) / ssum
3343 x0 = 1. - salb(iwave,2)
3344 x1 = radfac(1,iwave,2) + radfac(2,iwave,2)
3345 x2 = radfac(1,iwave,2) / x1
3346 x3 = radfac(2,iwave,2) / x1
3347 radfac(1,iwave,2) = x0 * x2
3348 radfac(2,iwave,2) = x0 * x3
3349 650 continue
3350 640 format(1x,'unrealistic value, dif',2i12,4e11.4)
3351 ! for direct albedo
3352 do 750 iwave = 1, 2
3353 salb(iwave,1) = salb(iwave,1) + xadj * salb(iwave,1) / ssum
3354 x0 = 1. - salb(iwave,1)
3355 x1 = radfac(1,iwave,1) + radfac(2,iwave,1)
3356 x2 = radfac(1,iwave,1) / x1
3357 x3 = radfac(2,iwave,1) / x1
3358 radfac(1,iwave,1) = x0 * x2
3359 radfac(2,iwave,1) = x0 * x3
3360 radsav(1) = xy - radfac(1,1,1)
3361 radsav(2) = xx - radfac(1,1,2)
3362 750 continue
3363 740 format(1x,'unrealistic value',2i12,4e11.4)
3364 730 continue
3365 !--------------- end adjustment ------------------------------
3366 !cl 2001,1,26 remove the following lines
3367 ! sibswup(nmm,ndd,nhh) = radn(1,1)*salb(1,1) + radn(1,2)*salb(1,2)
3368 ! & + radn(2,1)*salb(2,1) + radn(2,2)*salb(2,2)
3369 ! if ((swdown.gt.0.1).and.(sibswup(nmm,ndd,nhh).gt.0.1)) then
3370 ! sibalbedo(nmm,ndd,nhh) = sibswup(nmm,ndd,nhh) / swdown
3371 ! if (sibalbedo(nmm,ndd,nhh).gt.1.) then
3372 ! sibswup(nmm,ndd,nhh) = 0.
3373 ! sibalbedo(nmm,ndd,nhh) = 999.
3374 ! write (6, *) 'albebo incorrect',nymdh,sibalbedo(nmm,ndd,nhh)
3375 ! endif
3376 ! else
3377 ! sibswup(nmm,ndd,nhh) = 0.0
3378 ! sibalbedo(nmm,ndd,nhh) = 999.
3379 ! endif
3380 swup = radn(1,1)*salb(1,1) + radn(1,2)*salb(1,2) &
3381 + radn(2,1)*salb(2,1) + radn(2,2)*salb(2,2)
3382 if ((swdown.gt.0.01).and.(swup.gt.0.01)) then
3383 xalbedo = swup / swdown
3384 if (xalbedo.gt.1.) then
3385 swup = 0.
3386 xalbedo = 999.
3387 write (6, *) 'albebo incorrect',xalbedo
3388 endif
3389 else
3390 swup = 0.0
3391 xalbedo = .1
3392 endif
3393 !----------------------------------------------------------------------
3394 ! CALCULATION OF LONG-WAVE FLUX TERMS FROM CANOPY AND GROUND
3395 !----------------------------------------------------------------------
3396 !
3397 TC4 = TC * TC * TC * TC
3398 TG4 = TGS * TGS * TGS * TGS
3399 !
3400 ZKAT = EXTK(1,3,2) * ZLAI(1) / VCOVER(1)
3401 ZKAT = AMIN1( 50. , ZKAT )
3402 ZKAT = AMAX1( 1.E-5, ZKAT )
3403 THERMK = EXP(-ZKAT)
3404 !
3405 FAC1 = VCOVER(1) * ( 1.-THERMK )
3406 FAC2 = 1.
3407 CLOSS = 2. * FAC1 * STEFAN * TC4
3408 CLOSS = CLOSS - FAC2 * FAC1 * STEFAN * TG4
3409 GLOSS = FAC2 * STEFAN * TG4
3410 GLOSS = GLOSS - FAC1 * FAC2 * STEFAN * TC4
3411 !
3412 ZLWUP = FAC1 * STEFAN * TC4 + (1. - FAC1 ) * FAC2 * STEFAN * TG4
3413 TGEFF = SQRT( SQRT ( ( ZLWUP / STEFAN ) ) )
3414 !
3415 RADSAV(3) = EXTK(1,1,1)
3416 RADSAV(4) = EXTK(1,1,2)
3417 RADSAV(5) = EXTK(2,1,1)
3418 RADSAV(6) = EXTK(2,1,2)
3419 RADSAV(7) = THERMK
3420 RADSAV(8) = EXTK(1,3,1)
3421 RADSAV(9) = EXTK(2,3,1)
3422 RADSAV(10)= CLOSS
3423 RADSAV(11)= GLOSS
3424 RADSAV(12)= TGEFF
3425 !-----------------------------------------------------------------------
3426 !
3427 !cl CALL LONGRN( TRANC1, TRANC2, TRANC3)
3428 !-----------------------------------------------------------------------
3429 !
3430 !cl CALL RADUSE
3431 !---------------------------- subroutine RADUSE -----------------------
3432 !
3433 ! CALCULATION OF ABSORPTION OF RADIATION BY SURFACE
3434 !-----------------------------------------------------------------------
3435 P1F = RADSAV(1)
3436 P2F = RADSAV(2)
3437 !cl 2001,1,26, redundant to the above lines
3438 !cl EXTK(1,1,1) = RADSAV(3)
3439 ! EXTK(1,1,2) = RADSAV(4)
3440 ! EXTK(2,1,1) = RADSAV(5)
3441 ! EXTK(2,1,2) = RADSAV(6)
3442 ! THERMK = RADSAV(7)
3443 ! EXTK(1,3,1) = RADSAV(8)
3444 ! EXTK(2,3,1) = RADSAV(9)
3445 ! CLOSS = RADSAV(10)
3446 ! GLOSS = RADSAV(11)
3447 !cl TGEFF = RADSAV(12)
3448 !----------------------------------------------------------------------
3449 !
3450 ! SUMMATION OF SHORT-WAVE RADIATION ABSORBED BY CANOPY AND GROUND
3451 !----------------------------------------------------------------------
3452 RADT(1) = 0.
3453 RADT(2) = 0.
3454 !
3455 DO 7000 IVEG = 1, 2
3456 DO 7000 IWAVE = 1, 2
3457 DO 7000 IRAD = 1, 2
3458 !
3459 RADT(IVEG) = RADT(IVEG)+RADFAC(IVEG,IWAVE,IRAD)*RADN(IWAVE,IRAD)
3460 !
3461 7000 CONTINUE
3462 !=========================================================================
3463 fsdown = radn(1,1)+radn(1,2)+radn(2,1)+radn(2,2)
3464 fsup = fsdown-radt(1)-radt(2)
3465 !=========================================================================
3466 !
3467 SWCAN=RADT(1)
3468 SWGND=RADT(2)
3469 RADT(1) = RADT(1) + RADN(3,2)*VCOVER(1)*(1.- THERMK) &
3470 - CLOSS
3471 RADT(2) = RADT(2) + RADN(3,2)*( 1.-VCOVER(1)*(1-THERMK) ) &
3472 - GLOSS
3473 !=========================================================================
3474 fldown = radn(3,2)
3475 flup = closs+gloss
3476 !=========================================================================
3477 !
3478 PAR(1) = RADN(1,1) + RADN(1,2) + 0.001
3479 PD(1) = ( RADN(1,1) + 0.001 ) / PAR(1)
3480 P1 = P1F * RADN(1,1) + 0.001
3481 P2 = P2F * RADN(1,2)
3482 PAR(2) = P1 + P2
3483 PD(2) = P1 / PAR(2)
3484 !
3485 !------------------------------------------------------
3486 END SUBROUTINE RADAB
3487 !------------------------------------------------------
3488 !=======================================================================
3489 !
3490 SUBROUTINE RADAB_ICE(TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF, &
3491 TC,TGS,SATCAP,EXTK,CLOSS,GLOSS,THERMK,P1F,P2F, &
3492 RADT,PAR,PD,SALB,ALBEDO,TGEFF,SUNANG,XADJ,CAPAC, &
3493 RADN,bedo,ZLWUP,RADFRAC,SWDOWN,SCOV2,ISICE, &
3494 fsdown,fldown,fsup,flup)
3495 ! 11 AUGUST 2000
3496 !=======================================================================
3497 !
3498 ! CALCULATION OF ALBEDOS VIA TWO STREAM APPROXIMATION( DIRECT
3499 ! AND DIFFUSE ) AND PARTITION OF RADIANT ENERGY
3500 !
3501 !-----------------------------------------------------------------------
3502 !----------------------------------------------------------------------
3504 REAL, DIMENSION (2) :: TRANC1, TRANC2, TRANC3, CAPAC, SATCAP, &
3505 GREEN, VCOVER, ZLT, CHIL, RADT, PAR, PD
3506 REAL, DIMENSION (3) :: SOREF
3507 REAL, DIMENSION (2,2) :: RADFRAC, SALB
3508 REAL, DIMENSION (3,2) :: RADN
3509 REAL, DIMENSION (2,2,2) :: RADFAC
3510 REAL, DIMENSION (2,3,2) :: TRAN, REF, ALBEDO, EXTK
3511 REAL, DIMENSION (12) :: RADSAV
3512 !
3513 f=max(sunang,0.01746)
3514 !
3515 !----------------------------------------------------------------------
3516 ! CALCULATION OF MAXIMUM WATER STORAGE VALUES.
3517 !----------------------------------------------------------------------
3518 !
3519 FMELT = 1.
3520 IF ( ABS(TF-TGS) .LT. 0.5 ) FMELT = 0.6
3521 SATCAP(1) = ZLT(1) * 0.0001
3522 SATCAP(2) = ZLT(2) * 0.0001
3523 DEPCOV = AMAX1( 0., (CAPAC(2)*5.-Z1) )
3524 DEPCOV = AMIN1( DEPCOV, (Z2-Z1)*0.95 )
3525 SATCAP(1) = SATCAP(1) * ( 1. - DEPCOV / ( Z2 - Z1 ) )
3526 !----------------------------------------------------------------------
3527 do 202 iveg = 1, 2
3528 do 202 iwave = 1, 3
3529 do 202 irad = 1, 2
3530 albedo(iveg,iwave,irad)=0.
3531 202 continue
3532 !----------------------------------------------------------------------
3533 DO 1000 IWAVE = 1,2
3534 !
3535 DO 2000 IVDUM = 1,2
3536 IF ( IVDUM .EQ. 1 ) IVEG = 2
3537 IF ( IVDUM .EQ. 2 ) IVEG = 1
3538 !----------------------------------------------------------------------
3539 !----------------------------------------------------------------------
3540 ! MODIFICATION FOR EFFECT OF SNOW ON UPPER STOREY ALBEDO
3541 ! SNOW REFLECTANCE = 0.80, 0.40 . MULTIPLY BY 0.6 IF MELTING
3542 ! SNOW TRANSMITTANCE = 0.20, 0.54
3543 ! SNOW REFLECTANCE = 0.85, 0.65 . MULTIPLY BY 0.6 IF MELTING
3544 !
3545 !----------------------------------------------------------------------
3546 SCOV = 0.
3547 IF( IVEG .EQ. 2 ) GO TO 100
3548 IF( TC .LE. TF ) SCOV = AMIN1( 0.5, CAPAC(1) / SATCAP(1) )
3549 100 CONTINUE
3550 REFF1 = ( 1. - SCOV ) * REF(IVEG,IWAVE,1) + SCOV * ( 1.2 - &
3551 IWAVE * 0.4 ) * FMELT
3552 REFF2 = ( 1. - SCOV ) * REF(IVEG,IWAVE,2) + SCOV * ( 1.2 - &
3553 IWAVE * 0.4 ) * FMELT
3554 TRAN1 = TRAN(IVEG,IWAVE,1) * ( 1. - SCOV ) &
3555 + SCOV * ( 1.- ( 1.2 - IWAVE * 0.4 ) * FMELT ) &
3556 * TRAN(IVEG,IWAVE,1)
3557 TRAN2 = TRAN(IVEG,IWAVE,2) * ( 1. - SCOV ) &
3558 + SCOV * ( 1.- ( 1.2 - IWAVE * 0.4 ) * FMELT ) * 0.9 &
3559 * TRAN(IVEG,IWAVE,2)
3561 !----------------------------------------------------------------------
3562 !
3563 SCAT = GREEN(IVEG)*( TRAN1 + REFF1 ) +( 1. - GREEN(IVEG) ) * &
3564 ( TRAN2 + REFF2)
3565 CHIV = CHIL(IVEG)
3566 !
3567 IF ( ABS(CHIV) .LE. 0.01 ) CHIV = 0.01
3568 AA = 0.5 - 0.633 * CHIV - 0.33 * CHIV * CHIV
3569 BB = 0.877 * ( 1. - 2. * AA )
3570 !
3571 PROJ = AA + BB * F
3572 EXTKB = ( AA + BB * F ) / F
3573 ZMEW = 1. / BB * ( 1. - AA / BB * ALOG ( ( AA + BB ) / AA ) )
3574 ACSS = SCAT / 2. * PROJ / ( PROJ + F * BB )
3575 ACSS = ACSS * ( 1. - F * AA / ( PROJ + F * BB ) * ALOG ( ( PROJ &
3576 + F * BB + F * AA ) / ( F * AA ) ) )
3577 !
3578 EXTK( IVEG, IWAVE, 1 ) = PROJ / F * SQRT( 1.-SCAT )
3579 EXTK( IVEG, IWAVE, 2 ) = 1. / ZMEW * SQRT( 1.-SCAT )
3580 EXTK( IVEG, 3, 1 ) = AA + BB
3581 EXTK( IVEG, 3, 2 ) = 1./ZMEW
3582 !
3583 UPSCAT = GREEN(IVEG) * TRAN1 + ( 1. - GREEN(IVEG) ) * TRAN2
3584 UPSCAT = 0.5 * ( SCAT + ( SCAT - 2. * UPSCAT ) * &
3585 (( 1. - CHIV ) / 2. ) ** 2 )
3586 !
3587 BETAO = ( 1. + ZMEW * EXTKB ) / ( SCAT * ZMEW * EXTKB ) * ACSS
3588 !
3589 !----------------------------------------------------------------------
3590 !
3591 ! DICKINSON'S VALUES
3592 !
3593 BE = 1. - SCAT + UPSCAT
3594 CE = UPSCAT
3595 BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
3596 IF ( ABS(BOT) .GT. 1.E-10) GO TO 200
3597 SCAT = SCAT* 0.98
3598 BE = 1. - SCAT + UPSCAT
3599 BOT = ( ZMEW * EXTKB ) ** 2 + ( CE**2 - BE**2 )
3600 200 CONTINUE
3601 DE = SCAT * ZMEW * EXTKB * BETAO
3602 FE = SCAT * ZMEW * EXTKB * ( 1. - BETAO )
3603 !----------------------------------------------------------------------
3604 !
3605 CCE = DE * BE - ZMEW * DE * EXTKB + CE * FE
3606 FFE = BE * FE + ZMEW * FE * EXTKB + CE * DE
3607 !
3608 TORE = -CCE / BOT
3609 SIGE = -FFE / BOT
3610 !
3611 PSI = SQRT(BE**2 - CE**2)/ZMEW
3612 !
3613 !----------------------------------------------------------------------
3614 ! REDUCTION IN EXPOSED HEIGHT OF UPPER STOREY AS SNOW ACCUMULATES
3615 !
3616 SDEP = CAPAC(2) * 5.
3617 FAC = ( SDEP - Z1 ) / ( Z2 - Z1 )
3618 FAC = AMAX1( 0., FAC )
3619 FAC = AMIN1( 0.99, FAC )
3620 !
3621 ZAT = ZLT(IVEG) / VCOVER(IVEG)
3622 IF ( IVEG .EQ. 1 ) ZAT = ZAT * (1.-FAC)
3623 !
3624 POWER1 = AMIN1( PSI*ZAT, 50. )
3625 POWER2 = AMIN1( EXTKB*ZAT, 50. )
3626 EPSI = EXP( - POWER1 )
3627 EK = EXP ( - POWER2 )
3628 !
3629 ROSB = SOREF(IWAVE)
3630 ROSD = SOREF(IWAVE)
3631 IF ( IVEG .EQ. 2 ) GO TO 300
3632 ROSB = ALBEDO(2,IWAVE,1)
3633 ROSD = ALBEDO(2,IWAVE,2)
3634 300 CONTINUE
3635 !
3636 GE = ROSB / ROSD
3637 !
3638 !-----------------------------------------------------------------------
3639 ! CALCULATION OF DIFFUSE ALBEDOS
3640 !-----------------------------------------------------------------------
3641 !
3642 F1 = BE - CE / ROSD
3643 ZP = ZMEW * PSI
3644 !
3645 DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
3646 ( BE - ZP ) * ( F1 + ZP ) * EPSI
3647 ALPHA = CE * ( F1 - ZP ) / EPSI / DEN
3648 BETA = -CE * ( F1 + ZP ) * EPSI / DEN
3649 F1 = BE - CE * ROSD
3650 DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
3651 !
3652 GAMMA = ( F1 + ZP ) / EPSI / DEN
3653 DELTA = - ( F1 - ZP ) * EPSI / DEN
3654 !
3655 ALBEDO(IVEG,IWAVE,2) = ALPHA + BETA
3656 !
3657 IF ( IVEG .EQ. 1 ) GO TO 400
3658 SCOV2 = 0.
3659 !crr CORRECTION FOR KEEPING ALBEDO HIGH OVER SNOW
3660 IF (ISICE.EQ.1) SCOV2=1.
3661 !
3662 IF ( TGS .LE. TF ) SCOV2 = AMIN1( 1., CAPAC(2) / 0.004 )
3663 ALBEDO(2,IWAVE,2)= ROSD * ( 1. - VCOVER(2) ) + ALBEDO(2,IWAVE,2) * VCOVER(2)
3664 ALBEDO(2,IWAVE,2) = &
3665 ( 1. - SCOV2 ) * ALBEDO(2,IWAVE,2) + SCOV2 * &
3666 ( 1.2-IWAVE*0.4 ) * FMELT
3667 400 CONTINUE
3668 !
3669 TRANC2(IWAVE) = GAMMA * EPSI + DELTA / EPSI
3670 !
3671 !-----------------------------------------------------------------------
3672 ! CALCULATION OF DIRECT ALBEDOS
3673 !-----------------------------------------------------------------------
3674 !
3675 F1 = BE - CE / ROSD
3676 ZMK = ZMEW * EXTKB
3677 !
3678 DEN = ( BE + ZP ) * ( F1 - ZP ) / EPSI - &
3679 ( BE - ZP ) * ( F1 + ZP ) * EPSI
3680 ALPHA = ( DE - TORE * ( BE + ZMK ) ) * ( F1 - ZP ) / EPSI - &
3681 ( BE - ZP ) * ( DE - CE*GE - TORE * ( F1 + ZMK ) ) * EK
3682 ALPHA = ALPHA / DEN
3683 BETA = ( BE + ZP ) * (DE - CE*GE - TORE * ( F1 + ZMK ))* EK - &
3684 ( DE - TORE * ( BE + ZMK ) ) * ( F1 + ZP ) * EPSI
3685 BETA = BETA / DEN
3686 F1 = BE - CE * ROSD
3687 DEN = ( F1 + ZP ) / EPSI - ( F1 - ZP ) * EPSI
3688 GAMMA = - SIGE * ( F1 + ZP ) / EPSI - &
3689 ( FE + CE * GE * ROSD + SIGE * ( ZMK - F1 ) ) * EK
3690 GAMMA = GAMMA / DEN
3691 DELTA = ( CE * GE * ROSD + FE + SIGE * ( ZMK - F1 ) ) * EK &
3692 + SIGE * ( F1 - ZP ) * EPSI
3693 DELTA = DELTA / DEN
3694 !
3695 ALBEDO(IVEG,IWAVE,1) = TORE + ALPHA + BETA
3696 !
3697 !----------------------------------------------------------------------
3698 !
3699 IF( IVEG .EQ. 1 ) GO TO 500
3700 ALBEDO(2,IWAVE,1) = ROSB * ( 1. - VCOVER(2) ) &
3701 + ALBEDO(2,IWAVE,1) * VCOVER(2)
3702 ALBEDO(2,IWAVE,1) = ( 1. - SCOV2 ) * ALBEDO(2,IWAVE,1) + &
3703 SCOV2 * ( 1.2-IWAVE*0.4 ) * FMELT
3704 !
3705 500 CONTINUE
3706 !
3707 TRANC1(IWAVE) = EK
3708 TRANC3(IWAVE) = SIGE * EK + GAMMA * EPSI + DELTA / EPSI
3709 !
3710 2000 CONTINUE
3711 !
3712 !----------------------------------------------------------------------
3713 ! CALCULATION OF TERMS WHICH MULTIPLY INCOMING SHORT WAVE FLUXES
3714 ! TO GIVE ABSORPTION OF RADIATION BY CANOPY AND GROUND
3715 !----------------------------------------------------------------------
3716 !
3717 RADFAC(2,IWAVE,1) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,1) ) &
3718 + VCOVER(1) * ( TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
3719 + TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
3720 !
3721 RADFAC(2,IWAVE,2) = ( 1.-VCOVER(1) ) * ( 1.-ALBEDO(2,IWAVE,2) ) &
3722 + VCOVER(1) * TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) )
3723 !
3724 RADFAC(1,IWAVE,1) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,1) ) &
3725 - TRANC1(IWAVE) * ( 1.-ALBEDO(2,IWAVE,1) ) &
3726 - TRANC3(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
3727 !
3728 RADFAC(1,IWAVE,2) = VCOVER(1) * ( ( 1.-ALBEDO(1,IWAVE,2) ) &
3729 - TRANC2(IWAVE) * ( 1.-ALBEDO(2,IWAVE,2) ) )
3730 !
3731 ! XQQ(1,IWAVE,1) = RADFAC(1,IWAVE,1)
3732 ! XQQ(1,IWAVE,2) = RADFAC(1,IWAVE,2)
3733 ! XQQ(2,IWAVE,1) = RADFAC(2,IWAVE,1)
3734 ! XQQ(2,IWAVE,2) = RADFAC(2,IWAVE,2)
3735 !
3736 !----------------------------------------------------------------------
3737 ! CALCULATION OF TOTAL SURFACE ALBEDOS ( SALB )
3738 !
3739 DO 3000 IRAD = 1, 2
3740 SALB(IWAVE,IRAD) = ( 1.-VCOVER(1) ) * ALBEDO(2,IWAVE,IRAD) + &
3741 VCOVER(1) * ALBEDO(1,IWAVE,IRAD)
3742 3000 CONTINUE
3743 !
3744 !----------------------------------------------------------------------
3745 ! SAVING OF EXTINCTION COEFFICIENTS ( PAR ) FOR STOMAT CALCULATION
3746 !----------------------------------------------------------------------
3747 IF ( IWAVE .EQ. 2 ) GO TO 600
3748 RADSAV(1) = 1. - VCOVER(1) &
3749 + VCOVER(1) * ( TRANC1(IWAVE) + TRANC3(IWAVE) )
3750 RADSAV(2) = 1. - VCOVER(1) + VCOVER(1) * TRANC2(IWAVE)
3751 600 CONTINUE
3752 !
3753 1000 CONTINUE
3754 !
3755 ! albedo adjustment ==============================================
3756 !
3757 if (xadj.eq.0.) go to 730
3758 xx = radfac(1,1,2) + radsav(2)
3759 xy = radfac(1,1,1) + radsav(1)
3760 ssum = salb(1,1)*radfrac(1,1) + salb(1,2)*radfrac(1,2)+ &
3761 salb(2,1)*radfrac(2,1) + salb(2,2)*radfrac(2,2)
3762 ! for diffuse albedo
3763 do 650 iwave = 1, 2
3764 salb(iwave,2) = salb(iwave,2) + xadj * salb(iwave,2) / ssum
3765 x0 = 1. - salb(iwave,2)
3766 x1 = radfac(1,iwave,2) + radfac(2,iwave,2)
3767 x2 = radfac(1,iwave,2) / x1
3768 x3 = radfac(2,iwave,2) / x1
3769 radfac(1,iwave,2) = x0 * x2
3770 radfac(2,iwave,2) = x0 * x3
3771 if (salb(iwave,2).gt.1..or.radfac(1,iwave,2).gt.1..or. &
3772 radfac(2,iwave,2).gt.1..or.salb(iwave,2).lt.0..or. &
3773 radfac(1,iwave,2).lt.0..or.radfac(2,iwave,2).lt.0.) then
3774 stop 999
3775 end if
3776 650 continue
3777 640 format(1x,'unrealistic value, dif',2i12,4e11.4)
3778 ! for direct albedo
3779 do 750 iwave = 1, 2
3780 salb(iwave,1) = salb(iwave,1) + xadj * salb(iwave,1) / ssum
3781 x0 = 1. - salb(iwave,1)
3782 x1 = radfac(1,iwave,1) + radfac(2,iwave,1)
3783 x2 = radfac(1,iwave,1) / x1
3784 x3 = radfac(2,iwave,1) / x1
3785 radfac(1,iwave,1) = x0 * x2
3786 radfac(2,iwave,1) = x0 * x3
3787 radsav(1) = xy - radfac(1,1,1)
3788 radsav(2) = xx - radfac(1,1,2)
3789 if (salb(iwave,1).gt.1..or.radfac(1,iwave,1).gt.1..or. &
3790 radfac(2,iwave,1).gt.1..or.salb(iwave,1).lt.0..or. &
3791 radfac(1,iwave,1).lt.0..or.radfac(2,iwave,1).lt.0.) then
3792 write(7,740) nymdh,iwave,salb(iwave,1),radfac(1,iwave,1), &
3793 radfac(2,iwave,1)
3794 stop 999
3795 end if
3796 750 continue
3797 740 format(1x,'unrealistic value',2i12,4e11.4)
3798 730 continue
3799 !***************** end adjustment *******************************
3800 sibsu = radn(1,1)*salb(1,1) + radn(1,2)*salb(1,2) &
3801 + radn(2,1)*salb(2,1) + radn(2,2)*salb(2,2)
3802 if ((swdown.gt.0.01).and.(sibsu.gt.0.01)) then
3803 bedo = sibsu / swdown
3804 if (bedo.gt.1.) then
3805 sibsu = 0.
3806 bedo = .1
3807 ! print*,'albebo incorrect',ix,jx,bedo,sibsu,swdown, &
3808 ! radn(1,1),radn(1,2),radn(2,1),radn(2,2)
3809 endif
3810 else
3811 sibsu = 0.0
3812 bedo = .1
3813 endif
3814 !--------------------------------------------------------------------
3815 ! bedo = sibsu/swdown
3816 ! bedo = min(max(bedo,0.001),1.0)
3817 !--------------------------------------------------------------------
3818 !
3819 ! CALCULATION OF LONG-WAVE FLUX TERMS FROM CANOPY AND GROUND
3820 !
3821 !----------------------------------------------------------------------
3822 !
3823 TC4 = TC * TC * TC * TC
3824 TG4 = TGS * TGS * TGS * TGS
3825 !
3826 ZKAT = EXTK(1,3,2) * ZLT(1) / VCOVER(1)
3827 ZKAT = AMIN1( 50. , ZKAT )
3828 ZKAT = AMAX1( 1.E-5, ZKAT )
3829 THERMK = EXP(-ZKAT)
3830 !
3831 FAC1 = VCOVER(1) * ( 1.-THERMK )
3832 FAC2 = 1.
3833 CLOSS = 2. * FAC1 * STEFAN * TC4
3834 CLOSS = CLOSS - FAC2 * FAC1 * STEFAN * TG4
3835 GLOSS = FAC2 * STEFAN * TG4
3836 GLOSS = GLOSS - FAC1 * FAC2 * STEFAN * TC4
3837 !
3838 ZLWUP = FAC1 * STEFAN * TC4 + (1. - FAC1 ) * FAC2 * STEFAN * TG4
3839 TGEFF = SQRT( SQRT ( ( ZLWUP / STEFAN ) ) )
3840 !
3841 RADSAV(3) = EXTK(1,1,1)
3842 RADSAV(4) = EXTK(1,1,2)
3843 RADSAV(5) = EXTK(2,1,1)
3844 RADSAV(6) = EXTK(2,1,2)
3845 RADSAV(7) = THERMK
3846 RADSAV(8) = EXTK(1,3,1)
3847 RADSAV(9) = EXTK(2,3,1)
3848 RADSAV(10)= CLOSS
3849 RADSAV(11)= GLOSS
3850 RADSAV(12)= TGEFF
3851 !
3852 !-----------------------------------------------------------------------
3853 !
3854 ! CALCULATION OF ABSORPTION OF RADIATION BY SURFACE
3855 !
3856 !-----------------------------------------------------------------------
3857 !
3858 P1F = RADSAV(1)
3859 P2F = RADSAV(2)
3860 EXTK(1,1,1) = RADSAV(3)
3861 EXTK(1,1,2) = RADSAV(4)
3862 EXTK(2,1,1) = RADSAV(5)
3863 EXTK(2,1,2) = RADSAV(6)
3864 THERMK = RADSAV(7)
3865 EXTK(1,3,1) = RADSAV(8)
3866 EXTK(2,3,1) = RADSAV(9)
3867 CLOSS = RADSAV(10)
3868 GLOSS = RADSAV(11)
3869 TGEFF = RADSAV(12)
3870 !
3871 !----------------------------------------------------------------------
3872 ! SUMMATION OF SHORT-WAVE RADIATION ABSORBED BY CANOPY AND GROUND
3873 !----------------------------------------------------------------------
3874 !
3875 RADT(1) = 0.
3876 RADT(2) = 0.
3877 !
3878 DO 7000 IVEG = 1, 2
3879 DO 7000 IWAVE = 1, 2
3880 DO 7000 IRAD = 1, 2
3881 !
3882 RADT(IVEG) = RADT(IVEG)+RADFAC(IVEG,IWAVE,IRAD)*RADN(IWAVE,IRAD)
3883 !
3884 7000 CONTINUE
3885 !=========================================================================
3886 fsdown = radn(1,1)+radn(1,2)+radn(2,1)+radn(2,2)
3887 fsup = fsdown-radt(1)-radt(2)
3888 !=========================================================================
3889 !
3890 SWCAN=RADT(1)
3891 SWGND=RADT(2)
3892 !
3893 RADT(1) = RADT(1) + RADN(3,2)*VCOVER(1)*(1.- THERMK) &
3894 - CLOSS
3895 RADT(2) = RADT(2) + RADN(3,2)*( 1.-VCOVER(1)*(1-THERMK) ) &
3896 - GLOSS
3897 !=========================================================================
3898 fldown = radn(3,2)
3899 flup = closs+gloss
3900 !=========================================================================
3901 !
3902 PAR(1) = RADN(1,1) + RADN(1,2) + 0.001
3903 PD(1) = ( RADN(1,1) + 0.001 ) / PAR(1)
3904 P1 = P1F * RADN(1,1) + 0.001
3905 P2 = P2F * RADN(1,2)
3906 PAR(2) = P1 + P2
3907 PD(2) = P1 / PAR(2)
3908 !
3909 !------------------------------------------------------
3910 END SUBROUTINE RADAB_ICE
3911 !------------------------------------------------------
3912 !=======================================================================
3913 !
3914 SUBROUTINE RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZZWIND,UMM1, &
3915 RHOA,TMM,U2,USTAR,DRAG,TA,bps,rib,CU,CT,UV10)
3916 ! 2001,1,11
3917 !=======================================================================
3918 !
3919 ! CUU AND CTT ARE LINEAR (A SIMPLIFIED VERSION, XUE ET AL. 1991)
3920 !
3921 FS(X) = 66.85 * X
3922 FT(X) = 0.904 * X
3923 FV(X) = 0.315 * X
3924 !
3925 ! CU AND CT ARE THE FRICTION AND HEAT TRANSFER COEFFICIENTS.
3926 ! CUN AND CTN ARE THE NEUTRAL FRICTION AND HEAT TRANSFER
3927 ! COEFFICIENTS.
3928 !
3929 G2= 0.75
3930 G3= 0.75
3931 Z22 = Z2
3932 ZL = Z2 + 11.785 * Z0
3933 !crr
3934 ZWIND = ZZWIND
3935 TM = TMM
3936 UMM = UMM1
3937 !cxx IF(ZWIND.LE.Z2) THEN
3938 !cxx ZWIND=Z2+20.0 ! if trees are higher than model level
3939 !cxx ! increase model level by 10m
3940 !cxx TM = TMM - (ZWIND - ZZWIND)*0.0065 ! adjust temp (lin.)
3941 !cxx UMM = UMM1 + USTAR/VKC * ALOG(ZWIND/ZZWIND) ! adjust wind (log.)
3942 !cxx ENDIF
3943 !------------------------------------------------------------------------
3944 if(zwind.le.d.or.zl.le.d) d=min(zwind,zl)-0.1
3945 !crr
3946 Z2 = D + Z0
3947 CUNI = ALOG((ZWIND-D)/Z0)/VKC
3948 IF (ZL.LT.ZWIND) THEN
3949 XCT1 = ALOG((ZWIND-D)/(ZL-D))
3950 XCT2 = ALOG((ZL-D)/(Z2-D))
3951 XCTU2 = ALOG((ZL-D)/(Z22-D))
3952 CTNI = (XCT1 + G3 * XCT2) / VKC
3953 ELSE
3954 XCT2 = ALOG((ZWIND-D)/(Z2-D))
3955 XCTU2 = ALOG((ZWIND-D)/(Z22-D))
3956 CTNI = G3 * XCT2 /VKC
3957 END IF
3958 ! --------------- NEUTRAL VALUES OF USTAR AND VENTMF ------------
3959 !
3960 UM=AMAX1(UMM,2.)
3961 USTARN=UM/CUNI
3962 VENTN =RHOA /CTNI*USTARN
3963 IF (ZL.LT.ZWIND) THEN
3964 U2 = UM - 1. / VKC * USTARN * (XCT1 + G2 * XCTU2)
3965 ELSE
3966 U2 = UM - 1. / VKC * USTARN * G2 * XCTU2
3967 END IF
3968 !crr
3969 if(u2.lt.0.01) u2=0.01
3970 !crr
3971 !
3972 ! STABILITY BRANCH BASED ON BULK RICHARDSON NUMBER.
3973 !
3974 ! THM=TM*bps1
3975 ! THVGM= TRIB*bps0-THM
3976 THM=TM*bps !fds (06/2010)
3977 THVGM=TRIB-THM
3978 IF (TA.EQ.0.) THVGM = 0.
3979 RIB = -THVGM*GRAV*(ZWIND-D) / (THM*(UM-U2)**2)
3980 RIB = MAX(-10.E0,RIB)
3981 RIB = MIN(0.1643E0,RIB)
3982 !
3983 ! NON-NEUTRON CORRECTION (SEE XUE ET AL(1991))
3984 IF(RIB.LT.0.0)THEN
3985 GRIB = +RIB
3986 GRZL = +RIB*(ZL-D)/(ZWIND-D)
3987 GRZ2 = +RIB*(Z2-D)/(ZWIND-D)
3988 FVV = FV(GRIB)
3989 IF (ZL.LT.ZWIND) THEN
3990 FTT = FT(GRIB) + (G3-1.) * FT(GRZL) - G3 * FT(GRZ2)
3991 ELSE
3992 FTT = G3*(FT(GRIB) - FT(GRZ2))
3993 END IF
3994 CUI = CUNI + FVV
3995 CTI = CTNI + FTT
3996 ELSE
3997 RZL = RIB/(ZWIND-D)*(ZL-D)
3998 RZ2 = RIB/(ZWIND-D)*(Z2-D)
3999 FVV = FS(RIB)
4000 IF (ZL.LT.ZWIND) THEN
4001 FTT = FS(RIB) + (G3-1) * FS(RZL) - G3 * FS(RZ2)
4002 ELSE
4003 FTT = G3 * (FS(RIB) - FS(RZ2))
4004 END IF
4005 312 CUI = CUNI + FVV
4006 CTI = CTNI + FTT
4007 ENDIF
4008 310 CONTINUE
4009 !
4010 CU=1./CUI
4011 ! CT=1./CTI !Correction 3/8/16
4012 USTAR =UM*CU
4013 RAF = CTI / USTAR
4014 IF (RAF.LT.0.80) THEN
4015 RAF = 0.80
4016 CTI = RAF*USTAR
4017 ENDIF
4018 CT = 1./CTI !Correction 3/8/16
4019 !
4020 RA = RAF
4021 !
4022 UEST = USTAR
4023 DRAG = RHOA * UEST*UEST
4024 Z2 = Z22
4025 !
4026 !fds Calculate 10m wind intensity (Jan/2014)
4027 CUNI10 = ALOG((z2+10-D)/Z0)/VKC
4028 UV10 = USTAR * (CUNI10+FVV)
4029 !
4030 !------------------------------------------------------
4031 END SUBROUTINE RASIT5
4032 !------------------------------------------------------
4034 !=======================================================================
4035 !
4036 SUBROUTINE SDSOL(DSOL,DMASS,N,SOLAR,SOLSOIL)
4037 !
4038 !=======================================================================
4039 parameter(nd = 4)
4040 !clwp 12/08/2000, to change nd=20 to nd=4 to keep consistent
4041 !cl parameter(nd = 20)
4042 integer n
4043 real dsol(nd),dmass(nd),fext(nd)
4044 !
4045 gsize = 5.d-4
4046 bext = 400.0
4047 cv = 3.795d-3
4048 depth = 30
4049 do i=1,n
4050 fext(i) = 0.0
4051 enddo
4052 !
4053 tmass = 0.0
4054 do 10 i=1,n
4055 j=n+1-i
4056 tmass=tmass+dmass(j)
4057 if(tmass.gt.depth) goto 30
4058 fext(j)=exp(-cv*dmass(j)/sqrt(gsize))
4059 if(j .eq. n) fext(n)=exp(-bext*2d-3)*fext(n)
4060 10 continue
4061 30 tsolt = solar
4062 do 20 i=1,n
4063 j=n+1-i
4064 if(tsolt .le. 0d0)then
4065 dsol(j)=0d0
4066 tsolb=0.0
4067 else
4068 tsolb=tsolt*fext(j)
4069 dsol(j)=tsolt-tsolb
4070 tsolt=tsolb
4071 end if
4072 20 continue
4073 solsoil = tsolb
4074 !
4075 !------------------------------------------------------
4076 END SUBROUTINE SDSOL
4077 !------------------------------------------------------
4079 !=======================================================================
4080 !
4081 SUBROUTINE SET0(TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO, &
4082 SSO,CTO,BTO,DMLTO,WF,DHP)
4083 !
4084 !=======================================================================
4085 !cl
4086 DIMENSION WF(N1),DHP(N1),TSSNO(N1),BWO(N1),BLO(N1),BIO(N1),HO(N1), &
4087 FLO(N1),FIO(N1),WO(N1),DZO(N1),SSO(N1),CTO(N1),BTO(N1),DMLTO(N1)
4088 !clwp do 100 i=n+1,nd
4089 DO 100 I=N+1,N1
4090 TSSNO(I)=0.0
4091 BWO(I)=0.0
4092 BLO(I)=0.0
4093 BIO(I)=0.0
4094 HO(I)=0.0
4095 FLO(I)=0.0
4096 FIO(I)=0.0
4097 WO(I)=0.0
4098 DZO(I)=0.0
4099 SSO(I)=0.0
4100 CTO(I)=0.0
4101 BTO(I)=0.0
4102 DMLTO(I)=0.0
4103 100 CONTINUE
4104 !clwp DO 200 I=1,Nd
4105 DO 200 I=1,N1
4106 WF(I)=0.0
4107 DHP(I)=0.0
4108 200 CONTINUE
4109 !------------------------------------------------------
4110 END SUBROUTINE SET0
4111 !------------------------------------------------------
4113 !=======================================================================
4114 !
4115 SUBROUTINE SNOW_1ST (DTT,TM,SOLAR,PRCPW,PRCPS,BIO,BLO,DICEVOL, &
4116 DLIQVOL,TSSNO,PDZDTC,POROSITY,SO,SSO,WF,DHP,DZO,WO, &
4117 BWO,BTO,CTO,DMASS,DSOL,SNROFF,HROFF,SNOWDEPTH,SOLSOIL, &
4118 FLO,FIO,DMLTO,HO,BIFALL,BLFALL,FLFALL)
4119 !
4120 !=======================================================================
4121 !cl
4122 DIMENSION BIO(N1),BLO(N1),DICEVOL(N1),DLIQVOL(N1),TSSNO(N1), &
4123 PDZDTC(N1),POROSITY(N1),SO(N1),SSO(N1),WF(N1),DHP(N1), &
4124 DZO(N1),WO(N1),BWO(N1),BTO(N1),CTO(N1),DMASS(N1), &
4125 DSOL(N1),FLO(N1),FIO(N1),DMLTO(N1),HO(N1)
4126 ! ------------------------------------------------------------------7272
4127 tkair = TM
4128 prcp = prcpw+prcps
4129 snroff = 0.0
4130 hroff = 0.0
4131 ! dksatsnow=0.01
4132 !....................... rain
4133 if(prcpw.gt.0.0)then
4134 wf(n+1)=amin1(prcpw, dksatsnow*dtt)
4135 dhp(n+1)=(wf(n+1)/dtt)*cl*rhowater*(tkair-273.16)
4136 snroff =snroff+(prcpw-wf(n+1))
4137 hroff=hroff+(prcpw-wf(n+1))*cl*rhowater*(tkair-273.16)
4138 else if(prcps.gt.0.0)then
4139 !...................... snow, add new nodes
4140 wf(n+1)=0.0
4141 dhp(n+1)=0.0
4142 !cl 12/08/2000, the following subroutine just deals with top snow layer.
4143 CALL NEWSNOW(PRCP,BIFALL,BLFALL,FLFALL,TKAIR, &
4144 DZO(N),WO(N),BWO(N),CTO(N),HO(N),DMLTO(N),FIO(N),FLO(N), &
4145 BIO(N),BLO(N),DLIQVOL(N),DICEVOL(N),TSSNO(N),WF(N))
4146 endif
4147 !---------------------------------
4148 ! Compaction rate for snow
4149 !---------------------------------
4150 do 277 i=n,1,-1
4151 dicevol(i) = bio(i)/dice
4152 dliqvol(i) = blo(i)/rhowater
4153 porosity(i)=1.0-dicevol(i)
4154 porosity(i)=amin1(porosity(i),1.0)
4155 porosity(i)=amax1(porosity(i),0.0)
4156 so(i)=ssisnow
4157 if(porosity(i).ne.0.0) so(i)=dliqvol(i)/porosity(i)
4158 sso(i)=(so(i)-ssisnow)/(1.0-ssisnow)
4159 277 continue
4160 overburden=0.0
4161 do 377 i=n,1,-1
4162 overburden=overburden+ wo(i)*rhowater
4163 call COMPACT(BIO(I),TSSNO(I),BLO(I),OVERBURDEN,PDZDTC(I), &
4164 SSO(I),DICE)
4165 377 continue
4166 !
4167 !---------------------------------------------**
4168 ! Calculate some variables after new snowfall
4169 !---------------------------------------------**
4170 do 390 i = 1,n
4171 if((sso(i).lt.1.0.and.porosity(i).gt.0.0))then
4172 dzot=dzo(i)*(1d0+pdzdtc(i)*dtt)
4173 dzo(i)=amax1(dzot,dzmin)
4174 !
4175 if(wo(i).gt.womin)then
4176 bwo(i)=(wo(i)*rhowater)/dzo(i)
4177 if (bwo(i).gt.920.0) then
4178 bwo(i)=920.0
4179 dzo(i)=(wo(i)*rhowater)/bwo(i)
4180 end if
4181 endif
4182 !
4183 blo(i)=bwo(i)*flo(i)
4184 bio(i)=bwo(i)*fio(i)
4185 bto(i)=bwo(i)
4186 end if
4187 !
4188 dicevol(i) = bio(i)/dice
4189 dliqvol(i) = blo(i)/rhowater
4190 dummy = dliqvol(i) + dicevol(i)
4191 if(dummy.gt.1.0)then
4192 dliqvol(i) = 1.0 - dicevol(i)
4193 blo(i) = dliqvol(i)*rhowater
4194 bwo(i) = blo(i) + bio(i)
4195 dzo(i)=(wo(i)*rhowater)/bwo(i)
4196 endif
4197 cto(i)=(bwo(i)/920.0)*1.9e+6
4198 !
4199 porosity(i)=1.0-dicevol(i)
4200 if(porosity(i) .gt. 1.0)porosity(i)=1.0
4201 if(porosity(i) .lt. 0.0)porosity(i)=0.0
4202 !
4203 if(porosity(i).gt.0.0)then
4204 so(i)=dliqvol(i)/porosity(i)
4205 else
4206 so(i)=ssisnow
4207 endif
4208 !
4209 if(so(i).gt.ssisnow)then
4210 sso(i)=(so(i)-ssisnow)/(1.0-ssisnow)
4211 else
4212 sso(i)=0.0
4213 endif
4214 !!!!!! dmass is for using to calculate dsol in sdsol.f
4215 dmass(i)=bto(i)*dzo(i)
4216 390 continue
4217 SNOWDEPTH=dzo(1)+dzo(2)+dzo(3)
4218 !---------------------------------------------
4219 ! Optical parameters and solar extinction
4220 !---------------------------------------------
4221 IF (solar .gt. 0d0 ) THEN
4222 call sdsol(dsol,dmass,n,solar,solsoil)
4223 ELSE
4224 do 112 i=1,n
4225 dsol(i)=0d0
4226 112 continue
4227 solsoil=0.0
4228 END IF
4229 !
4230 !------------------------------------------------------
4231 END SUBROUTINE SNOW_1ST
4232 !------------------------------------------------------
4234 !=======================================================================
4235 !
4236 SUBROUTINE SNRESULT(DTT,I,ICASE,WFSOIL,TSOIL,B1,B2,FFF,DELTH,WWW, &
4237 ZDEPTH,POROS,BI,BIO,DZ,DZO,W,BW,BWO,H,HO,QK,BL,BT,CT, &
4238 FI,FL,WF,TSSN,DLIQVOL,DICEVOL,SNROFF,HROFF,QSOIL)
4239 !
4240 !=======================================================================
4241 !cl
4242 DIMENSION BIO(N1),DZO(N1),W(N1),BWO(N1),HO(N1), &
4243 DZ(N1),BI(N1),BW(N1),BL(N1),BT(N1),CT(N1),FI(N1),FL(N1), &
4244 WF(N1),H(N1),TSSN(N1),DLIQVOL(N1),DICEVOL(N1),QK(N1), &
4245 WWW(3),ZDEPTH(3)
4246 DIMENSION DELTH(20)
4247 DATA BWE/200.0/
4248 hx=0.0
4249 IF (ICASE.EQ.1) THEN
4250 fi(i)=1.0
4251 fl(i)=0.0
4252 dz(i)=dzo(i)
4253 bw(i)=(w(i)*rhowater)/dz(i)
4254 if((w(i)/dz(i)).lt.0.05.or.(w(i)/dz(i)) &
4255 .gt.(dice/1000.0))then
4256 bw(i) = bwo(i)
4257 dz(i) = (w(i)*rhowater)/bw(i)
4258 endif
4259 bi(i)=bw(i)
4260 bl(i)=0.0
4261 bt(i)=bw(i)
4262 wf(i)=0.0
4263 if (i.eq.1) wfsoil=0.0
4264 dliqvol(i)=0.0
4265 dicevol(i)=bi(i)/dice
4266 ct(i)=(bw(i)/920.0)*1.9e+6
4267 if (i.eq.n) then
4268 h(i)=ct(i)*dz(i)*(tssn(i)-273.16)-rhowater*dlm*w(n)*fi(n)
4269 else
4270 tssn(i) = ( ho(i) + ct(i)*dz(i)*273.16 + b1*dtt &
4271 + rhowater*dlm*w(i) ) &
4272 / ( ct(i)*dz(i) - b2*dtt )
4273 h(i) = ho(i) + (b1+b2*tssn(i))*dtt
4274 end if
4275 if(tssn(i).gt.273.16) then
4276 WRITE( message,* ) 'Warning: Snow Temp above freezing',i,tssn(i)
4277 tssn(i)=273.16
4278 CALL wrf_message ( message )
4279 endif
4280 ! ------------------------------------------------------------------7272
4281 ELSE IF (ICASE.EQ.2) THEN
4282 ! when snow temperature equals 273.16
4283 fl(i)=1.0-fi(i)
4284 tssn(i)=273.16
4285 wf(i)=0.0
4286 If(bwo(i).ge.bwe) Then
4287 if(fl(i).gt.flmin)then
4288 wf(i) = w(i)-(fi(i)/(1.0-flmin))*w(i)
4289 w(i) = (fi(i)/(1.0-flmin))*w(i)
4290 dum = wf(i)
4291 fl(i)=flmin
4292 fi(i)=1.0-fl(i)
4293 endif
4294 Else
4295 !.................................................
4296 flm = flmin+(flmax-flmin)*((bwe-bwo(i))/bwe)
4297 if(fl(i).gt.flm)then
4298 wf(i) = w(i)-(fi(i)/(1.0-flm))*w(i)
4299 w(i) = (fi(i)/(1.0-flm))*w(i)
4300 dum = wf(i)
4301 fl(i)=flm
4302 fi(i)=1.0-fl(i)
4303 endif
4304 Endif
4305 !.................................................
4306 If( wf(i).gt.0.0) Then
4307 if(i.ne.1)then
4308 wf(i)=amin1(dum, dksatsnow*dtt)
4309 snroff = snroff + (dum - wf(i))
4310 hroff=hroff+(dum-wf(i))*cl*rhowater*(tssn(i)-273.16)
4311 else
4312 !ctest2
4313 if(www(1).ge.1.0) then
4314 snroff = snroff + wf(i)
4315 wfsoil=0.0
4316 else
4317 slwet=www(1)*poros*zdepth(1)
4318 www(1)=(slwet+wf(i))/(poros*zdepth(1))
4319 if(www(1).gt.1.0) then
4320 snroff = snroff + (www(1)-1.0)*poros*zdepth(1)
4321 www(1)=1.0
4322 endif
4323 wfsoil=0.0
4324 endif
4325 hroff=hroff + wf(i)*cl*rhowater*(tssn(i)-273.16)
4326 endif
4327 Endif
4328 !cccccc next concerning compaction occurring during melt
4329 xnodalmelt=bio(i)*dzo(i)-w(i)*rhowater*fi(i)
4330 If(xnodalmelt.gt.0.0.and.bio(i)*dzo(i).gt.0.0 &
4331 .and.(bio(i).lt.250.0.or.(i.eq.n.and. &
4332 bio(i).lt.400.0))) Then
4333 ddz3=-xnodalmelt/(bio(i)*dzo(i))
4334 dz(i)=dzo(i)*(1.0+ddz3)
4335 Else
4336 dz(i)=dzo(i)
4337 Endif
4338 bw(i)=(w(i)*rhowater)/dz(i)
4339 !.............................................
4340 If((w(i)/dz(i)).lt.0.05.or.(w(i)/dz(i)) &
4341 .gt.(dice/1000.0)) Then
4342 bw(i) = bwo(i)
4343 dz(i) = (w(i)*rhowater)/bw(i)
4344 Endif
4345 bi(i)=bw(i)*fi(i)
4346 bl(i)=bw(i)-bi(i)
4347 bt(i)=bw(i)
4348 ct(i)=(bw(i)/920.0)*1.9e+6
4349 dliqvol(i)=bl(i)/rhowater
4350 dicevol(i)=bi(i)/dice
4351 h(i)=(-1.0)*w(i)*fi(i)*dlm*rhowater
4352 !cc---------------------------------------------**
4353 ELSE IF (ICASE.EQ.3) THEN
4354 ! i=n
4355 ! else if(fff.le.0.0) then
4356 !cccccc next calculate ponding condition.
4357 fl(i) = 1.0
4358 fi(i) = 0.0
4359 ! dz(i) = w(i)
4360 wf(i) = w(i)
4361 dum= wf(i)
4362 dz(i) = 10e-15
4363 w(i) = 10e-15
4364 bw(i) =rhowater
4365 bl(i)=bw(i)
4366 bi(i)=0.0
4367 dliqvol(i) = 1.0
4368 dicevol(i) = 0.0
4369 ct(i)=(bw(i)/920.0)*1.9e+6
4370 tssn(i) = 273.16
4371 h(i) = 0.0
4372 !
4373 If (i.eq.n) Then
4374 if (i.eq.1) then
4375 hx=(-1.0)*w(i)*fff*dlm*rhowater/dtt
4376 snroff=wf(1)+snroff
4377 wfsoil=0.0
4378 else
4379 wf(i)=amin1(dum, dksatsnow*dtt)
4380 snroff = snroff + (dum - wf(i))
4381 hroff=hroff+(dum-wf(i))*cl*rhowater*(tssn(i)-273.16)
4382 delth(n-1) = (-1.0)*w(i)*fff*dlm*rhowater/dtt
4383 end if
4384 Else
4385 if(i.eq.1)then
4386 hx = ho(i)/dtt + b1+b2*tssn(i)
4387 !ctest2
4388 if(www(1).ge.1.0) then
4389 snroff = snroff + wf(i)
4390 wfsoil=0.0
4391 else
4392 slwet=www(1)*poros*zdepth(1)
4393 www(1)=(slwet+wf(i))/(poros*zdepth(1))
4394 if(www(1).gt.1.0) then
4395 snroff = snroff + (www(1)-1.0)*poros*zdepth(1)
4396 www(1)=1.0
4397 endif
4398 wfsoil=0.0
4399 endif
4400 else
4401 wf(i)=amin1(dum, dksatsnow*dtt)
4402 snroff = snroff + (dum - wf(i))
4403 hroff=hroff+(dum-wf(i))*cl*rhowater*(tssn(i)-273.16)
4404 delth(i-1) = ho(i)/dtt + b1+b2*tssn(i)
4405 endif
4406 End if
4407 END IF
4408 !cS Calculate the heat flux into the soil: qsoil on 10/13/98.
4409 !cS qsoil : downward is positive [ W/m**2]
4410 if (i.eq.1) qsoil = qk(1)*(tssn(1) - tsoil) + hx
4411 !cs 10/13/98
4412 !
4413 !------------------------------------------------------
4414 END SUBROUTINE SNRESULT
4415 !------------------------------------------------------
4417 !=======================================================================
4418 !
4419 SUBROUTINE STRES1 (IFIRST,RSTM,ROOTP, &
4420 RSTFAC,RST,TC,ETC,RB,TGS,ETGS,RD,TU,TL,TOPT,EA, &
4421 DEFAC,PH1,PH2,NROOT,ZDEPTH,PHSOIL,ROOTD,VCOVER,DROP)
4422 !
4423 !=======================================================================
4424 !
4425 !======================================================================
4426 !
4427 ! CALCULATION OF ADJUSTMENT TO LIGHT DEPENDENT STOMATAL RESISTANCE
4428 ! BY TEMPERATURE, HUMIDITY AND STRESS FACTORS
4429 ! SIMPLIFIED SEE XUE ET AL(1991)
4430 !
4431 ! RSTFAC(IVEG,1) = FD
4432 ! RSTFAC(IVEG,2) = FP
4433 ! RSTFAC(IVEG,3) = FT
4434 ! RSTFAC(IVEG,4) = FTPD
4435 !
4436 !----------------------------------------------------------------------
4437 DIMENSION TOPT(2), TL(2), TU(2), DEFAC(2), VCOVER(2)
4438 DIMENSION PH1(2), PH2(2), RST(2), RSTFAC(2,4),XDRR(3)
4439 DIMENSION ROOTD(2),ROOTP(3),ZDEPTH(3),PHSOIL(3), RSTM(2), DEP(3)
4440 !----------------------------------------------------------------------
4441 ! HUMIDITY, TEMPERATURE AND TRANSPIRATION FACTORS
4442 !----------------------------------------------------------------------
4443 !
4444 DO 1000 IVEG = 1, 2
4445 !
4446 TV = TC
4447 ETV = ETC
4448 RAIR = RB * 2.
4449 IF ( IVEG .EQ. 1 ) GO TO 100
4450 TV = TGS
4451 ETV = ETGS
4452 RAIR = RD
4453 100 CONTINUE
4454 !
4455 TV = AMIN1 ( ( TU(IVEG) - 0.1 ), TV )
4456 TV = AMAX1 ( ( TL(IVEG) + 0.1 ), TV )
4457 !
4458 IF( IFIRST .EQ. 0 ) GO TO 200
4459 RSTM(IVEG) = RST(IVEG)
4460 D2 = ( TU(IVEG) - TOPT(IVEG) ) / ( TOPT(IVEG) - TL(IVEG) )
4461 D1 = 1. /(( TOPT(IVEG) - TL(IVEG) )* &
4462 EXP( ALOG( TU(IVEG) - TOPT(IVEG))*D2))
4463 RSTFAC(IVEG,3) = D1*( TV-TL(IVEG)) * EXP(ALOG(TU(IVEG)-TV)*D2)
4464 !
4465 IF (RSTFAC(IVEG,3).LT.0.) RSTFAC(IVEG,3) = 0.
4466 IF (RSTFAC(IVEG,3).GT.1.) RSTFAC(IVEG,3) = 1.
4467 !
4468 !----------------------------------------------------------------------
4469 ! SIMPLIFIED CALCULATION OF LEAF WATER POTENTIAL FACTOR , FP
4470 !----------------------------------------------------------------------
4471 !
4472 !---------new add------------
4473 XDRR(1)=-PHSOIL(1)
4474 XDRR(2)=-PHSOIL(2)
4475 XDRR(3)=-PHSOIL(3)
4476 IF(XDRR(1).le.0.001) XDRR(1)=0.001
4477 IF(XDRR(2).le.0.001) XDRR(2)=0.001
4478 IF(XDRR(3).le.0.001) XDRR(3)=0.001
4479 XDRR(1)=ALOG(XDRR(1))
4480 XDRR(2)=ALOG(XDRR(2))
4481 XDRR(3)=ALOG(XDRR(3))
4482 !------------------------------
4484 IF (NROOT.EQ.1) THEN
4485 XROT = ROOTD(1)
4486 DO 7400 I = 1, 3
4487 7400 DEP(I) = 0.
4488 DO 7500 I = 1, 3
4489 DEP(I) = AMIN1(ZDEPTH(I), XROT)
4490 XROT = XROT - ZDEPTH(I)
4491 IF (XROT.LE.0.) GO TO 7410
4492 7500 CONTINUE
4493 7410 CONTINUE
4494 ! XDR = (PHSOIL(1) * DEP(1) + PHSOIL(2) * DEP(2) &
4495 ! +PHSOIL(3) * DEP(3)) /ROOTD(1)
4496 XDR=(XDRR(1)*DEP(1)+XDRR(2)*DEP(2)+XDRR(3)*DEP(3))/ROOTD(1)
4498 ELSE
4499 ! XDR = PHSOIL(1) * ROOTP(1) + PHSOIL(2) * ROOTP(2) &
4500 ! +PHSOIL(3) * ROOTP(3)
4501 XDR=XDRR(1)*ROOTP(1)+XDRR(2)*ROOTP(2)+XDRR(3)*ROOTP(3)
4502 END IF
4503 ! XDR = - XDR
4504 ! IF (XDR .LE. 0.001) XDR = 0.001
4505 ! XDR = ALOG (XDR)
4506 !cl 2001,1,09 changed the following two lines back to the original ones.
4507 !cl EXPONENT = AMAX1(-86.0, (- PH1(IVEG) * (PH2(IVEG) - XDR)) )
4508 !cl RSTFAC(IVEG,2) = 1. - EXP(EXPONENT)
4509 RSTFAC(IVEG,2) = 1. - EXP(- PH1(IVEG) * (PH2(IVEG) - XDR))
4510 IF (RSTFAC(IVEG,2).GT.1.) RSTFAC(IVEG,2) = 1.
4511 IF (RSTFAC(IVEG,2).LT.0.) RSTFAC(IVEG,2) = 0.
4512 !
4513 200 RST(IVEG) = RSTM(IVEG)
4514 !
4515 EPOT = ETV - EA
4516 EPOT = AMAX1(0.0001,(ETV-EA))
4517 !
4518 ! ---** PJS mod 10/9/92 ---**
4519 ! ---** based on Verma FIFE-87 function for C4 grasses ---**
4520 !
4521 RSTFAC(IVEG,1) = 1./ ( 1 + DEFAC(IVEG)*DROP )
4522 !
4523 IF (RSTFAC(IVEG,1).LT.0.) RSTFAC(IVEG,1) = 0.
4524 IF (RSTFAC(IVEG,1).GT.1.) RSTFAC(IVEG,1) = 1.
4525 !----------------------------------------------------------------------
4526 ! VALUE OF FP FOUND
4527 !----------------------------------------------------------------------
4528 !
4529 300 FTPD = RSTFAC(IVEG,1) * RSTFAC(IVEG,2) * RSTFAC(IVEG,3)
4530 RSTFAC(IVEG,4) = AMAX1( FTPD, 0.00001 )
4531 !----------------------------------------------------------------------
4532 !
4533 RST(IVEG) = RST(IVEG) / RSTFAC(IVEG,4) / VCOVER(IVEG)
4534 !
4535 RST(IVEG) = AMIN1( RST(IVEG), 100000. )
4536 1000 CONTINUE
4537 !
4538 !------------------------------------------------------
4539 END SUBROUTINE STRES1
4540 !------------------------------------------------------
4542 !=======================================================================
4543 !
4544 SUBROUTINE TEMRS1 &
4545 (DTT,TC,TGS,TD,TA,TM,QM,EM,PSURF,WWW,CAPAC,SATCAP, &
4546 DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,D,Z0,RDC,RBC,VCOVER,Z2, &
4547 ZLAI,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
4548 ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP, &
4549 THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN, &
4550 BPS,rib,CU,XCT,flup,UV10)
4551 !
4552 !=======================================================================
4553 ! ------------------------------------------------------------------7272
4554 ! A SIMPLIFIED VERSION (XUE ET AL. 1991)
4555 ! CORE ROUTINE: CALCULATION OF CANOPY AND GROUND TEMPERATURE
4556 ! INCREMENTS OVER TIME STEP, FLUXES DERIVED.
4557 !-----------------------------------------------------------------------
4558 ! SUBROUTINES IN THIS BLOCK : TEMRS1,DELRN,DELHF,DELEF,STRES1
4559 !-----------------------------------------------------------------------
4560 REAL ZINC(3), A2(3), Y1(3), ITEX(3),RSTM(2)
4561 !cl add the following arrays after common block "comsib3" was removed
4562 DIMENSION WWW(3), CAPAC(2), SATCAP(2), ZDEPTH(3)
4563 DIMENSION VCOVER(2), ZLAI(2), RADT(2),ALBEDO(2,3,2)
4564 DIMENSION TOPT(2), TL(2), TU(2), DEFAC(2)
4565 DIMENSION PH1(2), PH2(2), RST(2), RSTFAC(2,4)
4566 DIMENSION ROOTD(2), ROOTP(3), PHSOIL(3)
4567 !
4568 !----------------------------------------------------------------------
4569 ! E(X) IS VAPOUR PRESSURE IN MBARS AS A FUNCTION OF TEMPERATURE
4570 ! GE(X) IS D E(X) / D ( TEMP )
4571 !----------------------------------------------------------------------
4572 !
4573 E(X) = EXP( 21.18123 - 5418. / X ) / .622
4574 GE(X) = EXP( 21.18123 - 5418. / X ) * 5418. &
4575 / (X*X) / .622
4576 !
4577 ETC = E(TC)
4578 ETGS = E(TGS)
4579 GETC = GE(TC)
4580 GETGS = GE(TGS)
4581 !crr HLAT = ( 3150.19 - 2.378 * TM ) * 1000.
4582 !crr PSY = CPAIR / HLAT * PSUR / .622
4583 PSY = CPAIR / HLAT * PSURF/100. / .622
4584 RCP = RHOAIR * CPAIR
4585 ! RADD = 44.
4586 WC = AMIN1( 1., CAPAC(1)/SATCAP(1) )
4587 WG = AMIN1( 1., CAPAC(2)/SATCAP(2) )
4588 !----------------------------------------------------------------------
4589 ! RSOIL FUNCTION FROM FIT TO CAMILLO AND GURNEY (1984) DATA.
4590 ! WETNESS OF UPPER 0.5 CM OF SOIL CALCULATED FROM APPROXIMATION
4591 ! TO MILLY FLOW EQUATION WITH REDUCED (1/50 ) CONDUCTIVITY IN
4592 ! TOP LAYER.
4593 !----------------------------------------------------------------------
4594 !
4595 ! WT = WWW(1) + 0.75 * ZDEPTH(1) / ( ZDEPTH(1) + ZDEPTH(2) )
4596 ! & * (WWW(1) - (WWW(2)**2)/WWW(1) ) / 2. * 50.
4597 ! FAC = AMIN1( WT, 0.99 )
4598 ! FAC = AMAX1( FAC, WWW(1) * 0.1 )
4599 !
4600 !------------------------------------------------------------
4601 ! --- soil resistance calculation alteration Y.K. Xue Feb. 1994**
4602 !------------------------------------------------------------
4603 FAC = AMIN1( www(1), 0.99 )
4604 FAC = AMAX1( FAC, 0.02 )
4605 RSOIL = 101840. * (1. - FAC ** 0.0027)
4606 !
4607 PSIT = PHSAT * FAC ** (- BEE )
4608 ARGG = AMAX1(-10.,(PSIT*GRAV/461.5/TGS))
4609 HR = EXP(ARGG)
4610 !cl 2001,1,10 added the following line according to Xue, 2000 August
4611 PILPHR = HR
4612 !----------------------------------------------------------------------
4613 ! ALTERATION OF AERODYNAMIC TRANSFER PROPERTIES IN CASE OF SNOW
4614 ! ACCUMULATION.
4615 !----------------------------------------------------------------------
4616 !
4617 RESD = D
4618 RESZ0 = Z0
4619 RESRDC = RDC
4620 RESRBC = RBC
4621 RESV2 = VCOVER(2)
4622 !
4623 IF ( TGS .GT. TF ) GO TO 100
4624 !
4625 SDEP = CAPAC(2) *SNOWDEN
4626 SDEP = AMIN1( SDEP, (Z2*0.95) )
4627 D = Z2 - ( Z2-D ) / Z2 * ( Z2 - SDEP )
4628 Z0 = Z0 / ( Z2-RESD ) * ( Z2-D )
4629 RDC = RDC * ( Z2-SDEP ) / Z2
4630 RBC = RBC * Z2 / ( Z2-SDEP )
4631 VCOVER(2) = 1.
4632 WG = AMIN1( 1., CAPAC(2) / 0.004 )
4633 RST(2) = RSOIL
4634 100 CONTINUE
4635 !----------------------------------------------------------------------
4636 !
4637 ! CALCULATION OF EA, TA, RA, RB, RD AND SOIL MOISTURE STRESS
4638 ! FOR THE BEGINNING OF THE TIME STEP
4639 !
4640 !----------------------------------------------------------------------
4641 IFIRST = 1
4642 ICOUNT = 0
4643 TGEN = TGS
4644 TCEN = TC
4645 FC = 1.
4646 FG = 1.
4647 !-- 2001,1,11 changed the following line according to Xue,August,2000(TA=TM)
4648 !cl TA = TM
4649 TRIB = TA
4650 EA = EM
4651 HT = 0.
4652 IONCE = 0
4653 1000 CONTINUE
4654 ICOUNT = ICOUNT + 1
4655 CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
4656 RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
4657 !cl ------------IF ( IFIRST .EQ. 1 ) CALL RBRD1 ------------
4658 IF ( IFIRST .EQ. 1 ) THEN
4659 !cl TCTA = TC - TA
4660 RB = 1.0/(SQRT(U2)/RBC+ZLAI(1)*.004)
4661 !cl X1 = TEMDIF
4662 TGTA = TGS- TA
4663 TEMDIF = ( TGTA + SQRT(TGTA*TGTA) ) / 2. + 0.1
4664 FIH = SQRT( 1. + 9. * GRAV *TEMDIF * Z2 / TGS / ( U2*U2) )
4665 RD = RDC / U2 / FIH
4666 ENDIF
4667 !cl ------------ END OF RBRD1 ---------------
4668 D1 = 1./RA + 1./RB + 1./RD
4669 TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
4670 HT = ( TA - TM ) * RCP / RA
4671 RCC = RST(1)*FC + 2. * RB
4672 COC = (1.-WC)/RCC + WC/(2.*RB)
4673 RG = RST(2)*FG
4674 RSURF = RSOIL*FG
4675 COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HR &
4676 + VCOVER(2)/(RSURF+RD+44.)*HR
4677 COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
4678 + VCOVER(2)/(RSURF+RD+44.)
4679 COG1 = COG1 + WG/RD * VCOVER(2)
4680 COG2 = COG2 + WG/RD * VCOVER(2)
4681 D2 = 1./RA + COC + COG2
4682 TOP = COC * ETC + COG1 * ETGS + EM / RA
4683 EA = TOP / D2
4684 DROP = AMAX1( 0., (E(TA)-EA) )
4685 !----------------------------------------------------------------------
4686 !cl CALL STRES1 ( IFIRST , RSTM)
4687 CALL STRES1 (IFIRST, RSTM,ROOTP, &
4688 RSTFAC,RST,TC,ETC,RB,TGS,ETGS,RD,TU,TL,TOPT,EA, &
4689 DEFAC,PH1,PH2,NROOT,ZDEPTH,PHSOIL,ROOTD,VCOVER,DROP)
4690 !----------------------------------------------------------------------
4691 IFIRST = 0
4692 ERIB = EA
4693 TRIB = TA
4694 !!!
4695 IF ( ICOUNT .LE. 4 ) GO TO 1000
4696 !======================================================================
4697 !cl CALL DELRN ( RNCDTC, RNCDTG, RNGDTG, RNGDTC )
4698 ! PARTIAL DERIVATIVES OF RADIATIVE AND SENSIBLE HEAT FLUXES
4699 TC3 = TC * TC * TC
4700 TG3 = TGS * TGS * TGS
4701 FAC1 = ( 1. - ALBEDO(1,3,2) ) * ( 1.-THERMK ) * VCOVER(1)
4702 FAC2 = 1. - ALBEDO(2,3,2)
4703 RNCDTC = - 2. * 4. * FAC1 * STEFAN * TC3
4704 RNCDTG = 4. * FAC1 * FAC2 * STEFAN * TG3
4705 RNGDTG = - 4. * FAC2 * STEFAN * TG3
4706 RNGDTC = 4. * FAC1 * FAC2 * STEFAN * TC3
4707 !----------------------------------------------------------------------
4708 !
4709 ! DEW CALCULATION : DEW CONDITION IS SET AT BEGINNING OF TIME STEP.
4710 ! IF SURFACE CHANGES STATE DURING TIME STEP, LATENT HEAT FLUX IS
4711 ! SET TO ZERO.
4712 !
4713 !----------------------------------------------------------------------
4714 IF ( EA .GT. ETC ) FC = 0.
4715 IF ( EA .GT. ETGS) FG = 0.
4716 !
4717 !----------------------------------------------------------------------
4718 !
4719 ! WET FRACTION EXHAUSTION TEST : IF CAPAC(X) IS EXHAUSTED IN
4720 ! A TIME STEP, INTERCEPTION LOSS IS LIMITED TO CAPAC(X).
4721 !
4722 !----------------------------------------------------------------------
4723 ! START OF NON-NEUTRAL RESISTANCE CALCULATION LOOP
4724 !----------------------------------------------------------------------
4725 I = 0
4726 ! ----- INITIALIZE NEWTON-RAPHSON ITERATIVE ROUTINE FOR RASIT 3,5,8
4727 NOX = 0
4728 NONPOS = 1
4729 IWALK = 0
4730 LX = 2
4731 FINC = 1.
4732 ITEX(LX) = 0.
4733 ZINC(LX) = 0.
4734 A2(LX) = 0.
4735 Y1(LX) = 0.
4736 2000 CONTINUE
4737 CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
4738 RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
4739 !======================================================================
4740 !cl CALL DELHF ( HCDTC, HCDTG, HGDTG, HGDTC )
4741 ! PARTIAL DERIVATIVES OF SENSIBLE HEAT FLUXES
4742 !
4743 RCP = RHOAIR * CPAIR
4744 D1 = 1./RA + 1./RB + 1./RD
4745 TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
4746 !
4747 HC = RCP * ( TC - TA ) / RB * DTT
4748 HG = RCP * ( TGS - TA ) / RD * DTT
4749 !----------------------------------------------------------------------
4750 ! N.B. FLUXES EXPRESSED IN JOULES M-2
4751 !----------------------------------------------------------------------
4752 !
4753 HCDTC = RCP / RB * ( 1./RA + 1./RD ) / D1
4754 HCDTG = - RCP / ( RB * RD ) / D1
4755 ! FOR TM
4756 HCDTM = - RCP / ( RB * RA ) / D1 * BPS
4757 !
4758 HGDTG = RCP / RD * ( 1./RA + 1./RB ) / D1
4759 HGDTC = - RCP / ( RD * RB ) / D1
4760 ! FOR TM
4761 HGDTM = - RCP / ( RD * RA ) / D1 *BPS
4762 !======================================================================
4763 ! CALL DELEF ( ECDTC, ECDTG, EGDTG, EGDTC, DEADTC, DEADTG, EC, EG ,
4764 ! & WC, WG, FC, FG, HR,MDLSNO,ISNOW )
4765 !======================================================================
4766 ! PARTIAL DERIVATIVES OF LATENT HEAT FLUXES
4767 ! MODIFICATION FOR SOIL DRYNESS : HR = REL. HUMIDITY IN TOP LAYER
4768 !----------------------------------------------------------------------
4769 !
4770 HRR = HR
4771 IF ( FG .LT. .5 ) HRR = 1.
4772 !
4773 RCC = RST(1)*FC + 2. * RB
4774 COC = (1.-WC)/RCC + WC/(2.*RB)
4775 RG = RST(2)*FG
4776 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
4777 IF (ISNOW.eq.0) THEN
4778 RSURF=RSOIL
4779 ELSE
4780 RSURF = RSOIL*FG
4781 END IF
4782 COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HRR &
4783 + VCOVER(2)/(RSURF+RD+44.)*HRR
4784 COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
4785 + VCOVER(2)/(RSURF+RD+44.)
4786 COG1 = COG1 + WG/RD * VCOVER(2)
4787 COG2 = COG2 + WG/RD * VCOVER(2)
4788 !
4789 D2 = 1./RA + COC + COG2
4790 TOP = COC * ETC + COG1 * ETGS + EM/RA
4791 EA = TOP / D2
4792 EC = ( ETC - EA ) * COC * RCP/PSY * DTT
4793 EG = ( ETGS*COG1 - EA*COG2 ) * RCP/PSY * DTT
4794 DEADTC = GETC * COC / D2
4795 DEADTG = GETGS * COG1 / D2
4796 !
4797 ECDTC = ( GETC - DEADTC ) * COC * RCP / PSY
4798 ECDTG = - DEADTG * COC * RCP / PSY
4799 !
4800 EGDTG = ( GETGS*COG1 - DEADTG*COG2 ) * RCP / PSY
4801 EGDTC = - DEADTC * COG2 * RCP / PSY
4802 !crr
4803 ! FOR QM
4804 DEADQM = 0.622 * PSURF /( (0.622+QM)**2 * RA * D2 )
4805 ECDQM = -DEADQM * COC * RCP / PSY
4806 EGDQM = -DEADQM * COG2 * RCP / PSY
4807 ! FOR YPDATING TM AND QM
4808 AK = 1/ RCP / BPS
4809 AH = 1/ (HLAT*RHOAIR)
4810 !crr
4811 !----------------------------------------------------------------------
4812 ! CALCULATION OF COEFFICIENTS OF TEMPERATURE TENDENCY EQUATIONS
4813 ! C - CANOPY
4814 ! G - GROUND
4815 !----------------------------------------------------------------------
4816 !
4817 CCODTC = CCX / DTT - RNCDTC + HCDTC + ECDTC
4818 CCODTG = - RNCDTG + HCDTG + ECDTG
4819 CCORHS = RADT(1) - ( HC + EC ) / DTT
4820 !----------------------------------------------------------------------
4821 !
4822 GCODTG = CG / DTT + TIMCON*CG*2. - RNGDTG + HGDTG + EGDTG
4823 GCODTC = - RNGDTC + HGDTC + EGDTC
4824 GCORHS = RADT(2) - TIMCON*CG*2. * ( TGS -TD ) - ( HG + EG ) / DTT
4825 !
4826 DENOM = CCODTC * GCODTG - CCODTG * GCODTC
4827 DTC = ( CCORHS * GCODTG - CCODTG * GCORHS ) / DENOM
4828 DTG = ( CCODTC * GCORHS - CCORHS * GCODTC ) / DENOM
4829 !----------------------------------------------------------------------
4830 ! CHECK IF INTERCEPTION LOSS TERM HAS EXCEEDED CANOPY STORAGE
4831 !----------------------------------------------------------------------
4832 !
4833 ECPOT = ( (ETC - EA) + (GETC - DEADTC)*DTC - DEADTG*DTG )
4834 ECI = ECPOT * WC /(2.*RB) * RCP/PSY * DTT
4835 ECIDIF=AMAX1(0.0,(ECI-CAPAC(1)*1.E3*HLAT))
4836 ECI =AMIN1(ECI,( CAPAC(1)*1.E3*HLAT))
4837 !
4838 EGPOT = ( (ETGS - EA) + (GETGS - DEADTG)*DTG - DEADTC*DTC )
4839 EGI = EGPOT * VCOVER(2) * WG/RD * RCP/PSY * DTT
4840 EGIDIF=AMAX1(0.0,(EGI-CAPAC(2)*1.E3*HLAT))
4841 EGI =AMIN1(EGI,( CAPAC(2)*1.E3*HLAT))
4842 !----------------------------------------------------------------------
4843 TGEN = TGS + DTG
4844 TCEN = TC + DTC
4845 D1 = 1./RA + 1./RB + 1./RD
4846 TAEN = ( TGEN / RD + TCEN / RB + TM / RA *bps) / D1
4847 !
4848 HEND = ( TAEN - TM ) * RCP / RA + (ECIDIF + EGIDIF)/DTT
4849 Y= TRIB - TAEN
4850 I = I + 1
4851 HT = HEND
4852 IF ( I .GT. 20 ) GO TO 200
4853 !cl IF ( I .GT. ITRUNK ) GO TO 200
4854 !
4855 CALL NEWTON(TRIB,Y,FINC,NOX,NONPOS,IWALK,LX,ZINC,A2,Y1,ITEX)
4856 IF(NOX.NE.1)GO TO 2000
4857 200 CONTINUE
4858 ! IQIN = IQIN + I
4859 ! IF (I.GT.10) IQIN1 = IQIN1 + 1
4860 !
4861 !----------------------------------------------------------------------
4862 ! EXIT FROM NON-NEUTRAL CALCULATION
4863 ! EVAPOTRANSPIRATION FLUXES CALCULATED FIRST ( J M-2 )
4864 !----------------------------------------------------------------------
4865 HRR = HR
4866 IF ( FG .LT. .5 ) HRR = 1.
4867 RSURF = RSOIL*FG
4868 !
4869 COCT = (1.-WC)/RCC
4870 COGT = VCOVER(2) * (1.-WG)/( RG + RD )
4871 COGS1 = (1.-VCOVER(2)) / ( RD + RSURF ) * HRR &
4872 + VCOVER(2) / ( RD + RSURF + 44.) * HRR
4873 COGS2 = COGS1 / HRR
4874 !
4875 ECT = ECPOT * COCT * RCP/PSY * DTT
4876 !
4877 EGT = EGPOT * COGT * RCP/PSY * DTT
4878 EGS = (ETGS + GETGS*DTG ) * COGS1 &
4879 - ( EA + DEADTG*DTG + DEADTC*DTC ) * COGS2
4880 EGS = EGS * RCP/PSY * DTT
4881 EGSMAX = WWW(1) / 2. * ZDEPTH(1) * POROS * HLAT * 1000.
4882 EGIADD = AMAX1( 0., EGS - EGSMAX )
4883 EGS = AMIN1 ( EGS, EGSMAX )
4884 EGIDIF = EGIDIF + EGIADD
4885 !
4886 !----------------------------------------------------------------------
4887 ! SENSIBLE HEAT FLUX CALCULATED WITH LATENT HEAT FLUX CORRECTION
4888 !----------------------------------------------------------------------
4889 HC = HC + (HCDTC*DTC + HCDTG*DTG)*DTT + ECIDIF
4890 HG = HG + (HGDTC*DTC + HGDTG*DTG)*DTT + EGIDIF
4891 !----------------------------------------------------------------------
4892 ! TEST OF DEW CONDITION. LATENT HEAT FLUXES SET TO ZERO IF SIGN
4893 ! OF FLUX CHANGES OVER TIME STEP.EXCESS ENERGY DONATED TO SENSIBLE
4894 ! HEAT FLUX.
4895 !----------------------------------------------------------------------
4896 ECF = SIGN( 1., ECPOT )
4897 EGF = SIGN( 1., EGPOT )
4898 DEWC = FC * 2. - 1.
4899 DEWG = FG * 2. - 1.
4900 !
4901 IF(DEWC*ECF.GT.0.0) GO TO 300
4902 HC = HC + ECI + ECT
4903 ECI = 0.
4904 ECT = 0.
4905 300 IF(DEWG*EGF.GT.0.0) GO TO 400
4906 HG = HG + EGS + EGI + EGT
4907 EGS = 0.
4908 EGI = 0.
4909 EGT = 0.
4910 400 CONTINUE
4911 !
4912 EC = ECI + ECT
4913 EG = EGT + EGS + EGI
4914 !
4915 !----------------------------------------------------------------------
4916 ! ADJUSTMENT OF TEMPERATURES AND VAPOR PRESSURE , CALCULATION OF
4917 ! SENSIBLE HEAT FLUXES.
4918 !----------------------------------------------------------------------
4919 !
4920 TC = TCEN
4921 TGS = TGEN
4922 TA = TAEN
4923 EA = EA + DEADTC*DTC + DEADTG*DTG
4924 !
4925 RADT(1) = RADT(1) + RNCDTC*DTC + RNCDTG*DTG
4926 RADT(2) = RADT(2) + RNGDTC*DTC + RNGDTG*DTG
4927 !========================================================================
4928 FLUP = FLUP - (RNCDTC+RNGDTC)*DTC - (RNCDTG+RNGDTG)*DTG
4929 !========================================================================
4930 !
4931 ! ** simulated net all-wave radiation **
4932 ! sibnet(nmm,ndd,nhh) = RADT(1) + RADT(2)
4933 !
4934 CHF = CCX / DTT * DTC
4935 SHF = CG / DTT * DTG + TIMCON*CG*2. * ( TGS - TD )
4936 !
4937 ZLWUP = ZLWUP - RNCDTC * DTC / 2. &
4938 - RNGDTG * DTG * (1.-VCOVER(1)*(1.-THERMK) )
4939 !
4940 IF ( TGS .GT. TF ) GO TO 500
4941 EGS = EG - EGI
4942 EGT = 0.
4943 500 CONTINUE
4944 VCOVER(2) = RESV2
4945 D = RESD
4946 Z0 = RESZ0
4947 RDC = RESRDC
4948 RBC = RESRBC
4949 !------------------------------------------------------
4950 END SUBROUTINE TEMRS1
4951 !------------------------------------------------------
4953 !=======================================================================
4954 !
4955 SUBROUTINE TEMRS2 &
4956 (DTT,TC,TGS,TD,TA,TM,QM,EM,PSURF,WWW,CAPAC,SATCAP, &
4957 DTC,DTG,RA,RST,ZDEPTH,BEE,PHSAT,POROS,D,Z0,RDC,RBC,VCOVER, &
4958 Z2,ZLAI,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP, &
4959 PH1,PH2,ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF, &
4960 ALBEDO,ZLWUP,THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, &
4961 ISNOW,CHISL,TSOIL,SOLSOIL,CSOIL,WFSOIL,POROSITY, &
4962 DZ,DZO,W,WO,WF,TSSN,TSSNO,BW,BWO,CT,CTO,FI,FIO,FL,FLO, &
4963 BL,BLO,BI,BIO,BT,BTO,DMLT,DMLTO,H,HO,S,SO,SS,SSO,DSOL,DHP, &
4964 DICEVOL,DLIQVOL,THK,QK,SWE,SNOWDEN,SNOWDEPTH,TKAIR,SNROFF, &
4965 DZSOIL,BPS,rib,CU,XCT,flup,UV10)
4966 !
4967 !=======================================================================
4968 ! ------------------------------------------------------------------7272
4969 ! SUBROUTINES IN THIS BLOCK : RASIT5(RBRD1), STRES1,DELRN,TPROPTY,
4970 ! ------------------------- DELHF,DELEF,NEWTON,SNRESULT
4971 !CS------------------ sun Adds Local variables 10/13/98 ----------------
4972 !clwp 12/13/2000, change the dimensions of delth to a certain number > N
4973 REAL WORK(N1),WORK1(N1),DELTH(20)
4974 data DELTH/20*0.0/
4975 REAL ZINC(3), A2(3), Y1(3), ITEX(3),RSTM(2)
4976 DIMENSION SSO(N1),POROSITY(N1),H(N1),HO(N1),DZ(N1),DZO(N1),CT(N1), &
4977 BI(N1),BIO(N1),BW(N1),BWO(N1),BL(N1),BLO(N1),CTO(N1), &
4978 TSSN(N1),TSSNO(N1),DLIQVOL(N1),DICEVOL(N1),DSOL(N1), &
4979 W(N1),WO(N1),WF(N1),FI(N1),FIO(N1),FL(N1),FLO(N1), &
4980 DMLT(N1),DMLTO(N1),BT(N1),BTO(N1),S(N1),SO(N1),SS(N1), &
4981 PDZDTC(N1),DMASS(N1),THK(N1),DHP(N1),QK(N1)
4982 DIMENSION WWW(3),CAPAC(2),SATCAP(2),ZDEPTH(3),VCOVER(2),ZLAI(2), &
4983 RADT(2),ALBEDO(2,3,2),TOPT(2),TL(2),TU(2),DEFAC(2), &
4984 PH1(2),PH2(2),RST(2),RSTFAC(2,4), &
4985 ROOTD(2),ROOTP(3),PHSOIL(3)
4986 ! ------------------------------------------------------------------7272
4987 ! E(X) IS VAPOUR PRESSURE IN MBARS AS A FUNCTION OF TEMPERATURE
4988 ! GE(X) IS D E(X) / D ( TEMP )
4989 ! ------------------------------------------------------------------7272
4990 !
4991 E(X) = EXP( 21.18123 - 5418. / X ) / .622
4992 GE(X) = EXP( 21.18123 - 5418. / X ) * 5418. &
4993 / (X*X) / .622
4994 !
4995 ETC = E(TC)
4996 ETGS = E(TGS)
4997 GETC = GE(TC)
4998 GETGS = GE(TGS)
4999 !crr HLAT = ( 3150.19 - 2.378 * TM ) * 1000.
5000 PSY = CPAIR / HLAT * PSURF/ 100. / .622
5001 RCP = RHOAIR * CPAIR
5002 ! RADD = 44.
5003 WC = AMIN1( 1., CAPAC(1)/SATCAP(1) )
5004 !CS SUN CHANGE foolowing statement to one new 10/13/98
5005 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5006 IF (ISNOW.eq.0) THEN
5007 WG=1.0
5008 ELSE
5009 WG = AMIN1( 1., CAPAC(2)/SATCAP(2) )
5010 END IF
5011 !CS on 10/13/98
5012 !----------------------------------------------------------------------
5013 ! RSOIL FUNCTION FROM FIT TO CAMILLO AND GURNEY (1984) DATA.
5014 ! WETNESS OF UPPER 0.5 CM OF SOIL CALCULATED FROM APPROXIMATION
5015 ! TO MILLY FLOW EQUATION WITH REDUCED (1/50 ) CONDUCTIVITY IN
5016 ! TOP LAYER.
5017 !----------------------------------------------------------------------
5018 !
5019 ! WT = WWW(1) + 0.75 * ZDEPTH(1) / ( ZDEPTH(1) + ZDEPTH(2) )
5020 ! & * (WWW(1) - (WWW(2)**2)/WWW(1) ) / 2. * 50.
5021 ! FAC = AMIN1( WT, 0.99 )
5022 ! FAC = AMAX1( FAC, WWW(1) * 0.1 )
5023 !
5024 !------------------------------------------------------------
5025 ! --- soil resistance calculation alteration Y.K. Xue Feb. 1994**
5026 !------------------------------------------------------------
5027 FAC = AMIN1( www(1), 0.99 )
5028 FAC = AMAX1( FAC, 0.02 )
5029 !CS Sun fixed following RSOIL equation as equal to 10/13/98
5030 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5031 IF (ISNOW.eq.0) THEN
5032 RSOIL=10000000000.
5033 ELSE
5034 RSOIL = 101840. * (1. - FAC ** 0.0027)
5035 END IF
5036 !CS 10/13/98
5037 !------------------------------------------------------------
5038 !
5039 PSIT = PHSAT * FAC ** (- BEE )
5040 ARGG = AMAX1(-10.,(PSIT*GRAV/461.5/TGS))
5041 HR = EXP(ARGG)
5042 !CL 2001,1,10 added the following line according to Xue, August 2000
5043 PILPHR = HR
5044 !----------------------------------------------------------------------
5045 ! ALTERATION OF AERODYNAMIC TRANSFER PROPERTIES IN CASE OF SNOW
5046 ! ACCUMULATION.
5047 !----------------------------------------------------------------------
5048 RESD = D
5049 RESZ0 = Z0
5050 RESRDC = RDC
5051 RESRBC = RBC
5052 RESV2 = VCOVER(2)
5053 !
5054 IF ( TGS .GT. TF ) GO TO 100
5055 !CS Sun Change following statement into another one: SDEP=snowdepth 10/13/98
5056 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5057 IF (ISNOW.eq.0) THEN
5058 SDEP = SNOWDEPTH
5059 ELSE
5060 SDEP = CAPAC(2) * SNOWDEN
5061 END IF
5062 !CS 10/13/98
5063 SDEP = AMIN1( SDEP, (Z2*0.95) )
5064 D = Z2 - ( Z2-D ) / Z2 * ( Z2 - SDEP )
5065 Z0 = Z0 / ( Z2-RESD ) * ( Z2-D )
5066 RDC = RDC * ( Z2-SDEP ) / Z2
5067 RBC = RBC * Z2 / ( Z2-SDEP )
5068 VCOVER(2) = 1.
5069 !CS Sun added the following IF,change the WG to WG=1.0 10/13/98
5070 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5071 IF (ISNOW.eq.0) THEN
5072 WG=1.0
5073 ELSE
5074 WG = AMIN1( 1., CAPAC(2) / 0.004 )
5075 END IF
5076 RST(2) = RSOIL
5077 100 CONTINUE
5078 !----------------------------------------------------------------------
5079 !
5080 ! CALCULATION OF EA, TA, RA, RB, RD AND SOIL MOISTURE STRESS
5081 ! FOR THE BEGINNING OF THE TIME STEP
5082 !
5083 !----------------------------------------------------------------------
5084 IFIRST = 1
5085 ICOUNT = 0
5086 TGEN = TGS
5087 TCEN = TC
5088 FC = 1.
5089 FG = 1.
5090 TRIB = TA
5091 EA = EM
5092 !cl TA = TM
5093 HT = 0.
5094 IONCE = 0
5095 1000 CONTINUE
5096 ICOUNT = ICOUNT + 1
5097 CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
5098 RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
5099 !cl ------------IF ( IFIRST .EQ. 1 ) CALL RBRD1 ------------
5100 IF ( IFIRST .EQ. 1 ) THEN
5101 !cl TCTA = TC - TA
5102 RB = 1.0/(SQRT(U2)/RBC+ZLAI(1)*.004)
5103 !cl X1 = TEMDIF
5104 TGTA = TGS- TA
5105 TEMDIF = ( TGTA + SQRT(TGTA*TGTA) ) / 2. + 0.1
5106 FIH = SQRT( 1. + 9. * GRAV *TEMDIF * Z2 / TGS / ( U2*U2) )
5107 RD = RDC / U2 / FIH
5108 ENDIF
5109 !cl ------------ END OF RBRD1 ---------------
5110 D1 = 1./RA + 1./RB + 1./RD
5111 TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
5112 HT = ( TA - TM ) * RCP / RA
5113 RCC = RST(1)*FC + 2. * RB
5114 COC = (1.-WC)/RCC + WC/(2.*RB)
5115 RG = RST(2)*FG
5116 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5117 IF (ISNOW.eq.0) THEN
5118 RSURF = RSOIL
5119 ELSE
5120 RSURF = RSOIL*FG
5121 END IF
5122 COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HR &
5123 + VCOVER(2)/(RSURF+RD+44.)*HR
5124 COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
5125 + VCOVER(2)/(RSURF+RD+44.)
5126 COG1 = COG1 + WG/RD * VCOVER(2)
5127 COG2 = COG2 + WG/RD * VCOVER(2)
5128 D2 = 1./RA + COC + COG2
5129 TOP = COC * ETC + COG1 * ETGS + EM / RA
5130 EA = TOP / D2
5131 DROP = AMAX1( 0., (E(TA)-EA) )
5132 !
5133 !----------------------------------------------------------------------
5134 CALL STRES1 (IFIRST, RSTM,ROOTP, &
5135 RSTFAC,RST,TC,ETC,RB,TGS,ETGS,RD,TU,TL,TOPT,EA, &
5136 DEFAC,PH1,PH2,NROOT,ZDEPTH,PHSOIL,ROOTD,VCOVER,DROP)
5137 !----------------------------------------------------------------------
5138 !
5139 IFIRST = 0
5140 ERIB = EA
5141 TRIB = TA
5142 !!!
5143 IF ( ICOUNT .LE. 4 ) GO TO 1000
5144 !======================================================================
5145 !cl CALL DELRN ( RNCDTC, RNCDTG, RNGDTG, RNGDTC )
5146 ! PARTIAL DERIVATIVES OF RADIATIVE AND SENSIBLE HEAT FLUXES
5147 TC3 = TC * TC * TC
5148 TG3 = TGS * TGS * TGS
5149 FAC1 = ( 1. - ALBEDO(1,3,2) ) * ( 1.-THERMK ) * VCOVER(1)
5150 FAC2 = 1. - ALBEDO(2,3,2)
5151 RNCDTC = - 2. * 4. * FAC1 * STEFAN * TC3
5152 RNCDTG = 4. * FAC1 * FAC2 * STEFAN * TG3
5153 RNGDTG = - 4. * FAC2 * STEFAN * TG3
5154 RNGDTC = 4. * FAC1 * FAC2 * STEFAN * TC3
5155 !----------------------------------------------------------------------
5156 !
5157 ! DEW CALCULATION : DEW CONDITION IS SET AT BEGINNING OF TIME STEP.
5158 ! IF SURFACE CHANGES STATE DURING TIME STEP, LATENT HEAT FLUX IS
5159 ! SET TO ZERO.
5160 !
5161 !----------------------------------------------------------------------
5162 !
5163 IF ( EA .GT. ETC ) FC = 0.
5164 IF ( EA .GT. ETGS) FG = 0.
5165 !
5166 !----------------------------------------------------------------------
5167 !
5168 ! WET FRACTION EXHAUSTION TEST : IF CAPAC(X) IS EXHAUSTED IN
5169 ! A TIME STEP, INTERCEPTION LOSS IS LIMITED TO CAPAC(X).
5170 !
5171 !----------------------------------------------------------------------
5172 ! START OF NON-NEUTRAL RESISTANCE CALCULATION LOOP
5173 !----------------------------------------------------------------------
5174 !
5175 II = 0
5176 !
5177 ! ----- INITIALIZE NEWTON-RAPHSON ITERATIVE ROUTINE FOR RASIT 3,5,8
5178 NOX = 0
5179 NONPOS = 1
5180 IWALK = 0
5181 LX = 2
5182 FINC = 1.
5183 ITEX(LX) = 0.
5184 ZINC(LX) = 0.
5185 A2(LX) = 0.
5186 Y1(LX) = 0.
5187 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5188 IF (ISNOW.eq.0) THEN
5189 !---------------------------------------------------------
5190 ! Next loop, we calculate the thermal conductivities
5191 ! and specific heat
5192 !---------------------------------------------------------
5193 CALL TPROPTY(CHISL,BWO,DZO,TKAIR,DZSOIL, THK,QK)
5194 !------------------------------------------------------------
5195 ! Next we calculate the balances of energy and water
5196 !------------------------------------------------------------
5197 tssn(n+1) = tkair
5198 !------------------------------------------------------------
5199 icount = 0
5200 do i=1,n
5201 work(i) = tssno(i)
5202 work1(i) = dliqvol(i)
5203 end do
5204 hx = 0.0
5205 NK=n
5206 ELSE
5207 NK=1
5208 END IF
5209 RADDWN=solsoil
5210 RADDWN=RADDWN+dsol(1)+dsol(2)
5211 RNG = RADT(2) - RADDWN
5212 RADT(2)=RNG
5213 do 57 ik = NK , 1 , -1
5214 !cccc Next calculate snow layers temperatures and densities
5215 IF (ISNOW.ne.0) go to 2000
5216 If((sso(ik).lt.1d0.and.porosity(ik).gt.0d0))then
5217 udum0 = dzo(ik)*(porosity(ik) -work1(ik))
5218 if(udum0.lt.0.0) then
5219 print*,' udum0 is WRONG in thermal.f'
5220 STOP
5221 endif
5222 if(wf(ik+1).gt.udum0)then
5223 uuu=udum0
5224 snroff = snroff + (wf(ik+1)-udum0)
5225 hroff=hroff+(wf(ik+1)-udum0)*cl*rhowater*(tssn(ik+1)-273.16)
5226 else
5227 uuu=wf(ik+1)
5228 endif
5229 dhp(ik+1)=(uuu*cl*rhowater*(tssn(ik+1)-273.16))/dtt
5230 w(ik)=wo(ik)+ uuu
5231 bwo(ik)=rhowater*w(ik)/dzo(ik)
5232 cto(ik)=(bwo(ik)/920.0)*1.9e+6
5233 dmlto(ik)=w(ik)*dlm*rhowater
5234 if (ho(ik).lt.-dmlto(ik)) then
5235 fio(ik)=1.0
5236 flo(ik)=0.0
5237 tssno(ik)=( ho(ik)+dmlto(ik))/(cto(ik)*dzo(ik))+273.16
5238 ! ------------------------------------------------------------------7272
5239 else
5240 tssno(ik)=273.16
5241 fio(ik)=-ho(ik)/dmlto(ik)
5242 flo(ik)=1.0-fio(ik)
5243 end if
5244 blo(ik)=bwo(ik)*flo(ik)
5245 bio(ik)=bwo(ik)*fio(ik)
5246 dliqvol(ik)=blo(ik)/rhowater
5247 dicevol(ik)=bio(ik)/dice
5248 Else
5249 w(ik)=wo(ik)
5250 snroff = snroff +wf(ik+1)
5251 hroff=hroff+wf(ik+1)*cl*rhowater*(tssn(ik+1)-273.16)
5252 dhp(ik+1) = 0.0
5253 End if
5254 !cs Sun add. It is important because tssno(n) is changed here on 1/25/99 .
5255 TGS=tssno(NK)
5256 !cs 0n 1/25/99
5257 !------------------------------------------------------------*
5258 If (ik.lt.Nk) Then
5259 ! Next: ik < n
5260 if(ik.ne.1) then
5261 b1 = dsol(ik) + delth(ik) &
5262 + qk(ik+1)*(tssn(ik+1)-tssno(ik)) + qk(ik)*work(ik-1)
5263 else
5264 b1 = dsol(ik) + delth(ik) &
5265 + qk(ik+1)*(tssn(ik+1)-tssno(ik)) + qk(ik)*tsoil
5266 endif
5267 !
5268 b2 = - qk(ik)
5269 ! Important: delth(ik) must be initialized after using.
5270 delth(ik) = 0.0
5271 End if
5272 dmlt(ik)=w(ik)*dlm*rhowater
5273 If (ik.lt.NK.and.ik.ge.1) Then
5274 fff = -( ho(ik) + (b1+b2*273.16)*dtt ) &
5275 / ( rhowater*dlm*w(ik) )
5276 ! when snow temperature equals 273.16
5277 !!
5278 if(fff.gt.0.0.and.fff.le.1.0) then
5279 ICASE=2
5280 fi(ik)=fff
5281 else if (fff.gt.1.0) then
5282 ICASE=1
5283 else if (fff.le.0.0) then
5284 ICASE=3
5285 end if
5286 End if
5287 If (ik.lt.NK) go to 3000
5288 !
5289 !CS Sun add above paragraph on 10/13/98
5290 2000 CONTINUE
5291 !
5292 CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM, &
5293 RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
5294 !----------------------------------------------------------------------
5295 !cl CALL DELHF ( HCDTC, HCDTG, HGDTG, HGDTC )
5296 ! PARTIAL DERIVATIVES OF SENSIBLE HEAT FLUXES
5297 !
5298 RCP = RHOAIR * CPAIR
5299 D1 = 1./RA + 1./RB + 1./RD
5300 TA = ( TGS/RD + TC/RB + TM/RA *bps) / D1
5301 !
5302 HC = RCP * ( TC - TA ) / RB * DTT
5303 HG = RCP * ( TGS - TA ) / RD * DTT
5304 !----------------------------------------------------------------------
5305 ! N.B. FLUXES EXPRESSED IN JOULES M-2
5306 !----------------------------------------------------------------------
5307 !
5308 HCDTC = RCP / RB * ( 1./RA + 1./RD ) / D1
5309 HCDTG = - RCP / ( RB * RD ) / D1
5310 ! FOR TM
5311 HCDTM = - RCP / ( RB * RA ) / D1 * BPS
5312 !
5313 HGDTG = RCP / RD * ( 1./RA + 1./RB ) / D1
5314 HGDTC = - RCP / ( RD * RB ) / D1
5315 ! FOR TM
5316 HGDTM = - RCP / ( RD * RA ) / D1 *BPS
5317 !======================================================================
5318 ! CALL DELEF ( ECDTC, ECDTG, EGDTG, EGDTC, DEADTC, DEADTG, EC, EG ,
5319 ! & WC, WG, FC, FG, HR,MDLSNO,ISNOW )
5320 !
5321 ! PARTIAL DERIVATIVES OF LATENT HEAT FLUXES
5322 ! MODIFICATION FOR SOIL DRYNESS : HR = REL. HUMIDITY IN TOP LAYER
5323 !----------------------------------------------------------------------
5324 !
5325 HRR = HR
5326 IF ( FG .LT. .5 ) HRR = 1.
5327 !
5328 RCC = RST(1)*FC + 2. * RB
5329 COC = (1.-WC)/RCC + WC/(2.*RB)
5330 RG = RST(2)*FG
5331 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5332 IF (ISNOW.eq.0) THEN
5333 RSURF=RSOIL
5334 ELSE
5335 RSURF = RSOIL*FG
5336 END IF
5337 COG1 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD)*HRR &
5338 + VCOVER(2)/(RSURF+RD+44.)*HRR
5339 COG2 = VCOVER(2)*(1.-WG)/(RG+RD)+(1.-VCOVER(2))/(RSURF+RD) &
5340 + VCOVER(2)/(RSURF+RD+44.)
5341 COG1 = COG1 + WG/RD * VCOVER(2)
5342 COG2 = COG2 + WG/RD * VCOVER(2)
5343 !
5344 D2 = 1./RA + COC + COG2
5345 TOP = COC * ETC + COG1 * ETGS + EM/RA
5346 EA = TOP / D2
5347 EC = ( ETC - EA ) * COC * RCP/PSY * DTT
5348 EG = ( ETGS*COG1 - EA*COG2 ) * RCP/PSY * DTT
5349 DEADTC = GETC * COC / D2
5350 DEADTG = GETGS * COG1 / D2
5351 !
5352 ECDTC = ( GETC - DEADTC ) * COC * RCP / PSY
5353 ECDTG = - DEADTG * COC * RCP / PSY
5354 !
5355 EGDTG = ( GETGS*COG1 - DEADTG*COG2 ) * RCP / PSY
5356 EGDTC = - DEADTC * COG2 * RCP / PSY
5357 !crr
5358 ! FOR QM
5359 DEADQM = 0.622 * PSURF /( (0.622+QM)**2 * RA * D2 )
5360 ECDQM = -DEADQM * COC * RCP / PSY
5361 EGDQM = -DEADQM * COG2 * RCP / PSY
5362 ! FOR YPDATING TM AND QM
5363 AK = 1/ RCP / BPS
5364 AH = 1/ (HLAT*RHOAIR)
5365 !crr
5366 !----------------------------------------------------------------------
5367 !
5368 ! CALCULATION OF COEFFICIENTS OF TEMPERATURE TENDENCY EQUATIONS
5369 ! C - CANOPY, G - GROUND
5370 !
5371 !----------------------------------------------------------------------
5372 !
5373 CCODTC = CCX / DTT - RNCDTC + HCDTC + ECDTC
5374 CCODTG = - RNCDTG + HCDTG + ECDTG
5375 CCORHS = RADT(1) - ( HC + EC ) / DTT
5376 !
5377 !----------------------------------------------------------------------
5378 !CS Sun Change following original GCODCG into new one 10/13/98
5379 IF (ISNOW.eq.0) THEN
5380 GCODTG= cto(n)*dzo(n)/DTT - RNGDTG + HGDTG + EGDTG + qk(n)
5381 ELSE
5382 GCODTG = CG / DTT + TIMCON*CG*2. - RNGDTG + HGDTG + EGDTG
5383 END IF
5384 GCODTC = - RNGDTC + HGDTC + EGDTC
5385 !CS From NOW ON WE REALLY GET INTO SNOW PART !!!!. ON 10/13/98
5386 !cl IF (MDLSNO.ne.0.or.ISNOW.ne.0) THEN
5387 IF (ISNOW.ne.0) THEN
5388 GCORHS = RADT(2)-TIMCON*CG*2.*( TGS -TD )-( HG + EG )/ DTT
5389 ELSE
5390 fi(n)=1.0
5391 GCORHS1 = ho(n)/DTT+RNG - ( HG + EG ) / DTT +dhp(n+1) &
5392 - qk(n)*(TGS -tssno(n-1))-cto(n)*dzo(n)*(tssno(n)-273.16)/DTT
5393 GCORHS = GCORHS1+ rhowater*dlm*w(n)*fi(n)/DTT
5394 END IF
5395 !
5396 DENOM = CCODTC * GCODTG - CCODTG * GCODTC
5397 !
5398 DTC = ( CCORHS * GCODTG - CCODTG * GCORHS ) / DENOM
5399 DTG = ( CCODTC * GCORHS - CCORHS * GCODTC ) / DENOM
5400 !CS Sun add following part here for inserting snow routing on 10/13/98
5401 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5402 IF (ISNOW.eq.0) THEN
5403 If ((TGS+DTG).le.273.16) Then
5404 TGSNEW=(TGS+DTG)
5405 ICASE=1
5406 !cs Sun debug on 1998/12/14 end
5407 ! ------------------------------------------------------------------7272
5408 h(NK)=( TGSNEW-273.16)*cto(n)*dzo(n)-fi(NK)*w(NK)*dlm*rhowater
5409 Dh_DTT_DTG=(h(NK)-ho(NK))/DTT
5410 tonm1=tssno(NK-1)
5411 qkn=qk(n)
5412 Else
5413 DTG=273.16-TGS
5414 DTC= (CCORHS - CCODTG*DTG)/CCODTC
5415 fi(NK)=(GCODTC*DTC+GCODTG*DTG-GCORHS1)/(rhowater*dlm*w(n))*DTT
5416 if (fi(NK).ge.0.0.and.fi(NK).le.1.0) then
5417 h(NK)=-fi(n)*w(n)*dlm*rhowater
5418 Dh_DTT_DTG=(h(NK)-ho(NK))/DTT
5419 ICASE=2
5420 tonm1=tssno(NK-1)
5421 qkn=qk(n)
5422 else if (fi(NK).lt.0.)then
5423 h(NK)= -fi(NK)*w(NK)*dlm*rhowater
5424 Dh_DTT_DTG=(h(NK)-ho(NK))/DTT
5425 ICASE=3
5426 tonm1=tssno(NK-1)
5427 qkn=qk(n)
5428 fff=fi(NK)
5429 fi(NK)=0.0
5430 end if
5431 End if
5432 END IF
5433 !----------------------------------------------------------------------
5434 ! CHECK IF INTERCEPTION LOSS TERM HAS EXCEEDED CANOPY STORAGE
5435 !----------------------------------------------------------------------
5436 !
5437 ECPOT = ( (ETC - EA) + (GETC - DEADTC)*DTC - DEADTG*DTG )
5438 ECI = ECPOT * WC /(2.*RB) * RCP/PSY * DTT
5439 ECIDIF=AMAX1(0.0,(ECI-CAPAC(1)*1.E3*HLAT))
5440 ECI =AMIN1(ECI,( CAPAC(1)*1.E3*HLAT))
5441 !
5442 EGPOT = ( (ETGS - EA) + (GETGS - DEADTG)*DTG - DEADTC*DTC )
5443 EGI = EGPOT * VCOVER(2) * WG/RD * RCP/PSY * DTT
5444 EGIDIF=AMAX1(0.0,(EGI-CAPAC(2)*1.E3*HLAT))
5445 EGI =AMIN1(EGI,( CAPAC(2)*1.E3*HLAT))
5446 !
5447 !----------------------------------------------------------------------
5448 TGEN = TGS + DTG
5449 TCEN = TC + DTC
5450 D1 = 1./RA + 1./RB + 1./RD
5451 TAEN = ( TGEN / RD + TCEN / RB + TM / RA *bps) / D1
5452 !
5453 HEND = ( TAEN - TM ) * RCP / RA + (ECIDIF + EGIDIF)/DTT
5454 Y= TRIB - TAEN
5455 II = II + 1
5456 HT = HEND
5457 IF ( II .GT. 20 ) GO TO 200
5458 !CL IF ( II .GT. ITRUNK ) GO TO 200
5459 !
5460 !CL CALL NEWTON(TRIB,Y,FINC,NOX,NONPOS,IWALK,LX)
5461 CALL NEWTON(TRIB,Y,FINC,NOX,NONPOS,IWALK,LX,ZINC,A2,Y1,ITEX)
5462 !
5463 IF(NOX.NE.1)GO TO 2000
5464 200 CONTINUE
5465 !CS Sun add following part here for inserting snow routing on 10/13/98
5466 !cl 3000 IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5467 3000 IF (ISNOW.eq.0) THEN
5468 IF (ICASE.eq.1.and.ik.eq.NK) THEN
5469 tssn(NK)=TGS+DTG
5470 END IF
5471 If (ik.eq.NK) then
5472 SNOFAC = HLAT / (HLAT + SNOMEL /1000.)
5473 egidw = EGI*SNOFAC /HLAT/1000.
5474 ! egidw= EGI/HLAT/1000.
5475 w(n)=w(n)-egidw
5476 swe=swe-egidw
5477 dzold=dzo(n)
5478 dzo(n)=dzo(n)-egidw*rhowater/bwo(n)
5479 !cs sun: following way to correct h(n) may lead to unballance of energy.
5480 ho(n)=ho(n)*dzo(n)/dzold
5481 capac(2)=swe
5482 End if
5483 CALL SNRESULT(DTT,IK,ICASE,WFSOIL,TSOIL,B1,B2,FFF,DELTH,WWW, &
5484 ZDEPTH,POROS,BI,BIO,DZ,DZO,W,BW,BWO,H,HO,QK,BL,BT,CT, &
5485 FI,FL,WF,TSSN,DLIQVOL,DICEVOL,SNROFF,HROFF,QSOIL)
5486 END IF
5487 57 CONTINUE
5488 ! ------------------------------------------------------------------7272
5489 !clwp 11/17/2000, Li add following sentence to recalculate the snowdepth
5490 SNOWDEPTH=DZO(1)+DZO(2)+DZO(3)
5491 !clwp 11/17/2000, Li add above sentence to recalculate the snowdepth
5492 !CS sun add following parts on 12/5/98 start
5493 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5494 IF (ISNOW.eq.0) THEN
5495 SWE=W(1)+W(2)+W(3)
5496 CAPAC(2)=SWE
5497 IF((DZ(1)+DZ(2)+DZ(3)).NE.0.0) THEN
5498 SNOWDEN=(BW(1)*DZ(1)+BW(2)*DZ(2)+BW(3)*DZ(3)) &
5499 /(DZ(1)+DZ(2)+DZ(3))
5500 SNOWDEN=1000./SNOWDEN
5501 ENDIF
5502 ENDIF
5503 !CS sun add above parts on 12/5/98 end
5504 !----------------------------------------------------------------------
5505 ! EXIT FROM NON-NEUTRAL CALCULATION
5506 !
5507 ! EVAPOTRANSPIRATION FLUXES CALCULATED FIRST ( J M-2 )
5508 !----------------------------------------------------------------------
5509 HRR = HR
5510 IF ( FG .LT. .5 ) HRR = 1.
5511 !cs SUn change RSURF = RSOIL*FG into followings: 02/03/99 start
5512 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5513 IF (ISNOW.eq.0) THEN
5514 RSURF = RSOIL
5515 ELSE
5516 RSURF = RSOIL*FG
5517 END IF
5518 !cs sun 03/02/99 end
5519 !
5520 COCT = (1.-WC)/RCC
5521 COGT = VCOVER(2) * (1.-WG)/( RG + RD )
5522 COGS1 = (1.-VCOVER(2)) / ( RD + RSURF ) * HRR &
5523 + VCOVER(2) / ( RD + RSURF + 44.) * HRR
5524 COGS2 = COGS1 / HRR
5525 !
5526 ECT = ECPOT * COCT * RCP/PSY * DTT
5527 !
5528 EGT = EGPOT * COGT * RCP/PSY * DTT
5529 EGS = (ETGS + GETGS*DTG ) * COGS1 &
5530 - ( EA + DEADTG*DTG + DEADTC*DTC ) * COGS2
5531 EGS = EGS * RCP/PSY * DTT
5532 !CS Sun add following IF statement on 10/13/98
5533 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) EGS=0.0
5534 IF (ISNOW.eq.0) EGS=0.0
5535 EGSMAX = WWW(1) / 2. * ZDEPTH(1) * POROS * HLAT * 1000.
5536 EGIADD = AMAX1( 0., EGS - EGSMAX )
5537 EGS = AMIN1 ( EGS, EGSMAX )
5538 EGIDIF = EGIDIF + EGIADD
5539 !
5540 !----------------------------------------------------------------------
5541 ! SENSIBLE HEAT FLUX CALCULATED WITH LATENT HEAT FLUX CORRECTION
5542 !----------------------------------------------------------------------
5543 HC = HC + (HCDTC*DTC + HCDTG*DTG)*DTT + ECIDIF
5544 HG = HG + (HGDTC*DTC + HGDTG*DTG)*DTT + EGIDIF
5545 !----------------------------------------------------------------------
5546 !
5547 ! TEST OF DEW CONDITION. LATENT HEAT FLUXES SET TO ZERO IF SIGN
5548 ! OF FLUX CHANGES OVER TIME STEP.EXCESS ENERGY DONATED TO SENSIBLE
5549 ! HEAT FLUX.
5550 !----------------------------------------------------------------------
5551 !
5552 !cs Sun add following one statement IF (ISNOW.eq.0.and.MDLSNO.eq.0) go to
5553 !cs 401 CONTINUE to skip folloing statements from
5554 !CS ECF = SIGN( 1., ECPOT ) to 400 CONTINUE
5555 !cl IF (ISNOW.eq.0.and.MDLSNO.eq.0) go to 401
5556 IF (ISNOW.eq.0) go to 401
5557 ECF = SIGN( 1., ECPOT )
5558 EGF = SIGN( 1., EGPOT )
5559 DEWC = FC * 2. - 1.
5560 DEWG = FG * 2. - 1.
5561 !
5562 IF(DEWC*ECF.GT.0.0) GO TO 300
5563 HC = HC + ECI + ECT
5564 ECI = 0.
5565 ECT = 0.
5566 300 IF(DEWG*EGF.GT.0.0) GO TO 400
5567 HG = HG + EGS + EGI + EGT
5568 EGS = 0.
5569 EGI = 0.
5570 EGT = 0.
5571 400 CONTINUE
5572 401 CONTINUE
5573 !
5574 EC = ECI + ECT
5575 EG = EGT + EGS + EGI
5576 !
5577 !----------------------------------------------------------------------
5578 ! ADJUSTMENT OF TEMPERATURES AND VAPOR PRESSURE , CALCULATION OF
5579 ! SENSIBLE HEAT FLUXES.
5580 !----------------------------------------------------------------------
5581 !
5582 !cs sun add following new statement 02/04/99
5583 TGSOLD=TGS
5584 !cs sun end
5585 TC = TCEN
5586 TGS = TGEN
5587 !CS Sun add following statement: 10/13/98
5588 IF (ISNOW.eq.0) tssn(n)=TGS
5589 !CS 10/13/98
5590 TA = TAEN
5591 EA = EA + DEADTC*DTC + DEADTG*DTG
5592 !
5593 RADT(1) = RADT(1) + RNCDTC*DTC + RNCDTG*DTG
5594 RADT(2) = RADT(2) + RNGDTC*DTC + RNGDTG*DTG
5595 !========================================================================
5596 FLUP = FLUP - (RNCDTC+RNGDTC)*DTC - (RNCDTG+RNGDTG)*DTG
5597 !========================================================================
5598 !
5599 ! ** simulated net all-wave radiation **
5600 ! sibnet(nmm,ndd,nhh) = RADT(1) + RADT(2)
5601 !
5602 CHF = CCX / DTT * DTC
5603 !cs sun change the original statement: on 12/14/98
5604 !cs SHF = CG / DTT * DTG + TIMCON*CG*2. * ( TGS - TD)
5605 !cs into following part where CG / DTT * DTG is replaced by Dh_DTT_DTG
5606 IF (ISNOW.eq.0) THEN
5607 SHF= Dh_DTT_DTG - dhp(n+1)+ qkn*(TGSOLD-tonm1) &
5608 +qkn*DTG
5609 ELSE
5610 SHF = CG / DTT * DTG + TIMCON*CG*2. * ( TGS - TD )
5611 END IF
5612 !
5613 ZLWUP = ZLWUP - RNCDTC * DTC / 2. &
5614 - RNGDTG * DTG * (1.-VCOVER(1)*(1.-THERMK) )
5615 !
5616 IF ( TGS .GT. TF ) GO TO 500
5617 EGS = EG - EGI
5618 EGT = 0.
5619 500 CONTINUE
5620 !
5621 VCOVER(2) = RESV2
5622 D = RESD
5623 Z0 = RESZ0
5624 RDC = RESRDC
5625 RBC = RESRBC
5626 !CS Sun add next paragrapg to get soil surface temperature TGS 10/13/98
5627 !cl IF (MDLSNO.eq.0.and.ISNOW.eq.0) THEN
5628 IF (ISNOW.eq.0) THEN
5629 TGS=TSOIL
5630 ATMP= (QSOIL+SOLSOIL)/CSOIL
5631 BTMP=2.*3.1416/86400.
5632 CTMP=CSOIL*BTMP/CSOIL/(365.*3.1416)**0.5
5633 TGS=(TSOIL+ATMP*DTT+BTMP*DTT*TD/(1.+CTMP*DTT))/ &
5634 (1.+BTMP*DTT*(1.-CTMP*DTT/(1.+CTMP*DTT)))
5635 TD=(CTMP*DTT*TGS+TD)/(1.+CTMP*DTT)
5636 END IF
5637 !------------------------------------------------------
5638 END SUBROUTINE TEMRS2
5639 !------------------------------------------------------
5641 !=======================================================================
5642 !
5643 SUBROUTINE TPROPTY(THKSOIL,BWO,DZO,TKAIR,DZSOIL, THK,QK)
5644 !
5645 !=======================================================================
5646 DIMENSION BWO(N1),DZO(N1),THK(N1),QK(N1)
5647 !!!!! this is thermal conductivity for snow from R.Jordan(1991)(2.4)
5648 do 37 i=1,n
5649 thkice=2.290d0
5650 thkair=2.30d-2
5651 thk(i) = thkair+(7.75d-5 *bwo(i)+ 1.105d-6* &
5652 bwo(i)*bwo(i))*(thkice -thkair)+0.1
5653 37 continue
5654 !!!!! calculate the ratio of thermal conductivity
5655 !!!!! at the ineterface between two layers(2.7)
5656 do 47 i=2,n
5657 qk(i)=2.0*thk(i)*thk(i-1)/(thk(i)*dzo(i-1)+thk(i-1)*dzo(i))
5658 47 continue
5659 ! YX2002 (test2) but do nothing at this stage
5660 qk(1)= 2.0*thk(1)*thksoil/(thk(1)*dzsoil+thksoil*dzo(1))
5661 !
5662 !------------------------------------------------------
5663 END SUBROUTINE TPROPTY
5664 !------------------------------------------------------
5666 !=======================================================================
5667 !
5668 SUBROUTINE UPDAT1(DTT,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, &
5669 EGS,EG,HC,HG,HFLUX,ETMASS,ROFF, &
5670 NROOT,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
5671 PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF,ISNOW,WFSOIL,SWE,SNROFF,smelt)
5672 !
5673 !=======================================================================
5674 !CS ------------------------------------------------------------------**
5675 !
5676 ! UPDATING OF SOIL MOISTURE STORES AND INTERCEPTION CAPACITY
5677 !-----------------------------------------------------------------------
5678 DIMENSION EF(3)
5679 !cl 2001,1,09 the following array were added after common blocks removed
5680 DIMENSION WWW(3), CAPAC(2),SNOWW(2),ROOTD(2), ZDEPTH(3), ROOTP(3)
5681 DIMENSION TEMW(3),TEMWP(3),TEMWPP(3),AAA(2),BBB(2),CCC(2),QQQ(2)
5682 !
5683 !----------------------------------------------------------------------
5684 ! EVAPORATION LOSSES ARE EXPRESSED IN J M-2 : WHEN DIVIDED BY
5685 ! ( HLAT*1000.) LOSS IS IN M M-2
5686 ! MASS TERMS ARE IN KG M-2 DT-1
5687 !----------------------------------------------------------------------
5688 !
5689 SNOFAC = HLAT / ( HLAT + SNOMEL /1000. )
5690 FACKS = 1.
5691 IF ( (TC-DTC) .LE. TF ) FACKS = SNOFAC
5692 IF ( (ECT+ECI) .GT. 0.) GO TO 100
5693 ECI = ECT + ECI
5694 ECT = 0.
5695 FACKS = 1. / FACKS
5696 100 CAPAC(1)=CAPAC(1) - ECI*FACKS/HLAT/1000.
5697 !
5698 ECMASS = ( ECT + ECI * FACKS ) / HLAT
5699 !
5700 !cs Sun add following statement IF (ISNOW.EQ.0) go to 201 on 12/5/98
5701 IF (ISNOW.eq.0) FACKS = SNOFAC
5702 IF (ISNOW.EQ.0) go to 201
5703 FACKS = 1.
5704 IF ( (TGS-DTG) .LE. TF ) FACKS = SNOFAC
5705 IF ( (EGT+EGI) .GT. 0. ) GO TO 200
5706 EGI = EGT + EGI
5707 EGT = 0.
5708 FACKS = 1. / FACKS
5709 200 CAPAC(2)=CAPAC(2) - EGI*FACKS/HLAT/1000.
5710 !
5711 201 EGMASS = ( EGT + EGS + EGI * FACKS ) / HLAT
5712 !
5713 ETMASS = ECMASS + EGMASS
5714 !
5715 HFLUX = ( HC + HG ) / DTT
5716 !----------------------------------------------------------------------
5717 ! DUMPING OF SMALL CAPAC VALUES ONTO SOIL SURFACE STORE
5718 !----------------------------------------------------------------------
5719 !
5720 DO 1000 IVEG = 1, 2
5721 IF ( CAPAC(IVEG) .GT. 0.000001 ) GO TO 1000
5722 !cl Xue added the following line in August,2000
5723 !cl FILTR = FILTR + CAPAC(IVEG)
5724 WWW(1) = WWW(1) + CAPAC(IVEG) / ( POROS*ZDEPTH(1) )
5725 CAPAC(IVEG) = 0.
5726 1000 CONTINUE
5727 !----------------------------------------------------------------------
5728 ! SNOWMELT / REFREEZE CALCULATION
5729 !----------------------------------------------------------------------
5730 !CS Sun Change following CALL SNOWM to SNOWM (ISNOW,wfsoil,swe)
5731 !CS 10/13/98
5732 !cl CALL SNOWM (MDLSNO,ISNOW,WFSOIL,SWE)
5733 !CS 10/13/98
5734 !=======================================================================
5735 !
5736 ! CALCULATION OF SNOWMELT AND MODIFICATION OF TEMPERATURES
5737 ! N.B. THIS VERSION DEALS WITH REFREEZING OF WATER
5738 !
5739 !-----------------------------------------------------------------------
5740 !
5741 DO 6000 IVEG = 1, 2
5742 !
5743 !CS Sun Add following part for snow melting and water flux to soil(wfsoil)
5744 !CS is greater zero 10/13/98
5745 IF (ISNOW.EQ.0.and.IVEG.EQ.2) THEN
5746 ZMELT= WFSOIL
5747 WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
5748 CAPAC(2)= SWE
5749 GO TO 6000
5750 END IF
5751 !CS 10/13/98
5752 CCT = CCX
5753 TS = TC
5754 DTS = DTC
5755 FLUX = CHF
5756 IF ( IVEG .EQ. 1 ) GO TO 110
5757 CCT = CG
5758 TS = TGS
5759 DTS = DTG
5760 FLUX = CCT * DTG / DTT
5761 110 CONTINUE
5762 !
5763 TTA = TS - DTS
5764 TTB = TS
5765 SNOWW(IVEG) = 0.
5766 IF ( TTA .LE. TF ) SNOWW(IVEG) = CAPAC(IVEG)
5767 CAPAC(IVEG) = CAPAC(IVEG) - SNOWW(IVEG)
5768 IF ( TTA .GT. TF .AND. TTB .GT. TF ) GO TO 120
5769 IF ( TTA .LE. TF .AND. TTB .LE. TF ) GO TO 120
5770 !
5771 DTF = TF - TTA
5772 DTIME1 = CCT * DTF / FLUX
5773 HF = FLUX*(DTT-DTIME1)
5774 FCAP = - CAPAC(IVEG) * SNOMEL
5775 SPWET = AMIN1( 5. , SNOWW(IVEG) )
5776 IF ( DTS .GT. 0. ) FCAP = SPWET * SNOMEL
5777 DTIME2 = FCAP / FLUX
5778 DTF2 = FLUX * (DTT-DTIME1-DTIME2)/CCT
5779 TN = TF + DTF2
5780 TS = TF - 0.1
5781 IF (ABS(HF) .GE.ABS(FCAP) ) TS = TN
5782 CHANGE = HF
5783 IF (ABS(CHANGE) .GE.ABS(FCAP) ) CHANGE = FCAP
5784 !
5785 CHANGE = CHANGE / SNOMEL
5786 !crr
5787 IF (CHANGE.GT.0.0) SMELT=CHANGE+SMELT
5788 !crr
5789 SNOWW(IVEG) = SNOWW(IVEG) - CHANGE
5790 CAPAC(IVEG) = CAPAC(IVEG) + CHANGE
5791 !
5792 IF ( IVEG .EQ. 1 ) TC = TS
5793 IF ( IVEG .EQ. 2 ) TGS = TS
5794 IF ( SNOWW(IVEG) .LT. 0.00001 ) GO TO 120
5795 !cl ZMELT = 0.
5796 ! modified to force water into soil. Xue Feb. 1994
5797 ZMELT = CAPAC(IVEG)
5798 ! IF ( TD .GT. TF ) ZMELT = CAPAC(IVEG)
5799 !crr FILTR = FILTR+ ZMELT
5800 WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
5801 ! IF ( TD .LE. TF ) ROFF = ROFF + CAPAC(IVEG)
5802 CAPAC(IVEG) = 0.
5803 120 CONTINUE
5804 !
5805 CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
5806 6000 CONTINUE
5807 ! ------------------------------------------------------------
5808 !CS Sun changes following statatement which is alwayes functioned
5809 !CS in Xue's code 10/13/98
5810 IF (ISNOW.NE.0) THEN
5811 FLUXEF = SHF - CCT*DTG/DTT
5812 TD = TD + FLUXEF / ( CG * 2. * SQRT ( PIE*365. ) ) * DTT
5813 END IF
5814 !CS ------------------------------------------------------------
5815 !
5816 ! --- LOAD PILPS DATA
5817 !
5818 ! if (change .gt. 0) snm(istat)=snm(istat)+(change*1000.)
5819 change=0.0
5820 !----------------------------------------------------------------------
5821 ! BARE SOIL EVAPORATION LOSS
5822 !----------------------------------------------------------------------
5823 !cl 2001,1,11 added the following line according to Xue, August 2000
5824 !cl FILTR = FILTR - EGS / HLAT / 1000.
5825 WWW(1) = WWW(1) - EGS / HLAT / 1000. / ( POROS * ZDEPTH(1) )
5826 !
5827 !----------------------------------------------------------------------
5828 ! EXTRACTION OF TRANSPIRATION LOSS FROM ROOT ZONE
5829 !----------------------------------------------------------------------
5830 !
5831 DO 2000 IVEG = 1, 2
5832 !
5833 IF ( IVEG .EQ. 1 ) ABSOIL = ECT / HLAT / 1000.
5834 IF ( IVEG .EQ. 2 ) ABSOIL = EGT / HLAT / 1000.
5835 !cl 2001,1,09 added the following IF according to Xue, Aug 2000
5836 IF (NROOT.EQ.1) THEN
5837 EF(2) = 0.
5838 EF(3) = 0.
5839 TOTDEP = ZDEPTH(1)
5840 !
5841 DO 3000 IL = 2, 3
5842 TOTDEP = TOTDEP + ZDEPTH(IL)
5843 !
5844 ! DIV = AMAX1 ( 1., ( PHSOIL(IL) - PHL(IVEG) ) )
5845 !
5846 IF ( ROOTD(IVEG) .LT. TOTDEP ) GO TO 400
5847 !
5848 EF(IL) = ZDEPTH(IL) / ROOTD(IVEG)
5849 GO TO 500
5850 !
5851 400 CONTINUE
5852 EF(IL) = ROOTD(IVEG) - TOTDEP + ZDEPTH(IL)
5853 EF(IL) = EF(IL) / ROOTD(IVEG)
5854 GO TO 600
5855 500 CONTINUE
5856 3000 CONTINUE
5857 !
5858 600 EFT = EF(2) + EF(3)
5859 EFT = MAX(EFT,0.1E-5)
5860 EF(2) = EF(2) / EFT
5861 EF(3) = EF(3) / EFT
5862 DO 4000 IL = 2, 3
5863 WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
5864 4000 CONTINUE
5865 ELSE
5866 EF(1) = ROOTP(1)
5867 EF(2) = ROOTP(2)
5868 EF(3) = ROOTP(3)
5869 DO 4004 IL = 1, 3
5870 WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
5871 4004 CONTINUE
5872 END IF
5873 2000 CONTINUE
5874 !
5875 !----------------------------------------------------------------------
5876 !
5877 ! CALCULATION OF INTERFLOW, INFILTRATION EXCESS AND LOSS TO
5878 ! GROUNDWATER . ALL LOSSES ARE ASSIGNED TO VARIABLE 'ROFF' .
5879 !
5880 !----------------------------------------------------------------------
5881 !
5882 DO 5000 IL = 1, 2
5883 IF ( WWW(IL) .GT. 0. ) GO TO 5000
5884 WWW(IL+1) = WWW(IL+1) + WWW(IL) * ZDEPTH(IL)/ZDEPTH(IL+1)
5885 WWW(IL) = 0.
5886 5000 CONTINUE
5887 ! IF ( TD .LT. TF ) GO TO 800
5888 !=======================================================================
5889 !cl CALL RUN2
5890 !cl 2001,1,09 substitute subroutine RUN2 by its full code
5891 ! calculation of interflow, infiltration excess and loss to
5892 ! groundwater . all losses are assigned to variable 'roff' .
5893 !=======================================================================
5894 do 8000 i = 1, 3
5895 TEMW(I) = AMAX1( 0.03, WWW(I) )
5896 TEMWP(I) = TEMW(I) ** ( -BEE )
5897 TEMWPP(I) = AMIN1( 1., TEMW(I)) ** ( 2.*BEE+ 3. )
5898 8000 CONTINUE
5899 !-----------------------------------------------------------------------
5900 !
5901 ! calculation of gravitationally driven drainage from w(3) : taken
5902 ! as an integral of time varying conductivity.addition of liston
5903 ! baseflow term to original q3g to insure flow in
5904 ! dry season. modified liston baseflow constant scaled
5905 ! by available water.
5906 !
5907 ! q3g (q3) : equation (62) , SE-86
5908 !
5909 !-----------------------------------------------------------------------
5910 POWS = 2.*BEE+2.
5911 Q3G = TEMW(3)**(-POWS) + SATCO/ZDEPTH(3)/POROS*SLOPE*POWS*DTT
5912 Q3G = Q3G ** ( 1. / POWS )
5913 Q3G = - ( 1. / Q3G - WWW(3) ) * POROS * ZDEPTH(3) / DTT
5914 Q3G = AMAX1( 0., Q3G )
5915 Q3G = AMIN1( Q3G, WWW(3)*POROS*ZDEPTH(3)/DTT )
5916 !
5917 Q3G = Q3G + 0.002*POROS*ZDEPTH(3)*0.5 / 86400. * WWW(3)
5918 !
5919 !----------------------------------------------------------------------
5920 !
5921 ! calculation of inter-layer exchanges of water due to gravitation
5922 ! and hydraulic gradient. the values of w(x) + dw(x) are used to
5923 ! calculate the potential gradients between layers.
5924 ! modified calculation of mean conductivities follows ME-82 ),
5925 ! reduces recharge flux to top layer.
5926 !
5927 ! dpdw : estimated derivative of soil moisture potential
5928 ! with respect to soil wetness. assumption of
5929 ! gravitational drainage used to estimate likely
5930 ! minimum wetness over the time step.
5931 !
5932 ! qqq (q ) : equation (61) , SE-86
5933 ! i,i+1
5934 ! -
5935 ! avk (k ) : equation (4.14) , ME-82
5936 ! i,i+1
5937 !
5938 !----------------------------------------------------------------------
5939 !
5940 WMAX = AMAX1( WWW(1), WWW(2), WWW(3), 0.05 )
5941 WMAX = AMIN1( WMAX, 1. )
5942 PMAX = WMAX**(-BEE)
5943 WMIN = (PMAX-2./( PHSAT*(ZDEPTH(1)+2.*ZDEPTH(2)+ZDEPTH(3)))) &
5944 **(-1./BEE)
5945 WMIN = AMIN1( WWW(1), WWW(2), WWW(3), WMIN )
5946 WMIN = AMAX1( WMIN, 0.02 )
5947 PMIN = WMIN**(-BEE)
5948 DPDW = PHSAT*( PMAX-PMIN )/( WMAX-WMIN )
5949 !
5950 do 8200 i = 1, 2
5951 !
5952 RSAME = 0.
5953 AVK = TEMWP(I)*TEMWPP(I) - TEMWP(I+1)*TEMWPP(I+1)
5954 DIV = TEMWP(I+1) - TEMWP(I)
5955 IF ( ABS(DIV) .LT. 1.E-6 ) RSAME = 1.
5956 AVK = SATCO*AVK / ( ( 1. + 3./BEE ) * DIV + RSAME )
5957 AVKMIN = SATCO * AMIN1( TEMWPP(I), TEMWPP(I+1) )
5958 AVKMAX = SATCO * AMAX1( TEMWPP(I), TEMWPP(I+1) )*1.01
5959 AVK = AMAX1( AVK, AVKMIN )
5960 AVK = AMIN1( AVK, AVKMAX )
5961 !-----------------------------------------------------------------------
5962 ! conductivities and base flow reduced when temperature drops below
5963 ! freezing.
5964 !-----------------------------------------------------------------------
5965 !
5966 TSNOW = AMIN1 ( TF-0.01, TGS )
5967 AREAS = AMIN1 (0.999,13.2*SNOWW(2))
5968 TGG = TSNOW*AREAS + TGS*(1.-AREAS)
5969 TS = TGG*(2-I) + TD*(I-1)
5970 PROPS = ( TS-(TF-10.) ) / 10.
5971 ! props = 1.+5*(ts-tf)
5972 PROPS = AMAX1( 0.05, AMIN1( 1.0, PROPS ) )
5973 AVK = AVK * PROPS
5974 Q3G = Q3G * PROPS
5975 !
5976 !-----------------------------------------------------------------------
5977 ! backward implicit calculation of flows between soil layers.
5978 !-----------------------------------------------------------------------
5979 !
5980 DPDWDZ = DPDW * 2./( ZDEPTH(I) + ZDEPTH(I+1) )
5981 AAA(I) = 1. + AVK*DPDWDZ*( 1./ZDEPTH(I)+1./ZDEPTH(I+1) ) &
5982 *DTT/POROS
5983 BBB(I) =-AVK * DPDWDZ * 1./ZDEPTH(2)*DTT/POROS
5984 CCC(I) = AVK * ( DPDWDZ * ( WWW(I)-WWW(I+1) ) + 1. + &
5985 (I-1)*DPDWDZ*Q3G*1./ZDEPTH(3)*DTT/POROS )
5986 8200 CONTINUE
5987 !
5988 DENOM = ( AAA(1)*AAA(2) - BBB(1)*BBB(2) )
5989 RDENOM = 0.
5990 IF ( ABS(DENOM) .LT. 1.E-6 ) RDENOM = 1.
5991 RDENOM = ( 1.-RDENOM)/( DENOM + RDENOM )
5992 QQQ(1) = ( AAA(2)*CCC(1) - BBB(1)*CCC(2) ) * RDENOM
5993 QQQ(2) = ( AAA(1)*CCC(2) - BBB(2)*CCC(1) ) * RDENOM
5994 !
5995 !-----------------------------------------------------------------------
5996 ! update wetness of each soil moisture layer due to layer interflow
5997 ! and base flow.
5998 !-----------------------------------------------------------------------
5999 !
6000 WWW(3) = WWW(3) - Q3G*DTT/(POROS*ZDEPTH(3))
6001 ROFF = ROFF + Q3G * DTT
6002 !
6003 do 8300 i = 1, 2
6004 !
6005 QMAX = WWW(I) * (POROS*ZDEPTH(I) /DTT)
6006 QMIN = -WWW(I+1) * (POROS*ZDEPTH(I+1)/DTT)
6007 QQQ(I) = AMIN1( QQQ(I),QMAX)
6008 QQQ(I) = AMAX1( QQQ(I),QMIN)
6009 WWW(I) = WWW(I) - QQQ(I)/(POROS*ZDEPTH(I) /DTT)
6010 WWW(I+1) = WWW(I+1) + QQQ(I)/(POROS*ZDEPTH(I+1)/DTT)
6011 8300 continue
6012 !
6013 ! --- LOAD water flow & root-zone drainage PILPS DATA
6014 !crr SOILDIF=SOILDIF+ QQQ(1)* DTT *1000.
6015 !crr SOILDRA=SOILDRA+ Q3G* DTT *1000.
6016 !
6017 do 8400 i = 1, 3
6018 EXCESS = AMAX1(0.,(WWW(I) - 1.))
6019 WWW(I) = WWW(I) - EXCESS
6020 ROFF = ROFF + EXCESS * POROS*ZDEPTH(I)
6021 !
6022 ! --- LOAD IN as root-drainage for PILPS
6023 !crr IF (I.LT.2) THEN
6024 !crr RNOFFS= RNOFFS+ 1000.*EXCESS*POROS*ZDEPTH(I)
6025 !crr ELSE
6026 !crr RNOFFB= RNOFFB+ 1000.*EXCESS*POROS*ZDEPTH(I)
6027 !crr ENDIF
6028 8400 continue
6029 !-----------------------------------------------------------------------
6030 ! prevent negative values of www(i)
6031 !-----------------------------------------------------------------------
6032 !
6033 do 8402 i = 1,2
6034 DEFICIT = AMAX1 (0.,(1.E-12 - WWW(I)))
6035 !crr IF (I.EQ.1) SOILDIF=SOILDIF-DEFICIT * ZDEPTH(1) * POROS
6036 WWW (I) = WWW(I) + DEFICIT
6037 WWW (I+1) = WWW(I+1) - DEFICIT * ZDEPTH(I) / ZDEPTH (I+1)
6038 8402 CONTINUE
6039 WWW(3) = AMAX1 (WWW(3),1.E-12)
6040 ! --------------------------------- end of subroutine RUN2 ------
6041 800 CONTINUE
6042 !
6043 IF (WWW(1) .GT.1.) THEN
6044 WWW(2) = WWW(2) + (WWW(1)-1.) * ZDEPTH(1) / ZDEPTH(2)
6045 !crr SOILDIF=SOILDIF+(WWW(1)-1.)* ZDEPTH(1) * POROS *1000.
6046 WWW(1) = 1.
6047 END IF
6048 If (WWW(2) .GT.1.) THEN
6049 WWW(3) = WWW(3) + (WWW(2)-1.) * ZDEPTH(2) / ZDEPTH(3)
6050 !
6051 ! --- LOAD IN AS PILP ROOT DRAINAGE
6052 WWW(2) = 1.
6053 END IF
6054 IF (WWW(3) .GT.1.) THEN
6055 ROFF = ROFF + (WWW(3)-1.)* ZDEPTH(3) * POROS
6056 !crr RNOFFB=RNOFFB + (WWW(3)-1.)* ZDEPTH(3) * POROS *1000.
6057 WWW(3) = 1.
6058 END IF
6059 !
6060 !------------------------------------------------------
6061 END SUBROUTINE UPDAT1
6062 !------------------------------------------------------
6064 !=======================================================================
6065 !
6066 SUBROUTINE UPDAT1_ICE(DTT,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI, &
6067 EGS,EG,HC,HG,HFLUX,ETMASS,FILTR,SOILDIF,SOILDRA,ROFF, &
6068 RNOFFB,RNOFFS,NROOT,ROOTD,ROOTP,POROS,BEE,SATCO,SLOPE, &
6069 PHSAT,ZDEPTH,WWW,CCX,CG,CHF,SHF,SMELT)
6070 ! 12 AUGUST 2000
6071 !=======================================================================
6072 !
6073 ! UPDATING OF SOIL MOISTURE STORES AND INTERCEPTION CAPACITY
6074 !
6075 !-----------------------------------------------------------------------
6076 !----------------------------------------------------------------------
6078 REAL, DIMENSION (2) :: CAPAC, SNOWW, ROOTD, aaa, bbb, ccc, qqq
6079 REAL, DIMENSION (3) :: WWW, EF, ZDEPTH, ROOTP, temw, temwp, temwpp
6081 !
6082 !----------------------------------------------------------------------
6083 ! EVAPORATION LOSSES ARE EXPRESSED IN J M-2 : WHEN DIVIDED BY
6084 ! ( HLAT*1000.) LOSS IS IN M M-2
6085 ! MASS TERMS ARE IN KG M-2 DT-1
6086 !----------------------------------------------------------------------
6087 !
6088 SNOFAC = HLAT / ( HLAT + SNOMEL /1000. )
6089 FACKS = 1.
6090 IF ( (TC-DTC) .LE. TF ) FACKS = SNOFAC
6091 IF ( (ECT+ECI) .GT. 0.) GO TO 100
6092 ECI = ECT + ECI
6093 ECT = 0.
6094 FACKS = 1. / FACKS
6095 100 CAPAC(1)=CAPAC(1) - ECI*FACKS/HLAT/1000.
6096 !
6097 ECMASS = ( ECT + ECI * FACKS ) / HLAT
6098 !
6099 FACKS = 1.
6100 IF ( (TGS-DTG) .LE. TF ) FACKS = SNOFAC
6101 IF ( (EGT+EGI) .GT. 0. ) GO TO 200
6102 EGI = EGT + EGI
6103 EGT = 0.
6104 FACKS = 1. / FACKS
6105 200 CAPAC(2)=CAPAC(2) - EGI*FACKS/HLAT/1000.
6106 !
6107 EGMASS = ( EGT + EGS + EGI * FACKS ) / HLAT
6108 !
6109 ETMASS = ECMASS + EGMASS
6110 !
6111 HFLUX = ( HC + HG )
6112 !
6113 !----------------------------------------------------------------------
6114 ! DUMPING OF SMALL CAPAC VALUES ONTO SOIL SURFACE STORE
6115 !----------------------------------------------------------------------
6116 !
6117 DO 1000 IVEG = 1, 2
6118 IF ( CAPAC(IVEG) .GT. 0.000001 ) GO TO 300
6119 FILTR = FILTR + CAPAC(IVEG)
6120 WWW(1) = WWW(1) + CAPAC(IVEG) / ( POROS*ZDEPTH(1) )
6121 CAPAC(IVEG) = 0.
6122 300 CONTINUE
6123 1000 CONTINUE
6124 !----------------------------------------------------------------------
6125 ! SNOWMELT / REFREEZE CALCULATION
6126 !----------------------------------------------------------------------
6127 !
6128 ! CALCULATION OF SNOWMELT AND MODIFICATION OF TEMPERATURES
6129 ! N.B. THIS VERSION DEALS WITH REFREEZING OF WATER
6130 !
6131 !-----------------------------------------------------------------------
6132 !
6133 DO 7000 IVEG = 1, 2
6134 !
6135 CCT = CCX
6136 TS = TC
6137 DTS = DTC
6138 FLUX = CHF
6139 IF ( IVEG .EQ. 1 ) GO TO 7100
6140 CCT = CG
6141 TS = TGS
6142 DTS = DTG
6143 FLUX = CCT * DTG / DTT
6145 7100 CONTINUE
6146 !
6147 TTA = TS - DTS
6148 TTB = TS
6149 SNOWW(IVEG) = 0.
6150 IF ( TTA .LE. TF ) SNOWW(IVEG) = CAPAC(IVEG)
6151 CAPAC(IVEG) = CAPAC(IVEG) - SNOWW(IVEG)
6152 IF ( TTA .GT. TF .AND. TTB .GT. TF ) GO TO 7200
6153 IF ( TTA .LE. TF .AND. TTB .LE. TF ) GO TO 7200
6154 !
6155 DTF = TF - TTA
6156 DTIME1 = CCT * DTF / FLUX
6157 HF = FLUX*(DTT-DTIME1)
6158 FCAP = - CAPAC(IVEG) * SNOMEL
6159 SPWET = AMIN1( 5. , SNOWW(IVEG) )
6160 IF ( DTS .GT. 0. ) FCAP = SPWET * SNOMEL
6161 DTIME2 = FCAP / FLUX
6162 DTF2 = FLUX * (DTT-DTIME1-DTIME2)/CCT
6163 TN = TF + DTF2
6164 TS = TF - 0.1
6165 IF (ABS(HF) .GE.ABS(FCAP) ) TS = TN
6166 CHANGE = HF
6167 IF (ABS(CHANGE) .GE.ABS(FCAP) ) CHANGE = FCAP
6168 !
6169 CHANGE = CHANGE / SNOMEL
6170 !
6171 IF (CHANGE.GT.0.0) SMELT=CHANGE+SMELT
6172 !
6173 SNOWW(IVEG) = SNOWW(IVEG) - CHANGE
6174 CAPAC(IVEG) = CAPAC(IVEG) + CHANGE
6175 !
6176 IF ( IVEG .EQ. 1 ) TC = TS
6177 IF ( IVEG .EQ. 2 ) TGS = TS
6178 IF ( SNOWW(IVEG) .LT. 0.00001 ) GO TO 7200
6179 ZMELT = 0.
6180 ! modified to force water into soil. Xue Feb. 1994
6181 ZMELT = CAPAC(IVEG)
6182 FILTR = FILTR+ ZMELT
6183 WWW(1) = WWW(1) + ZMELT / ( POROS * ZDEPTH(1) )
6184 CAPAC(IVEG) = 0.
6185 7200 CONTINUE
6186 !
6187 CAPAC(IVEG) = CAPAC(IVEG) + SNOWW(IVEG)
6188 !
6189 7000 CONTINUE
6190 !
6191 FLUXEF = SHF - CCT*DTG/DTT
6192 TD = TD + FLUXEF / ( CG * 2. * SQRT ( PIE*365. ) ) * DTT
6193 !
6194 change=0.0
6195 !
6196 !----------------------------------------------------------------------
6197 ! BARE SOIL EVAPORATION LOSS
6198 !----------------------------------------------------------------------
6199 !
6200 FILTR = FILTR - EGS / HLAT / 1000.
6201 WWW(1) = WWW(1) - EGS / HLAT / 1000. / ( POROS * ZDEPTH(1) )
6202 !
6203 !----------------------------------------------------------------------
6204 ! EXTRACTION OF TRANSPIRATION LOSS FROM ROOT ZONE
6205 !----------------------------------------------------------------------
6206 !
6207 DO 2000 IVEG = 1, 2
6208 !
6209 IF ( IVEG .EQ. 1 ) ABSOIL = ECT / HLAT / 1000.
6210 IF ( IVEG .EQ. 2 ) ABSOIL = EGT / HLAT / 1000.
6211 !
6212 IF (NROOT.EQ.1) THEN
6213 EF(2) = 0.
6214 EF(3) = 0.
6215 TOTDEP = ZDEPTH(1)
6216 !
6217 DO 3000 IL = 2, 3
6218 TOTDEP = TOTDEP + ZDEPTH(IL)
6219 !
6220 IF ( ROOTD(IVEG) .LT. TOTDEP ) GO TO 400
6221 !
6222 EF(IL) = ZDEPTH(IL) / ROOTD(IVEG)
6223 GO TO 500
6224 !
6225 400 CONTINUE
6226 EF(IL) = ROOTD(IVEG) - TOTDEP + ZDEPTH(IL)
6227 EF(IL) = EF(IL) / ROOTD(IVEG)
6228 GO TO 600
6229 !
6230 500 CONTINUE
6231 3000 CONTINUE
6232 !
6233 600 EFT = EF(2) + EF(3)
6234 !
6235 EFT = MAX(EFT,0.1E-5)
6236 !
6237 EF(2) = EF(2) / EFT
6238 EF(3) = EF(3) / EFT
6239 !
6240 DO 4000 IL = 2, 3
6241 WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
6242 4000 CONTINUE
6243 ELSE
6244 EF(1) = ROOTP(1)
6245 EF(2) = ROOTP(2)
6246 EF(3) = ROOTP(3)
6247 DO 4004 IL = 1, 3
6248 WWW(IL) = WWW(IL) - ABSOIL * EF(IL) / ( POROS * ZDEPTH(IL) )
6249 4004 CONTINUE
6250 END IF
6251 !
6252 2000 CONTINUE
6253 !
6254 !----------------------------------------------------------------------
6255 !
6256 ! CALCULATION OF INTERFLOW, INFILTRATION EXCESS AND LOSS TO
6257 ! GROUNDWATER . ALL LOSSES ARE ASSIGNED TO VARIABLE 'ROFF' .
6258 !
6259 !----------------------------------------------------------------------
6260 !
6261 DO 5000 IL = 1, 2
6262 IF ( WWW(IL) .GT. 0. ) GO TO 700
6263 WWW(IL+1) = WWW(IL+1) + WWW(IL) * ZDEPTH(IL)/ZDEPTH(IL+1)
6264 WWW(IL) = 0.
6265 700 CONTINUE
6266 5000 CONTINUE
6267 !
6268 !=======================================================================
6269 ! calculation of interflow, infiltration excess and loss to
6270 ! groundwater . all losses are assigned to variable 'roff' .
6271 !----------------------------------------------------------------------
6272 !
6273 do 8000 i = 1, 3
6274 !
6275 TEMW(I) = AMAX1( 0.03, WWW(I) )
6276 TEMWP(I) = TEMW(I) ** ( -BEE )
6277 TEMWPP(I) = AMIN1( 1., TEMW(I)) ** ( 2.*BEE+ 3. )
6278 8000 CONTINUE
6279 !
6280 !-----------------------------------------------------------------------
6281 !
6282 ! calculation of gravitationally driven drainage from w(3) : taken
6283 ! as an integral of time varying conductivity.addition of liston
6284 ! baseflow term to original q3g to insure flow in
6285 ! dry season. modified liston baseflow constant scaled
6286 ! by available water.
6287 !
6288 ! q3g (q3) : equation (62) , SE-86
6289 !
6290 !-----------------------------------------------------------------------
6291 !
6292 POWS = 2.*BEE+2.
6293 Q3G = TEMW(3)**(-POWS) + SATCO/ZDEPTH(3)/POROS*SLOPE*POWS*DTT
6294 Q3G = Q3G ** ( 1. / POWS )
6295 Q3G = - ( 1. / Q3G - WWW(3) ) * POROS * ZDEPTH(3) / DTT
6296 Q3G = AMAX1( 0., Q3G )
6297 Q3G = AMIN1( Q3G, WWW(3)*POROS*ZDEPTH(3)/DTT )
6298 !
6299 Q3G = Q3G + 0.002*POROS*ZDEPTH(3)*0.5 / 86400. * WWW(3)
6300 !
6301 !----------------------------------------------------------------------
6302 !
6303 ! calculation of inter-layer exchanges of water due to gravitation
6304 ! and hydraulic gradient. the values of w(x) + dw(x) are used to
6305 ! calculate the potential gradients between layers.
6306 ! modified calculation of mean conductivities follows ME-82 ),
6307 ! reduces recharge flux to top layer.
6308 !
6309 ! dpdw : estimated derivative of soil moisture potential
6310 ! with respect to soil wetness. assumption of
6311 ! gravitational drainage used to estimate likely
6312 ! minimum wetness over the time step.
6313 !
6314 ! qqq (q ) : equation (61) , SE-86
6315 ! i,i+1
6316 ! -
6317 ! avk (k ) : equation (4.14) , ME-82
6318 ! i,i+1
6319 !
6320 !----------------------------------------------------------------------
6321 !
6322 WMAX = AMAX1( WWW(1), WWW(2), WWW(3), 0.05 )
6323 WMAX = AMIN1( WMAX, 1. )
6324 PMAX = WMAX**(-BEE)
6325 WMIN = (PMAX-2./( PHSAT*(ZDEPTH(1)+2.*ZDEPTH(2)+ZDEPTH(3)))) &
6326 **(-1./BEE)
6327 WMIN = AMIN1( WWW(1), WWW(2), WWW(3), WMIN )
6328 WMIN = AMAX1( WMIN, 0.02 )
6329 PMIN = WMIN**(-BEE)
6330 DPDW = PHSAT*( PMAX-PMIN )/( WMAX-WMIN )
6331 !
6332 DO 8200 I = 1, 2
6333 !
6334 RSAME = 0.
6335 AVK = TEMWP(I)*TEMWPP(I) - TEMWP(I+1)*TEMWPP(I+1)
6336 DIV = TEMWP(I+1) - TEMWP(I)
6337 IF ( ABS(DIV) .LT. 1.E-6 ) RSAME = 1.
6338 AVK = SATCO*AVK / ( ( 1. + 3./BEE ) * DIV + RSAME )
6339 AVKMIN = SATCO * AMIN1( TEMWPP(I), TEMWPP(I+1) )
6340 AVKMAX = SATCO * AMAX1( TEMWPP(I), TEMWPP(I+1) )*1.01
6341 AVK = AMAX1( AVK, AVKMIN )
6342 AVK = AMIN1( AVK, AVKMAX )
6343 !
6344 !-----------------------------------------------------------------------
6345 ! conductivities and base flow reduced when temperature drops below
6346 ! freezing.
6347 !-----------------------------------------------------------------------
6348 !
6349 TSNOW = AMIN1 ( TF-0.01, TGS )
6350 AREAS = AMIN1 (0.999,13.2*SNOWW(2))
6351 TGG = TSNOW*AREAS + TGS*(1.-AREAS)
6352 TS = TGG*(2-I) + TD*(I-1)
6353 PROPS = ( TS-(TF-10.) ) / 10.
6354 PROPS = AMAX1( 0.05, AMIN1( 1.0, PROPS ) )
6355 AVK = AVK * PROPS
6356 Q3G = Q3G * PROPS
6357 !
6358 !-----------------------------------------------------------------------
6359 ! backward implicit calculation of flows between soil layers.
6360 !-----------------------------------------------------------------------
6361 !
6362 DPDWDZ = DPDW * 2./( ZDEPTH(I) + ZDEPTH(I+1) )
6363 AAA(I) = 1. + AVK*DPDWDZ*( 1./ZDEPTH(I)+1./ZDEPTH(I+1) ) &
6364 *DTT/POROS
6365 BBB(I) =-AVK * DPDWDZ * 1./ZDEPTH(2)*DTT/POROS
6366 CCC(I) = AVK * ( DPDWDZ * ( WWW(I)-WWW(I+1) ) + 1. + &
6367 (I-1)*DPDWDZ*Q3G*1./ZDEPTH(3)*DTT/POROS )
6368 8200 CONTINUE
6369 !
6370 DENOM = ( AAA(1)*AAA(2) - BBB(1)*BBB(2) )
6371 RDENOM = 0.
6372 IF ( ABS(DENOM) .LT. 1.E-6 ) RDENOM = 1.
6373 RDENOM = ( 1.-RDENOM)/( DENOM + RDENOM )
6374 QQQ(1) = ( AAA(2)*CCC(1) - BBB(1)*CCC(2) ) * RDENOM
6375 QQQ(2) = ( AAA(1)*CCC(2) - BBB(2)*CCC(1) ) * RDENOM
6376 !
6377 !-----------------------------------------------------------------------
6378 ! update wetness of each soil moisture layer due to layer interflow
6379 ! and base flow.
6380 !-----------------------------------------------------------------------
6381 !
6382 WWW(3) = WWW(3) - Q3G*DTT/(POROS*ZDEPTH(3))
6383 ROFF = ROFF + Q3G * DTT
6384 !
6385 DO 8300 I = 1, 2
6386 !
6387 QMAX = WWW(I) * (POROS*ZDEPTH(I) /DTT)
6388 QMIN = -WWW(I+1) * (POROS*ZDEPTH(I+1)/DTT)
6389 QQQ(I) = AMIN1( QQQ(I),QMAX)
6390 QQQ(I) = AMAX1( QQQ(I),QMIN)
6391 WWW(I) = WWW(I) - QQQ(I)/(POROS*ZDEPTH(I) /DTT)
6392 WWW(I+1) = WWW(I+1) + QQQ(I)/(POROS*ZDEPTH(I+1)/DTT)
6393 8300 CONTINUE
6394 !
6395 ! *** LOAD water flow & root-zone drainage PILPS DATA
6396 SOILDIF=SOILDIF+QQQ(1)*DTT*1000.
6397 SOILDRA=SOILDRA+Q3G*DTT*1000.
6398 !
6399 DO 8400 I = 1, 3
6400 EXCESS = AMAX1(0.,(WWW(I) - 1.))
6401 WWW(I) = WWW(I) - EXCESS
6402 ROFF = ROFF + EXCESS * POROS*ZDEPTH(I)
6403 !
6404 ! *** LOAD IN as root-drainage for PILPS
6405 IF (I.LT.2) THEN
6406 RNOFFS= RNOFFS+ 1000.*EXCESS*POROS*ZDEPTH(I)
6407 ELSE
6408 RNOFFB= RNOFFB+ 1000.*EXCESS*POROS*ZDEPTH(I)
6409 ENDIF
6410 8400 CONTINUE
6411 !
6412 !-----------------------------------------------------------------------
6413 ! prevent negative values of www(i)
6414 !-----------------------------------------------------------------------
6415 !
6416 DO 8402 I = 1,2
6417 DEFICIT = AMAX1 (0.,(1.E-12 - WWW(I)))
6418 IF (I.EQ.1) SOILDIF=SOILDIF-DEFICIT* &
6419 ZDEPTH(1)*POROS
6420 WWW (I) = WWW(I) + DEFICIT
6421 WWW (I+1) = WWW(I+1) - DEFICIT * ZDEPTH(I) / ZDEPTH (I+1)
6422 8402 CONTINUE
6423 WWW(3) = AMAX1 (WWW(3),1.E-12)
6424 !
6425 800 CONTINUE
6426 !
6427 IF (WWW(1) .GT.1.) THEN
6428 WWW(2) = WWW(2) + (WWW(1)-1.) * ZDEPTH(1)/ &
6429 ZDEPTH(2)
6430 SOILDIF=SOILDIF+(WWW(1)-1.)*ZDEPTH(1) &
6431 *POROS*1000.
6432 WWW(1) = 1.
6433 END IF
6434 If (WWW(2) .GT.1.) WWW(3) = WWW(3) + (WWW(2)-1.) * &
6435 ZDEPTH(2) / ZDEPTH(3)
6436 !
6437 ! *** LOAD IN AS PILP ROOT DRAINAGE
6438 IF (WWW(2) .GT.1.) WWW(2) = 1.
6439 IF (WWW(3) .GT.1.) THEN
6440 ROFF = ROFF + (WWW(3)-1.)*POROS*ZDEPTH(3)
6441 RNOFFB=RNOFFB+((WWW(3)-1.)*ZDEPTH(3)* &
6442 POROS*1000.)
6443 WWW(3) = 1.
6444 END IF
6445 !
6446 !------------------------------------------------------
6447 END SUBROUTINE UPDAT1_ICE
6448 !------------------------------------------------------
6450 !=======================================================================
6451 !
6452 SUBROUTINE CONVDIM(IOFLAG, &
6453 DZO1,WO1,TSSN1,TSSNO1,BWO1,BTO1,CTO1,FIO1,FLO1,BIO1,BLO1,HO1, &
6454 DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, &
6455 DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, &
6456 DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, &
6457 DZO, WO, TSSN, TSSNO, BWO, BTO, CTO, FIO, FLO, BIO, BLO, HO )
6458 !
6459 !=======================================================================
6460 ! Ratko Oct., 2007
6461 !----------------------------------------------------------------------
6463 REAL, DIMENSION (4) :: DZO,WO,TSSN,TSSNO,BWO,BTO,CTO,FIO,FLO,BIO,BLO,HO
6465 IF (IOFLAG.EQ.0) THEN ! variable to array
6467 DZO (1) = DZO1
6468 WO (1) = WO1
6469 TSSN (1) = TSSN1
6470 TSSNO (1) = TSSNO1
6471 BWO (1) = BWO1
6472 BTO (1) = BTO1
6473 CTO (1) = CTO1
6474 FIO (1) = FIO1
6475 FLO (1) = FLO1
6476 BIO (1) = BIO1
6477 BLO (1) = BLO1
6478 HO (1) = HO1
6480 DZO (2) = DZO2
6481 WO (2) = WO2
6482 TSSN (2) = TSSN2
6483 TSSNO (2) = TSSNO2
6484 BWO (2) = BWO2
6485 BTO (2) = BTO2
6486 CTO (2) = CTO2
6487 FIO (2) = FIO2
6488 FLO (2) = FLO2
6489 BIO (2) = BIO2
6490 BLO (2) = BLO2
6491 HO (2) = HO2
6493 DZO (3) = DZO3
6494 WO (3) = WO3
6495 TSSN (3) = TSSN3
6496 TSSNO (3) = TSSNO3
6497 BWO (3) = BWO3
6498 BTO (3) = BTO3
6499 CTO (3) = CTO3
6500 FIO (3) = FIO3
6501 FLO (3) = FLO3
6502 BIO (3) = BIO3
6503 BLO (3) = BLO3
6504 HO (3) = HO3
6506 DZO (4) = DZO4
6507 WO (4) = WO4
6508 TSSN (4) = TSSN4
6509 TSSNO (4) = TSSNO4
6510 BWO (4) = BWO4
6511 BTO (4) = BTO4
6512 CTO (4) = CTO4
6513 FIO (4) = FIO4
6514 FLO (4) = FLO4
6515 BIO (4) = BIO4
6516 BLO (4) = BLO4
6517 HO (4) = HO4
6519 ELSEIF (IOFLAG.EQ.1) THEN ! array to variable
6521 DZO1 = DZO(1)
6522 WO1 = WO(1)
6523 TSSN1 = TSSN(1)
6524 TSSNO1 = TSSNO(1)
6525 BWO1 = BWO(1)
6526 BTO1 = BTO(1)
6527 CTO1 = CTO(1)
6528 FIO1 = FIO(1)
6529 FLO1 = FLO(1)
6530 BIO1 = BIO(1)
6531 BLO1 = BLO(1)
6532 HO1 = HO(1)
6534 DZO2 = DZO(2)
6535 WO2 = WO(2)
6536 TSSN2 = TSSN(2)
6537 TSSNO2 = TSSNO(2)
6538 BWO2 = BWO(2)
6539 BTO2 = BTO(2)
6540 CTO2 = CTO(2)
6541 FIO2 = FIO(2)
6542 FLO2 = FLO(2)
6543 BIO2 = BIO(2)
6544 BLO2 = BLO(2)
6545 HO2 = HO(2)
6547 DZO3 = DZO(3)
6548 WO3 = WO(3)
6549 TSSN3 = TSSN(3)
6550 TSSNO3 = TSSNO(3)
6551 BWO3 = BWO(3)
6552 BTO3 = BTO(3)
6553 CTO3 = CTO(3)
6554 FIO3 = FIO(3)
6555 FLO3 = FLO(3)
6556 BIO3 = BIO(3)
6557 BLO3 = BLO(3)
6558 HO3 = HO(3)
6560 DZO4 = DZO(4)
6561 WO4 = WO(4)
6562 TSSN4 = TSSN(4)
6563 TSSNO4 = TSSNO(4)
6564 BWO4 = BWO(4)
6565 BTO4 = BTO(4)
6566 CTO4 = CTO(4)
6567 FIO4 = FIO(4)
6568 FLO4 = FLO(4)
6569 BIO4 = BIO(4)
6570 BLO4 = BLO(4)
6571 HO4 = HO(4)
6573 ELSE
6574 print*,'something wrong in CONVDIM',IOFLAG
6575 STOP
6576 ENDIF
6577 !------------------------------------------------------
6578 END SUBROUTINE CONVDIM
6579 !------------------------------------------------------
6581 END MODULE module_sf_ssib