📄 遗传算法.frm
字号:
' For k = 1 To 5
mid1 = arel * tao(choose1(i), j) + (1 - arel) * tao(choose1(2 * pcnum - i + 1), j)
mid2 = (1 - arel) * tao(choose1(i), j) + arel * tao(choose1(2 * pcnum - i + 1), j)
' If Abs(mid1) < 0.0001 Then mid1 = 0.5
' If Abs(mid2) < 0.0001 Then mid2 = 0.5
' If sel_bz = 1 Then
' If mid1 < 0 Or mid1 > 1 Then mid1 = 0.5
' If mid2 < 0 Or mid2 > 1 Then mid2 = 0.5
' End If
tao(choose1(i), j) = mid1
tao(choose1(2 * pcnum - i + 1), j) = mid2
' Next k
' Case 3:
' mid1 = arel * di(choose1(i)) + (1 - arel) * di(choose1(2 * pcnum - i + 1))
' mid2 = (1 - arel) * di(choose1(i)) + arel * di(choose1(2 * pcnum - i + 1))
' di(choose1(i)) = mid1
' di(choose1(2 * pcnum - i + 1)) = mid2
' End Select
End If
Next j
Next i
'变异
Randomize
pmnum = Int(pm * popnum)
For i = 1 To pmnum
If i > 1 Then
18 midval = Int((popnum * Rnd) + 1)
If BZ(midval) = 1 Then GoTo 18
For j = 1 To i - 1
If choose1(j) = midval Then GoTo 18
Next j
choose1(i) = midval
Else
70 choose1(i) = Int((popnum * Rnd) + 1)
If BZ(choose1(i)) = 1 Then GoTo 70
End If
Randomize
choosexh = Int((5 * Rnd) + 1)
' Select Case choosexh
' Case 1:
'For k = 1 To 5
k = choosexh
tao(choose1(i), k) = tao(choose1(i), k) + Int(((quan1(2, k) - quan1(1, k)) * Rnd) - quan1(1, k))
'Next k
' Case 2:
For k = 1 To 5
4 midval = lamd(choose1(i), k) + Int(((quan2(2, k) - quan2(1, k)) * Rnd) - quan2(1, k))
If Abs(midval) < 0.00001 Then GoTo 4
If sel_bz = 1 And (midval < 0 Or midval > 1) Then GoTo 4
lamd(choose1(i), k) = midval
Next k
cont(choose1(i)) = cont(choose1(i)) + Int(((quan4 - quan3) * Rnd) - quan3)
' Case 3:
' di(choose1(i)) = di(choose1(i)) + Int(((quan(2, 3) - quan(1, 3)) * Rnd) - quan(1, 3))
' End Select
Next i
sumjsq = sumjsq + 1
GoTo 1
100 Close #2
End Sub
Private Sub Form_Load()
ReDim grpoint(grnum_max), gr_type(grnum_max), grnote_visible(grnum_max), grnote_LR(grnum_max)
ReDim grnote_name$(grnum_max)
ReDim Lstyle(grnum_max), Lwidth(grnum_max), Lcolor(grnum_max)
ReDim Pstyle(grnum_max), Pwidth(grnum_max), Pcolor(grnum_max)
ReDim grdatx(grnum_max, grpoint_max), grdaty(grnum_max, grpoint_max)
'Me.Left = 3600: Me.Top = 2000
'Me.Width = 5240: Me.Height = 5352
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -