?Dim P(1 To 366) As Single '流域的平均降雨量
Dim i As Integer, P1(1 To 366) As Single, P2(1 To 366) As Single, P3(1 To 366) As Single, P4(1 To 366) As Single
Dim E0(1 To 366) As Single '流域的水面蒸发 Dim Ep(1 To 366) As Single '流域的蒸发能力 Dim E(1 To 366) As Single '流域总的蒸发量
Dim EU(1 To 366) As Single, EL(1 To 366) As Single, ED(1 To 366) As Single Dim Q(1 To 366) As Single '流域实测径流 Dim R(1 To 366) As Single '流域计算径流
Dim RS(1 To 366) As Single, RG(1 To 366) As Single, PE(1 To 366) As Single Dim W(1 To 367) As Single '流域总的蓄水量
Dim WU(1 To 367) As Single, WL(1 To 367) As Single, WD(1 To 367) As Single, WMM As Single, a(1 To 367) As Single
Const h1 = 0.33, h2 = 0.14, h3 = 0.33, h4 = 0.2 '各雨量站的权重 Const Wm = 140, Um = 20, Lm = 60, Dm = 60 Const B = 0.3, C = 0.16, IM = 0.002
Private Sub Command1_Click() '任务一运用程序优选Kc
Dim sumQ As Single, sumR As Single, sumR89(2000) As Single, sumQ89(2000) As Single, sumR90(2000) As Single, sumQ90(2000) As Single
Dim JD89(2000) As Single, XD89(2000) As Single, j As Integer, JD90(2000) As Single, XD90(2000) As Single
Dim JDB(2000) As Single, XDB(2000) As Single, Y As Single, minj As Integer, Min As Single, Kc(2000) As Single
Const Fc = 24
For j = 1 To 2000 '运用1989年资料率定 Kc(j) = 0.9 + 0.001 * j
Open "C:\Documents and Settings\Administrator\桌面\水文预报\1989年资料.txt" For Input As #1
For i = 1 To 365 '流域平均降雨量计算 Input #1, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i)
P(i) = 0.33 * P1(i) + 0.14 * P2(i) + 0.33 * P3(i) + 0.2 * P4(i) sumQ89(j) = sumQ89(j) + Q(i) * 24 * 3.6 / 553 Next i Close #1
W(1) = 110: WU(1) = 10: WL(1) = 40: WD(1) = 60 '流域三层蒸发计算 W(1) = WU(1) + WL(1) + WD(1) WMM = Wm * (1 + B)
a(1) = WMM * (1 - (1 - (W(1) / Wm)) ^ (1 / (1 + B))) For i = 1 To 365
Ep(i) = E0(i) * Kc(j) Next i
For i = 1 To 365
If WU(i) + P(i) >= Ep(i) Then EU(i) = Ep(i) EL(i) = 0 ED(i) = 0 End If
If WU(i) + P(i) < Ep(i) Then If WL(i) >= C * Lm Then EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * WL(i) / Lm ED(i) = 0
ElseIf WL(i) < C * Lm And WL(i) >= C * (Ep(i) - EU(i)) Then EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * C ED(i) = 0
ElseIf WL(i) < C * (Ep(i) - EU(i)) Then EU(i) = WU(i) + P(i) EL(i) = WL(i)
ED(i) = (Ep(i) - EU(i)) * C - EL(i) End If End If
E(i) = EU(i) + EL(i) + ED(i)
PE(i) = P(i) - E(i) '流域产流计算 If PE(i) > 0 Then '当产流时 If PE(i) + a(i) < WMM Then
R(i) = PE(i) + W(i) - Wm + Wm * (1 - (PE(i) + a(i)) / WMM) ^ (B + 1) W(i + 1) = W(i) + PE(i) - R(i) a(i + 1) = PE(i) + a(i) ElseIf PE(i) + a(i) >= WMM Then R(i) = PE(i) + W(i) - Wm W(i + 1) = Wm a(i + 1) = WMM End If End If
If WU(i) + P(i) - EU(i) - R(i) <= Um Then WU(i + 1) = WU(i) + P(i) - EU(i) - R(i) WL(i + 1) = WL(i) - EL(i) WD(i + 1) = WD(i) - ED(i) Else
WU(i + 1) = Um
If WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) <= Lm Then
WL(i + 1) = WL(i) - EL(i) + (WU(i) + P(i)
- EU(i) - R(i) - Um) WD(i + 1) = WD(i) - ED(i) Else
WL(i + 1) = Lm
If WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm <= Dm Then WD(i + 1) = WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm Else
WD(i + 1) = Dm End If End If End If
If PE(i) <= 0 Then '当不产流时 R(i) = 0
W(i + 1) = W(i) + PE(i)
a(i + 1) = WMM * (1 - (1 - W(i + 1) / Wm) ^ (1 / (1 + B))) End If Next i
For i = 1 To 365
sumR89(j) = sumR89(j) + R(i) Next i Next j
For j = 1 To 2000 '运用1990年资料率定 Kc(j) = 0.9 + 0.001 * j
Open "C:\Documents and Settings\Administrator\桌面\水文预报\1990年资料.txt" For Input As #2
For i = 1 To 365
Input #2, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i)
P(i) = 0.33 * P1(i) + 0.14 * P2(i) + 0.33 * P3(i) + 0.2 * P4(i) sumQ90(j) = sumQ90(j) + Q(i) * 24 * 3.6 / 553 Next i Close #2
W(1) = 110: WU(1) = 10: WL(1) = 40: WD(1) = 60 W(1) = WU(1) + WL(1) + WD(1) WMM = Wm * (1 + B)
a(1) = WMM * (1 - (1 - (W(1) / Wm)) ^ (1 / (1 + B))) For i = 1 To 365
Ep(i) = E0(i) * Kc(j) Next i
For i = 1 To 365
If WU(i) + P(i) >= Ep(i) Then EU(i) = Ep(i):EL(i) = 0:ED(i) = 0 End If
If WU(i) + P(i) < Ep(i) Then If WL(i) >= C * Lm Then EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * WL(i) / Lm ED(i) = 0
ElseIf WL(i) < C * Lm And WL(i)
EL(i) = (Ep(i) - EU(i)) * C
ED(i) = 0
ElseIf WL(i) < C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = WL(i)
ED(i) = (Ep(i) - EU(i)) * C - EL(i)
End If
End If
E(i) = EU(i) + EL(i) + ED(i)
PE(i) = P(i) - E(i)
If PE(i) > 0 Then
If a(i) + PE(i) < WMM Then
R(i) = PE(i) + W(i) - Wm + Wm * (1 - (PE(i) + a(i)) / WMM) ^ (B + 1)
a(i + 1) = PE(i) + a(i)
W(i + 1) = W(i) + PE(i) - R(i)
Else
R(i) = PE(i) + W(i) - Wm
a(i + 1) = WMM
W(i + 1) = Wm
End If
Else
R(i) = 0
W(i + 1) = W(i) + PE(i)
a(i + 1) = WMM * (1 - (1 - W(i + 1) / Wm) ^ (1 / (1 + B)))
End If
If WU(i) + P(i) - EU(i) - R(i) <= Um Then
WU(i + 1) = WU(i) + P(i) - EU(i) - R(i)
WL(i + 1) = WL(i) - EL(i)
WD(i + 1) = WD(i) - ED(i)
Else
WU(i + 1) = Um
If WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) <= Lm Then
WL(i + 1) = WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um)
WD(i + 1) = WD(i) - ED(i)
Else
WL(i + 1) = Lm
If WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm <= Dm Then WD(i + 1) = WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm
Else
WD(i + 1) = Dm
End If
End If
End If
Next i
For i = 1 To 365
sumR90(j) = sumR90(j) + R(i)
Next i
Next j
For j = 1 To 2000
JD89(j) = sumR89(j) - sumQ89(j)
XD89(j) = (sumR89(j) - sumQ89(j)) / sumQ89(j)
JD90(j) = sumR90(j) - sumQ90(j)
XD90(j) = (sumR90(j) - sumQ90(j)) / sumQ90(j)
Next j
For j = 1 To 2000
JDB(j) = Abs(XD90(j)) - Abs(XD89(j))
XDB(j) = (Abs(XD90(j)) - Abs(XD89(j))) / Abs(XD89(j))
Next j
Min = 1
For j = 1 To 2000 '运用尽量相近原则优选Kc
If Abs(XDB(j)) < Min Then
Min = Abs(XDB(j))
minj = j
End If
Next j
Label2.Caption = Kc(minj) ‘输出计算结果
JD89(
minj) = sumQ89(minj) - sumR89(minj) '绝对误差
XD89(minj) = (sumQ89(minj) - sumR89(minj)) / sumQ89(minj) '相对误差
Text1.Text = sumQ89(minj)
Text2.Text = sumR89(minj)
Text3.Text = JD89(minj)
Text4.Text = XD89(minj)
JD90(minj) = sumQ90(minj) - sumR90(minj) '绝对误差
XD90(minj) = (sumQ90(minj) - sumR90(minj)) / sumQ90(minj) '相对误差
Text5.Text = sumQ90(minj)
Text6.Text = sumR90(minj)
Text7.Text = JD90(minj)
Text8.Text = XD90(minj)
End Sub
Private Sub Command2_Click()'任务二次洪流量计算
Dim Qg(1 To 28) As Single, Qs(1 To 28) As Single, UH(1 To 28) As Integer
Const Fc = 11, Cg = 0.978, Qgchu = 55.3
Kc = Val(Label2.Caption)
Open "C:\Documents and Settings\Administrator\桌面\水文预报\暴雨资料.txt" For Input As #3
For i = 1 To 28
Input #3, E0(i), P1(i), P2(i), P3(i), P4(i)
P(i) = h1 * P1(i) + h2 * P2(i) + h3 * P3(i) + h4 * P4(i)
Ep(i) = E0(i) * Kc
Next i
Close #3
W(1) = 140: WU(1) = 20: WL(1) = 60: WD(1) = 60
W(1) = WU(1) + WL(1) + WD(1)
WMM = Wm * (1 + B)
a(1) = WMM * (1 - (1 - (W(1) / Wm)) ^ (1 / (1 + B)))
For i = 1 To 28
If WU(i) + P(i) >= Ep(i) Then
EU(i) = Ep(i):EL(i) = 0:ED(i) = 0
End If
If WU(i) + P(i) < Ep(i) Then
If WL(i) >= C * Lm Then
EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * WL(i) / Lm
ED(i) = 0
ElseIf WL(i) < C * Lm And WL(i) >= C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * C
ED(i) = 0
ElseIf WL(i) < C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = WL(i)
ED(i) = (Ep(i) - EU(i)) * C - EL(i)
End If
End If
E(i) = EU(i) + EL(i) + ED(i)
PE(i) = P(i) - E(i) '流域产流计算
If PE(i) > 0 Then
If PE(i) + a(i) < WMM Then
R(i) = PE(i) + W(i) - Wm + Wm * (1 - (PE(i) + a(i)) / WMM) ^ (B + 1)
W(i + 1) = W(i) + PE(i) - R(i)
a(i + 1) = PE(i) + a(i)
ElseIf PE(i) + a(i) >= WMM Then
R(i) = PE(i) + W(i) - Wm
W(i + 1) = Wm
a(i + 1) = WMM
End If
End If
If WU(i) + P(i) - EU(i) - R(i) <= Um Then
WU(i + 1) = WU(i) + P(i) - EU(i) - R(i)
WL(i + 1) = WL(i) - EL(i)
WD(i + 1) = WD(i) - ED(i)
Else
WU(i + 1) = Um
If WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) <= Lm Then
WL(i + 1) = WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um)
WD(i + 1) = WD(i) - ED(i)
Else
WL(i + 1) = Lm
If WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm <= Dm Then WD(i + 1) = WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm
Else
WD(i + 1) = Dm
End If
End If
End If
If PE(i) <= 0 Then
R(i) = 0
W(i + 1) = W(i) + PE(i)
a(i + 1) = WMM * (1 - (1 - W(i + 1) / Wm) ^ (1 / (1 + B)))
End If
Next i
For i = 1 To 28 '水源划分
If PE(i) > 0 Then
If PE(i) <= Fc Then
RG(i) = R(i)
RS(i) = 0
Else
RG(i) = Fc * R(i) / PE(i)
RS(i) = R(i) - RG(i)
End If
End If
If PE(i) <= 0 Then
R(i) = 0
RG(i) = 0
RS(i) = 0
End If
Next i
'出流系数法推求地下径流
Qg(1) = Cg * Qgchu + (1 - Cg) * RG(1) * 553 / (3 * 3.6)
For i = 2 To 28
Qg(i) = Cg * Qg(i - 1) + (1 - Cg) * RG(i) * 553 / (3 * 3.6)
Next
i
'单位线推求直接径流
Open "C:\Documents and Settings\Administrator\桌面\水文预报\单位线.txt" For Input As #4 For i = 1 To 11
Input #4, UH(i)
Next i
Close #4
For i = 1 To 28
For j = 1 To 28
If 1 <= i - j + 1 And i - j + 1 <= 28 Then
Qs(i) = Qs(i) + RS(j) / 10 * UH(i - j + 1)
End If
Next j
Next i
For i = 1 To 28 '总的流量
Q(i) = Qs(i) + Qg(i)
Next i
'次洪计算结果输出
Open "C:\Documents and Settings\Administrator\桌面\水文预报\次洪流量过程.txt" For Output As #5
For i = 1 To 28
Print #5, "直接径流:" & Qs(i); "地下径流:" & Qg(i); "次洪总流量:" & Q(i)
Next i
Close #5
End Sub
Private Sub Command3_Click() ‘退出
End
End Sub
Private Sub Command4_Click() ‘人工优选和检验
Dim R(1 To 366) As Single, RS(1 To 366) As Single, RG(1 To 366) As Single
Dim PE(1 To 366) As Single, W(1 To 366) As Single, WU(1 To 366) As Single, WL(1 To 366) As Single, WD(1 To 366) As Single
Dim WMM As Single, a(1 To 366) As Single
Dim sumQ As Single, sumR As Single, sumQ90 As Single, sumR90 As Single
Kc = Val(Text9.Text)
If Option1.Value = True Then
Open "C:\Documents and Settings\Administrator\桌面\水文预报\1989年资料.txt" For Input As #1
For i = 1 To 365
Input #1, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i)
P(i) = h1 * P1(i) + h2 * P2(i) + h3 * P3(i) + h4 * P4(i)
sumQ = sumQ + Q(i) * 24 * 3600 * 1000 / 553000000
Text1.Text = sumQ
Next i
Close #1
End If
If Option2.Value = True Then
Open "C:\Documents and Settings\Administrator\桌面\水文预报\1990年资料.txt" For Input As #2
For i = 1 To 365
Input #2, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i)
P(i) = h1 * P1(i) + h2 * P2(i) + h3 * P3(i) + h4 * P4(i)
sumQ90 = sumQ90 + Q(i) * 24 * 3600 * 1000 / 553000000
Text5.Text = sumQ90
Next i
Close #2
End If
If Option3.Value = True Then
Open "C:\Documents and Settings\Administrator\桌面\水文预报\1991年资料.txt" For Input As #6
For i = 1 To 365 '运用1991年资料检验
Input #6, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i)
P(i) = h1 * P1(i) + h2 * P2(i) + h3 * P3(i) + h4 * P4(i)
sumQ = sumQ + Q(i) * 24 * 3600 * 1000 / 553000000
Text1.Text = sumQ
Next i
Close #6
End If
W(1) = 110: WU(1) = 10: WL(1) = 40: WD(1) = 60
W(1) = WU(1) + WL(1) + WD(1)
WMM = Wm * (1 + B)
a(1) = WMM * (1 - (1 - (W(1) / Wm)) ^ (1 / (1 + B)))
For i = 1 To 365
Ep(i) = E0(i) * Kc
Next i
For i = 1 To 365
If WU(i) + P(i) >= Ep(i) Then
EU(i) = Ep(i): EL(i) = 0: ED(i) = 0
End If
If WU(i) + P(i) < Ep(i) Then
If WL(i) >= C * Lm Then
EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * WL(i) / Lm
ED(i) = 0
ElseIf WL(i) < C * Lm And WL(i) >= C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * C
ED(i) = 0
ElseIf WL(i) < C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = WL(i)
ED(i) = (Ep(i) - EU(i)) * C - EL(i)
End If
End If
E(i) = EU(i) + EL(i) + ED(i)
PE(i) = P(i) - E(i)
If PE(i) > 0 Then
If PE(i) + a(i) < WMM Then
R(i) = PE(i) + W(i) - Wm + Wm * (1
- (PE(i) + a(i)) / WMM) ^ (B + 1)
W(i + 1) = W(i) + PE(i) - R(i)
a(i + 1) = PE(i) + a(i)
ElseIf PE(i) + a(i) >= WMM Then
R(i) = PE(i) + W(i) - Wm
W(i + 1) = Wm
a(i + 1) = WMM
End If
End If
If WU(i) + P(i) - EU(i) - R(i) <= Um Then
WU(i + 1) = WU(i) + P(i) - EU(i) - R(i)
WL(i + 1) = WL(i) - EL(i)
WD(i + 1) = WD(i) - ED(i)
Else
WU(i + 1) = Um
If WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) <= Lm Then
WL(i + 1) = WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um)
WD(i + 1) = WD(i) - ED(i)
Else
WL(i + 1) = Lm
If WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm <= Dm Then
WD(i + 1) = WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - Um) - Lm
Else
WD(i + 1) = Dm
End If
End If
End If
If PE(i) <= 0 Then
R(i) = 0
W(i + 1) = W(i) + PE(i)
a(i + 1) = WMM * (1 - (1 - W(i + 1) / Wm) ^ (1 / (1 + B)))
End If
Next i
If Option1.Value = True Or Option3.Value = True Then
For i = 1 To 365
sumR = sumR + R(i)
Next i
Text2.Text = sumR
Text3.Text = sumQ - sumR
Text4.Text = (sumQ - sumR) / sumQ
End If
If Option2.Value = True Then
For i = 1 To 365
sumR90 = sumR90 + R(i)
Next i
Text6.Text = sumR90
Text7.Text = sumQ90 - sumR90
Text8.Text = (sumQ90 - sumR90) / sumQ90
End If
End Sub