12
13
14
15
16
17
18
19
20
21
22
23
25
26 IMPLICIT NONE
27 INTEGER, PARAMETER :: ndays = 366
28 INTEGER, PARAMETER :: NSurf = 7
29 INTEGER, PARAMETER :: NVegSurf = 3
30 INTEGER, PARAMETER :: ivConif = 1
31 INTEGER, PARAMETER :: ivGrass = 3
32
33
34 REAL(KIND(1D0)), PARAMETER :: Qm = 0
35
36 INTEGER, INTENT(in) :: veg_type
37 INTEGER, INTENT(in) :: SnowUse
38
39 REAL(KIND(1D0)), INTENT(in) :: qn1
40 REAL(KIND(1D0)), INTENT(in) :: qf
41 REAL(KIND(1D0)), INTENT(in) :: qs
42 REAL(KIND(1D0)), INTENT(in) :: Temp_C
43 REAL(KIND(1D0)), INTENT(in) :: VegFraction
44 REAL(KIND(1D0)), INTENT(in) :: avcp
45 REAL(KIND(1D0)), INTENT(in) :: Press_hPa
46 REAL(KIND(1D0)), INTENT(in) :: lv_J_kg
47 REAL(KIND(1D0)), INTENT(in) :: tstep_real
48 REAL(KIND(1D0)), INTENT(in) :: DRAINRT
49 REAL(KIND(1D0)), INTENT(in) :: nsh_real
50 REAL(KIND(1D0)), INTENT(in) :: Precip
51 REAL(KIND(1D0)), INTENT(in) :: RainMaxRes
52 REAL(KIND(1D0)), INTENT(in) :: RAINCOVER
53
54 REAL(KIND(1D0)), DIMENSION(nsurf), INTENT(in) :: sfr_surf
55 REAL(KIND(1D0)), DIMENSION(NVEGSURF), INTENT(in) :: LAI_id_prev
56 REAL(KIND(1D0)), DIMENSION(3), INTENT(in) :: LAImax
57 REAL(KIND(1D0)), DIMENSION(3), INTENT(in) :: LAImin
58
59 REAL(KIND(1D0)), INTENT(out) :: QH_LUMPS
60 REAL(KIND(1D0)), INTENT(out) :: QE_LUMPS
61 REAL(KIND(1D0)), INTENT(out) :: psyc_hPa
62 REAL(KIND(1D0)), INTENT(out) :: s_hPa
63 REAL(KIND(1D0)), INTENT(out) :: sIce_hpa
64 REAL(KIND(1D0)), INTENT(out) :: Veg_Fr_temp
65 REAL(KIND(1D0)), INTENT(out) :: VegPhenLumps
66
67
68
69 REAL(KIND(1D0)), DIMENSION(3) :: sfrVeg
70 REAL(KIND(1D0)) :: VegPhen, VegMax, VegMin, &
71 psyc_s, &
72 alpha_sl, alpha_in, &
73 beta, &
74 alpha_qhqe, rainres, rainbucket, tlv
75 REAL(KIND(1D0)), PARAMETER :: NAN = -999
76
77 tlv = lv_j_kg/tstep_real
78
79 vegphenlumps = 0
80
81
82 rainbucket = 0.
83
84
85 sfrveg = sfr_surf(ivconif + 2:ivgrass + 2)
86
87
89 psyc_hpa =
psyc_const(avcp, press_hpa, lv_j_kg)
90 psyc_s = psyc_hpa/s_hpa
91
92
93
94 IF (snowuse == 1) THEN
95 IF (temp_c <= 0) THEN
97 ELSE
99 END IF
100 psyc_s = psyc_hpa/sice_hpa
101 END IF
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123 vegphen = dot_product(sfrveg, lai_id_prev)
124 vegmax = dot_product(sfrveg, laimax)
125 vegmin = dot_product(sfrveg, laimin)
126
127
128
129
130
131
132
133 IF (vegmax <= 0.01000) THEN
134 veg_fr_temp = 0
135 ELSE
136 vegphenlumps = (vegphen)/(vegmax)
137 veg_fr_temp = vegfraction*vegphenlumps
138 END IF
139
140
141 alpha_sl = 0.6
142 alpha_in = 0.2
143
144 IF (veg_fr_temp > 0.9000) THEN
145 beta = (20 - 3)*veg_fr_temp + 3
146 alpha_qhqe = veg_fr_temp*0.8 + 0.2
147 ELSE
148 beta = 3
149 IF (veg_type == 1) THEN
150 alpha_sl = 0.686
151 alpha_in = 0.189
152 ELSEIF (veg_type == 2) THEN
153 alpha_sl = 0.610
154 alpha_in = 0.222
155 END IF
156 alpha_qhqe = veg_fr_temp*alpha_sl + alpha_in
157 END IF
158
159
160 qh_lumps = ((1 - alpha_qhqe) + psyc_s)/(1 + psyc_s)*(qn1 + qf - qs
161
162 IF (qh_lumps == nan) qh_lumps = qn1*0.2
163 qe_lumps = (alpha_qhqe/(1 + psyc_s)*(qn1 + qf - qs - qm)) + beta
164
165
166
167 IF (qe_lumps > 0.) rainbucket = rainbucket - qe_lumps/tlv
168 IF (temp_c > 0.) rainbucket = rainbucket - drainrt/nsh_real
169 IF (rainbucket < 0.) rainbucket = 0.
170 IF (precip > 0) rainbucket = min(rainmaxres, rainbucket + precip)
171
172 rainres = rainbucket
173 IF (rainres > raincover) rainres = raincover
174
175 RETURN
176
real(kind(1d0)) function slope_svp(temp_C)
real(kind(1d0)) function slopeice_svp(temp_C)
real(kind(1d0)) function psyc_const(cp, Press_hPa, lv_J_kg)