📄 form1.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 9675
ClientLeft = 60
ClientTop = 450
ClientWidth = 7305
LinkTopic = "Form1"
ScaleHeight = 9675
ScaleWidth = 7305
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 495
Left = 4680
TabIndex = 0
Top = 5280
Width = 1215
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''//////支持向量机回归预测说明
'npt为拟合样本总数据，npol为回归系数总数据，npol<=npt,处理
'uu（）为输入样本数据，u()为最小二乘法输入数据，preu()为预测样本输入数据
'a()为回归系数
Private Sub Command1_Click()
npt = 45
Dim Y(200), SIG(200), A(50), CVM(50, 50)
Dim u(200, 50), V(50, 50), W(50), uu(200, 50)
Dim preu(200, 50), prey(50), preuu(200, 50) As Double '定义预测数据
'PROGRAM D9R4
'Driver for routine SVDFIT
Open App.Path & "\1.dat" For Input As #1
' Open App.Path & "\11.dat" For Input As #1
Open App.Path & "\2.dat" For Output As #2
SPREAD = 0.02
npol = 45 '表示回归系数的总数
'Polynomial fi
IDUM& = -911
MP = npt '样本数据总数
NP = npol '回归系数总数
For i = 1 To npt
Input #1, uu(i, 2), uu(i, 3), uu(i, 4), uu(i, 5), uu(i, 6), uu(i, 7), uu(i, 8), uu(i, 9), uu(i, 10), uu(i, 11), Y(i)
'Input #1, uu(i, 2), Y(i)
'Y(I) = Y(I) + SPREAD * GASDEV(IDUM&)
SIG(i) = SPREAD
'SIG(i) = 1
'Print #1, yyy(i), Y(i), (Y(i) - yyy(i))
Next i
For i = 1 To 4
Input #1, preu(i, 2), preu(i, 3), preu(i, 4), preu(i, 5), preu(i, 6), preu(i, 7), preu(i, 8), preu(i, 9), preu(i, 10), preu(i, 11), prey(i)
'Input #1, preu(i, 2), Y(i)
Next i
'／／／／求取内积的矩阵运算
For j = 2 To npol
For i = 1 To npt
u(i, 1) = 1#
u(i, j) = neiji(uu(), j - 1, uu(), i, 11)
' Print #2, u(i, 2)
Next i
Next j
For i = 1 To npt
'Print #2, u(i, 1), u(i, 2), u(i, 3), u(i, 4), u(i, 5), u(i, 6), u(i, 7), u(i, 8), u(i, 9), u(i, 10), u(i, 11), Y(i)
Next i
Call SVDFIT(Y(), SIG(), npt, A(), npol, u(), V(), W(), MP, NP, CHISQ, "FPOLY") 'u()表示最小二乘法系数对应的输入数据
Call SVDVAR(V(), npol, NP, W(), CVM(), npol)
'\\\\\数据预测
For i = 1 To 4
sum1 = A(1)
For j = 2 To npol
sum1 = sum1 + A(j) * neiji(uu(), j - 1, preu(), i, 11)
If i = 4 Then
'Print #2, neiji(uu(), j - 1, preu(), i, npol)
End If
Next j
Print #2, sum1
Next i
Print
Print Tab(5); "Polynomial fit"
'Print
For i = 1 To npol
Print #2, Tab(5); Format$(A(i), "#.##0000")
Print Format$(Sqr(CVM(i, i)), ".#####0")
Next i
Print Tab(5); "Chi-squared "; Format$(CHISQ, "###.####00")
Close #2
Close #1
End Sub
Sub SVDFIT(Y(), SIG(), NDATA, A(), MA, u(), V(), W(), MP, NP, CHISQ, FUNCS$)
TOL = 0.00001
Dim B(1000)
Dim pry(200, 150)
For i = 1 To NDATA
TMP = 1# / SIG(i)
For j = 1 To MA
pry(i, j) = u(i, j)
u(i, j) = u(i, j) * TMP
Next j
B(i) = Y(i) * TMP
Next i
Call SVDCMP(u(), NDATA, MA, W(), V())
WMAX = 0#
For j = 1 To MA
If W(j) > WMAX Then WMAX = W(j)
Next j
THRESH = TOL * WMAX
For j = 1 To MA
If W(j) < THRESH Then W(j) = 0#
Next j
Call SVBKSB(u(), W(), V(), NDATA, MA, B(), A())
CHISQ = 0#
For i = 1 To NDATA
sum1 = 0#
For j = 1 To MA
sum1 = sum1 + A(j) * pry(i, j)
Next j
Print #2, sum1
CHISQ = CHISQ + ((Y(i) - sum1) / SIG(i)) ^ 2
Next i
End Sub
Function GASDEV(IDUM&)
Static ISET, GSET
If ISET = 0 Then
Do
V1 = 2# * RAN1(IDUM&) - 1#
V2 = 2# * RAN1(IDUM&) - 1#
R = V1 ^ 2 + V2 ^ 2
Loop While R >= 1# Or R = 0
FAC = Sqr(-2# * Log(R) / R)
GSET = V1 * FAC
GASDEV = V2 * FAC
ISET = 1
Else
GASDEV = GSET
ISET = 0
End If
End Function
Static Function RAN1(IDUM&)
Dim R(97)
M1& = 259200: IA1& = 7141: IC1& = 54773: RM1 = 0.0000038580247
M2& = 134456: IA2& = 8121: IC2& = 28411: RM2 = 0.0000074373773
M3& = 243000: IA3& = 4561: IC3& = 51349
If IDUM& < 0 Or IFF = 0 Then
IFF = 1
IX1& = (IC1& - IDUM&) Mod M1&
IX1& = (IA1& * IX1& + IC1&) Mod M1&
IX2& = IX1& Mod M2&
IX1& = (IA1& * IX1& + IC1&) Mod M1&
IX3& = IX1& Mod M3&
For j = 1 To 97
IX1& = (IA1& * IX1& + IC1&) Mod M1&
IX2& = (IA2& * IX2& + IC2&) Mod M2&
R(j) = (CSng(IX1&) + CSng(IX2&) * RM2) * RM1
Next j
IDUM& = 1
End If
IX1& = (IA1& * IX1& + IC1&) Mod M1&
IX2& = (IA2& * IX2& + IC2&) Mod M2&
IX3& = (IA3& * IX3& + IC3&) Mod M3&
j = 1 + Int((97 * IX3&) / M3&)
If j > 97 Or j < 1 Then Print "Abnormal exit": Exit Function
RAN1 = R(j)
R(j) = (CSng(IX1&) + CSng(IX2&) * RM2) * RM1
End Function
Sub SVDVAR(V(), MA, NP, W(), CVM(), NCVM)
Dim WTI(200)
For i = 1 To MA
WTI(i) = 0#
If W(i) <> 0# Then WTI(i) = 1# / (W(i) * W(i))
Next i
For i = 1 To MA
For j = 1 To i
sum1 = 0#
For k = 1 To MA
sum1 = sum1 + V(i, k) * V(j, k) * WTI(k)
Next k
CVM(i, j) = sum1
CVM(j, i) = sum1
Next j
Next i
End Sub
Sub SVDCMP(A(), M, N, W(), V())
Dim RV1(200)
If M < N Then Print "You must augment A with extra zero rows."
G = 0#
SCALE1 = 0#
ANORM = 0#
For i = 1 To N
L = i + 1
RV1(i) = SCALE1 * G
G = 0#
S = 0#
SCALE1 = 0#
If i <= M Then
For k = i To M
SCALE1 = SCALE1 + Abs(A(k, i))
Next k
If SCALE1 <> 0# Then
For k = i To M
A(k, i) = A(k, i) / SCALE1
S = S + A(k, i) * A(k, i)
Next k
F = A(i, i)
G = -Sqr(S) * Sgn(F)
H = F * G - S
A(i, i) = F - G
If i <> N Then
For j = L To N
S = 0#
For k = i To M
S = S + A(k, i) * A(k, j)
Next k
F = S / H
For k = i To M
A(k, j) = A(k, j) + F * A(k, i)
Next k
Next j
End If
For k = i To M
A(k, i) = SCALE1 * A(k, i)
Next k
End If
End If
W(i) = SCALE1 * G
G = 0#
S = 0#
SCALE1 = 0#
If i <= M And i <> N Then
For k = L To N
SCALE1 = SCALE1 + Abs(A(i, k))
Next k
If SCALE1 <> 0# Then
For k = L To N
A(i, k) = A(i, k) / SCALE1
S = S + A(i, k) * A(i, k)
Next k
F = A(i, L)
G = -Sqr(S) * Sgn(F)
H = F * G - S
A(i, L) = F - G
For k = L To N
RV1(k) = A(i, k) / H
Next k
If i <> M Then
For j = L To M
S = 0#
For k = L To N
S = S + A(j, k) * A(i, k)
Next k
For k = L To N
A(j, k) = A(j, k) + S * RV1(k)
Next k
Next j
End If
For k = L To N
A(i, k) = SCALE1 * A(i, k)
Next k
End If
End If
If ANORM > Abs(W(i)) + Abs(RV1(i)) Then
ANORM = ANORM
Else
ANORM = Abs(W(i)) + Abs(RV1(i))
End If
Next i
For i = N To 1 Step -1
If i < N Then
If G <> 0# Then
For j = L To N
V(j, i) = (A(i, j) / A(i, L)) / G
Next j
For j = L To N
S = 0#
For k = L To N
S = S + A(i, k) * V(k, j)
Next k
For k = L To N
V(k, j) = V(k, j) + S * V(k, i)
Next k
Next j
End If
For j = L To N
V(i, j) = 0#
V(j, i) = 0#
Next j
End If
V(i, i) = 1#
G = RV1(i)
L = i
Next i
For i = N To 1 Step -1
L = i + 1
G = W(i)
If i < N Then
For j = L To N
A(i, j) = 0#
Next j
End If
If G <> 0# Then
G = 1# / G
If i <> N Then
For j = L To N
S = 0#
For k = L To M
S = S + A(k, i) * A(k, j)
Next k
F = (S / A(i, i)) * G
For k = i To M
A(k, j) = A(k, j) + F * A(k, i)
Next k
Next j
End If
For j = i To M
A(j, i) = A(j, i) * G
Next j
Else
For j = i To M
A(j, i) = 0#
Next j
End If
A(i, i) = A(i, i) + 1#
Next i
For k = N To 1 Step -1
For ITS = 1 To 30
For L = k To 1 Step -1
NM = L - 1
If Abs(RV1(L)) + ANORM = ANORM Then GoTo 2
If Abs(W(NM)) + ANORM = ANORM Then GoTo 1
Next L
1 C = 0#
S = 1#
For i = L To k
F = S * RV1(i)
If Abs(F) + ANORM <> ANORM Then
G = W(i)
H = Sqr(F * F + G * G)
W(i) = H
H = 1# / H
C = (G * H)
S = -(F * H)
For j = 1 To M
Y = A(j, NM)
Z = A(j, i)
A(j, NM) = (Y * C) + (Z * S)
A(j, i) = -(Y * S) + (Z * C)
Next j
End If
Next i
2 Z = W(k)
If L = k Then
If Z < 0# Then
W(k) = -Z
For j = 1 To N
V(j, k) = -V(j, k)
Next j
End If
GoTo 3
End If
If ITS = 30 Then Print "No convergence in 30 iterations"
X = W(L)
NM = k - 1
Y = W(NM)
G = RV1(NM)
H = RV1(k)
F = ((Y - Z) * (Y + Z) + (G - H) * (G + H)) / (2# * H * Y)
G = Sqr(F * F + 1#)
F = ((X - Z) * (X + Z) + H * ((Y / (F + Abs(G) * Sgn(F))) - H)) / X
C = 1#
S = 1#
For j = L To NM
i = j + 1
G = RV1(i)
Y = W(i)
H = S * G
G = G * C
Z = Sqr(F * F + H * H)
RV1(j) = Z
C = F / Z
S = H / Z
F = (X * C) + (G * S)
G = -(X * S) + (G * C)
H = Y * S
Y = Y * C
For NM = 1 To N
X = V(NM, j)
Z = V(NM, i)
V(NM, j) = (X * C) + (Z * S)
V(NM, i) = -(X * S) + (Z * C)
Next NM
Z = Sqr(F * F + H * H)
W(j) = Z
If Z <> 0# Then
Z = 1# / Z
C = F * Z
S = H * Z
End If
F = (C * G) + (S * Y)
X = -(S * G) + (C * Y)
For NM = 1 To M
Y = A(NM, j)
Z = A(NM, i)
A(NM, j) = (Y * C) + (Z * S)
A(NM, i) = -(Y * S) + (Z * C)
Next NM
Next j
RV1(L) = 0#
RV1(k) = F
W(k) = X
Next ITS
3 AAAAA = 1
Next k
End Sub
Sub SVBKSB(u(), W(), V(), M, N, B(), X())
Dim TMP(200)
For j = 1 To N
S = 0#
If W(j) <> 0# Then
For i = 1 To M
S = S + u(i, j) * B(i)
Next i
S = S / W(j)
End If
TMP(j) = S
Next j
For j = 1 To N
S = 0#
For JJ = 1 To N
S = S + V(j, JJ) * TMP(JJ)
Next JJ
X(j) = S
Next j
End Sub
'\\\\\\\\\\\\\\\\\\\\\\定义内积函数
Function neiji(ua(), k1, ub(), k2, npol)
Dim i
Sum = 0
For i = 2 To npol
Sum = Sum + (ua(k1, i) * ub(k2, i)) ^ 2
Next i
neiji = ((Sum) + 1) ^ 3#
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -