xinanjiang_model.txt

新安江模型源代码,适用于黄土高原区的流域水文模型

Option Explicit
Private Sub Command1_Click()
Dim P(366) As Single, E(366) As Single, PE(366) As Single
Dim P1(366) As Single, P2(366) As Single, P3(366) As Single, P4(366) As Single
Dim E0(366) As Single, Ep(366) As Single
Dim EU(366) As Single, EL(366) As Single, ED(366) As Single
Dim WU(366) As Single, WL(366) As Single, WD(366) As Single, W(366) As Single
Dim Q(366) As Single, R(366) As Single, sumR As Single, sumQ As Single
Dim i As Integer, Kc As Single, WMM As Single, a(366) As Single
Const WUM = 20, WLM = 60, WDM = 60
Const C = 0.16
Const b = 0.3
Const WM = 140
Const FC = 24
Kc = Val(Text1.Text)
If Option1.Value = True Then
Open "89data.txt" For Input As #1 '打开文件
For i = 1 To 365
Input #1, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i) '引用89数据
P(i) = 0.33 * P1(i) + 0.14 * P2(i) + 0.33 * P3(i) + 0.2 * P4(i)
sumQ = sumQ + Q(i) * 24 * 3.6 / 553
Text2.Text = sumQ
Next i
Close #1
End If
If Option2.Value = True Then
Open "90data.txt" For Input As #2 '打开文件
For i = 1 To 365
Input #2, Q(i), E0(i), P1(i), P2(i), P3(i), P4(i) '引用90数据
P(i) = 0.33 * P1(i) + 0.14 * P2(i) + 0.33 * P3(i) + 0.2 * P4(i)
sumQ = sumQ + Q(i) * 24 * 3.6 / 553
Text2.Text = sumQ
Next i
Close #2
End If
WMM = WM * (1 + b)
WU(1) = 10: WL(1) = 40: WD(1) = 60
W(1) = WU(1) + WL(1) + WD(1)
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
Else
If WL(i) >= C * WLM Then
EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * WL(i) / WLM
ED(i) = 0
Else
If WL(i) >= C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = C * (Ep(i) - EU(i))
ED(i) = 0
Else
EU(i) = WU(i) + P(i)
EL(i) = WL(i)
ED(i) = C * (Ep(i) - EU(i)) - EL(i)
End If
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) <= WUM 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) = WUM
If WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM) <= WLM Then
WL(i + 1) = WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM)
WD(i + 1) = WD(i) - ED(i)
Else
WL(i + 1) = WLM
If WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM) - WLM <= WDM Then
WD(i + 1) = WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM) - WLM
Else
WD(i + 1) = WDM
End If
End If
End If
Next i
For i = 1 To 365
sumR = sumR + R(i)
Text3.Text = sumR
Next i
Text4.Text = sumR - sumQ
Text5.Text = (sumR - sumQ) / sumQ
End Sub
Private Sub Command2_Click()
Dim i As Integer, P(28) As Single, Ep(28) As Single, EU(28) As Single, EL(28) As Single
Dim ED(28) As Single, E(28) As Single, PE(28) As Single, WU(29) As Single, WL(29) As Single, WD(29) As Single
Dim W(29) As Single, R(28) As Single, rpe(28) As Single, rg(28) As Single, rs(28) As Single
Dim WUM As Integer, WLM As Integer, WDM As Integer, C As Single, b As Single, FC As Single
Dim WM As Integer, WMM As Single, a(29) As Single, ep2(28) As Single
Dim P1(28) As Single, P2(28) As Single, P3(28) As Single, P4(28) As Single
Dim Qg0 As Single, Cg As Single, U(28) As Integer, Kc As Single
Dim Q(28) As Single, Qs(28) As Single, Qg(28) As Single, j As Integer
Kc = Val(Text1.Text)
WUM = 20: WLM = 60: WDM = 60: C = 0.16: b = 0.3: FC = 11: WM = 140
WMM = WM * (1 + b)
WU(1) = 20: WL(1) = 60: WD(1) = 60
W(1) = WU(1) + WL(1) + WD(1)
a(1) = WMM * (1 - (1 - W(1) / WM) ^ (1 / (1 + b)))
Qg0 = 55.3: Cg = 0.978
Open "暴雨过程.txt" For Input As #1
For i = 1 To 28
Input #1, ep2(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)
Ep(i) = ep2(i) * Kc
Next i
Close #1
'三层蒸散发计算
For i = 1 To 28
If WU(i) + P(i) >= Ep(i) Then
EU(i) = Ep(i): EL(i) = 0: ED(i) = 0
ElseIf WL(i) >= C * WLM Then
EU(i) = WU(i) + P(i)
EL(i) = (Ep(i) - EU(i)) * WL(i) / WLM
ED(i) = 0
ElseIf WL(i) >= C * (Ep(i) - EU(i)) Then
EU(i) = WU(i) + P(i)
EL(i) = C * (Ep(i) - EU(i))
ED(i) = 0
Else
EU(i) = WU(i) + P(i)
EL(i) = WL(i)
ED(i) = C * (Ep(i) - EU(i)) - EL(i)
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
rpe(i) = R(i) / PE(i)
If WU(i) + P(i) - EU(i) - R(i) <= WUM 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) = WUM
If WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM) <= WLM Then
WL(i + 1) = WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM)
WD(i + 1) = WD(i) - ED(i)
Else
WL(i + 1) = WLM
If WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM) - WLM <= WDM Then
WD(i + 1) = WD(i) - ED(i) + WL(i) - EL(i) + (WU(i) + P(i) - EU(i) - R(i) - WUM) - WLM
Else
WD(i + 1) = WDM
End If
End If
End If
Next i
'二水源划分
For i = 1 To 28
If R(i) = 0 Then
rg(i) = 0: rs(i) = 0
Else
If PE(i) < FC Then
rg(i) = R(i)
rs(i) = 0
Else
rg(i) = FC * rpe(i)
rs(i) = R(i) - rg(i)
End If
End If
Next i
Open "单位线.txt" For Input As #4 '打开单位线文件
For i = 1 To 11
Input #4, U(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 * U(i - j + 1)
End If
Next j
Next i
'地下径流汇流计算采用出流系数法
Qg(1) = Cg * Qg0 + (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
For i = 1 To 28
Q(i) = Qs(i) + Qg(i)
Next i
Open "次洪计算结果.txt" For Output As #5 '打开文件
For i = 1 To 28
Print #5, Qs(i); Qg(i); Q(i) '输出计算结果
Next i
End Sub
Private Sub Command3_Click()
End
End Sub