【新安江模型】基于VB实现的的二水源新安江模型
说明
VB6.0环境下，能够正常运行，VB6.0安装教程
业务逻辑代码是复制网上公开代码，界面是根据其公开图片绘制的，没有进行优化。示例数据也是随便设置的。
核心代码
'读入起始数据
file1 = App.Path & "\par\qishizhi.txt"
If Dir(file1) = "" Then MsgBox "初始文件" + file1 + "不存在， 请软件商联系！ ", _
vbInformation + vbOKOnly, "提示信息": Exit Sub
Open file1 For Input As #1
Input #1, W(0), wu(0), wl(0), wd(0), QRG(0)
Close #1
'读入参数值
Dim im, wm, wum, wlm, b
Dim c, fc, k, kkg, u
file1 = App.Path & "\par\mscpar.txt"
If Dir(file1) = "" Then MsgBox "初始文件" + file1 + "不存在， 请软件商联系！ ", _
vbInformation + vbOKOnly, "提示信息": Exit Sub
Open file1 For Input As #1
Input #1, im, wm, wum, wlm, b
Input #1, c, fc, k, kkg, u
Close #1
'读入单位线值
z = 9
ReDim UH(1 To z)
file1 = App.Path & "\par\dwx.txt"
If Dir(file1) = "" Then MsgBox "初始文件" + file1 + "不存在， 请软件商联系！ ", _
vbInformation + vbOKOnly, "提示信息": Exit Sub
Open file1 For Input As #1
For i = 1 To z
Input #1, UH(i)
Next
Close #1
'新安江模型的主程序
wmm = (1 + b) * wm / (1 - im)
For i = 1 To n
pe(i) = p(i) - k * em(i)
If pe(i) > 0 Then
a(i) = wmm * (1 - (1 - W(i - 1) / wm) ^ (1 / (1 + b)))
If a(i) + pe(i) < wmm Then
r(i) = pe(i) - wm + W(i - 1) + wm * (1 - (pe(i) + a(i)) / wmm) ^ (1 + b)
Else
r(i) = pe(i) + W(i - 1) - wm
End If
If pe(i) < fc Then
rg(i) = r(i) - im * pe(i)
rs(i) = r(i) - rg(i)
Else
rg(i) = (r(i) - im * pe(i)) / pe(i) * fc
rs(i) = r(i) - rg(i)
End If
eu(i) = k * em(i)
ed(i) = 0
el(i) = 0
If wu(i - 1) + pe(i) - r(i) < wum Then
wu(i) = wu(i - 1) + pe(i) - r(i)
wl(i) = wl(i - 1)
wd(i) = wd(i - 1)
Else
If wu(i - 1) + wl(i - 1) + pe(i) - r(i) - wum > wlm Then
wu(i) = wum
wl(i) = wlm
wd(i) = W(i - 1) + pe(i) - r(i) - wu(i) - wl(i)
Else
wl(i) = wu(i - 1) + wl(i - 1) + pe(i) - r(i) - wum
wu(i) = wum
wd(i) = wd(i - 1)
End If
End If
Else
r(i) = 0
rg(i) = 0
rs(i) = 0
If wu(i - 1) + p(i) > k * em(i) Then
eu(i) = k * em(i)
ed(i) = 0
el(i) = 0
wu(i) = wu(i - 1) + pe(i)
wl(i) = wl(i - 1)
wd(i) = wd(i - 1)
Else
eu(i) = wu(i - 1) + p(i)
wu(i) = 0
wl(i) = wl(i - 1)
wd(i) = wd(i - 1)
If wl(i - 1) > c * wlm Then
el(i) = (k * em(i) - eu(i)) * wl(i - 1) / wlm
wl(i) = wl(i - 1) - el(i)
ed(i) = 0
wd(i) = wd(i - 1)
If wl(i - 1) > c * (k * em(i) - eu(i)) Then
el(i) = c * (k * em(i) - eu(i))
wl(i) = wl(i - 1) - el(i)
ed(i) = 0
wd(i) = wd(i - 1)
Else
el(i) = wl(i - 1)
wl(i) = 0
ed(i) = c * (k * em(i) - eu(i)) - el(i)
wd(i) = wd(i - 1) - ed(i)
End If
End If
End If
End If
e(i) = eu(i) + el(i) + ed(i)
W(i) = wu(i) + wl(i) + wd(i)
QRG(i) = QRG(i - 1) * kkg + rg(i) * (1 - kkg) * u
'输出结果
p(i) = Format(p(i), "0.00")
em(i) = Format(em(i), "0.00")
pe(i) = Format(pe(i), "0.00")
r(i) = Format(r(i), "0.00")
rg(i) = Format(rg(i), "0.00")
rs(i) = Format(rs(i), "0.00")
e(i) = Format(e(i), "0.00")
W(i) = Format(W(i), "0.00")
QRG(i) = Format(QRG(i), "0.00")
Next i
'汇流计算
ReDim QRS(1 To n + z)
For j = 1 To n
For k = 1 To z
QRS(j + k - 1) = rs(j) * UH(k) + QRS(j + k - 1)
Next k
Next j
For i = 1 To n
Debug.Print QRS(i)
Next i
For i = 1 To n
Q(i) = QRG(i) + QRS(i)
'输出结果
QRS(i) = Format(QRS(i), "0.00")
Q(i) = Format(Q(i), "0.00")
'结果保存在文件中
file1$ = App.Path & "\par\jieguo.txt"
Open file1$ For Output As #2
For j = 1 To n
Print #2, p(j), em(j), pe(j), r(j), rg(j), rs(j), e(j), W(j), QRG(j), QRS(j), Q(j)
Next j
Close #2
Debug.Print p(i), em(i), pe(i), r(i), rg(i), rs(i), e(i), W(i), QRG(i), QRS(i), Q(i)
Next i
MsgBox "计算结束", vbInformation + vbOKCancel, "提示信息"
End Sub
下载链接
包含两个VB6.0写的二水源新安江模型代码，下载链接：基于VB6.0的二水源新安江模型