📄 matrixmodule.bas
字号:
End If
If (kk <= k) Then
For i = kk To m
dblU(i, kk) = dblA(i, kk)
Next i
End If
If (kk <= l) Then
d = 0#
For i = kk + 1 To n
d = d + e(i) * e(i)
Next i
e(kk) = Sqr(d)
If (e(kk) <> 0#) Then
If (e(kk + 1) <> 0#) Then
e(kk) = Abs(e(kk))
If (e(kk + 1) < 0#) Then
e(kk) = -e(kk)
End If
End If
For i = kk + 1 To n
e(i) = e(i) / e(kk)
Next i
e(kk + 1) = 1# + e(kk + 1)
End If
e(kk) = -e(kk)
If ((kk + 1 <= m) And (e(kk) <> 0#)) Then
For i = kk + 1 To m
w(i) = 0#
Next i
For j = kk + 1 To n
For i = kk + 1 To m
w(i) = w(i) + e(j) * dblA(i, j)
Next i
Next j
For j = kk + 1 To n
For i = kk + 1 To m
dblA(i, j) = dblA(i, j) - w(i) * e(j) / e(kk + 1)
Next i
Next j
End If
For i = kk + 1 To n
dblV(i, kk) = e(i)
Next i
End If
Next kk
End If
mm = n
If (m + 1 < n) Then mm = m + 1
If (k < n) Then s(k + 1) = dblA(k + 1, k + 1)
If (m < mm) Then s(mm) = 0#
If (l + 1 < mm) Then e(l + 1) = dblA(l + 1, mm)
e(mm) = 0#
nn = m
If (m > n) Then nn = n
If (nn >= k + 1) Then
For j = k + 1 To nn
For i = 1 To m
dblU(i, j) = 0#
Next i
dblU(j, j) = 1#
Next j
End If
If (k >= 1) Then
For ll = 1 To k
kk = k - ll + 1
If (s(kk) <> 0#) Then
If (nn >= kk + 1) Then
For j = kk + 1 To nn
d = 0#
For i = kk To m
d = d + dblU(i, kk) * dblU(i, j) / dblU(kk, kk)
Next i
d = -d
For i = kk To m
dblU(i, j) = dblU(i, j) + d * dblU(i, kk)
Next i
Next j
End If
For i = kk To m
dblU(i, kk) = -dblU(i, kk)
Next i
dblU(kk, kk) = 1# + dblU(kk, kk)
If (kk - 1 >= 1) Then
For i = 1 To kk - 1
dblU(i, kk) = 0#
Next i
End If
Else
For i = 1 To m
dblU(i, kk) = 0#
Next i
dblU(kk, kk) = 1#
End If
Next ll
End If
For ll = 1 To n
kk = n - ll + 1
If ((kk <= l) And (e(kk) <> 0#)) Then
For j = kk + 1 To n
d = 0#
For i = kk + 1 To n
d = d + dblV(i, kk) * dblV(i, j) / dblV(kk + 1, kk)
Next i
d = -d
For i = kk + 1 To n
dblV(i, j) = dblV(i, j) + d * dblV(i, kk)
Next i
Next j
End If
For i = 1 To n
dblV(i, kk) = 0#
Next i
dblV(kk, kk) = 1#
Next ll
For i = 1 To m
For j = 1 To n
dblA(i, j) = 0#
Next j
Next i
m1 = mm
it = 60
While (True)
If (mm = 0) Then
Call Cal1(dblA, e, s, dblV, m, n)
MUav = True
Exit Function
End If
If (it = 0) Then
Call Cal1(dblA, e, s, dblV, m, n)
MUav = False
Exit Function
End If
kk = mm - 1
While ((kk <> 0) And (Abs(e(kk)) <> 0#))
d = Abs(s(kk)) + Abs(s(kk + 1))
dd = Abs(e(kk))
If (dd > eps * d) Then
kk = kk - 1
Else
e(kk) = 0#
End If
Wend
If (kk = mm - 1) Then
kk = kk + 1
If (s(kk) < 0#) Then
s(kk) = -s(kk)
For i = 1 To n
dblV(i, kk) = -dblV(i, kk)
Next i
End If
While ((kk <> m1) And (s(kk) < s(kk + 1)))
d = s(kk)
s(kk) = s(kk + 1)
s(kk + 1) = d
If (kk < n) Then
For i = 1 To n
d = dblV(i, kk)
dblV(i, kk) = dblV(i, kk + 1)
dblV(i, kk + 1) = d
Next i
End If
If (kk < m) Then
For i = 1 To m
d = dblU(i, kk)
dblU(i, kk) = dblU(i, kk + 1)
dblU(i, kk + 1) = d
Next i
End If
kk = kk + 1
Wend
it = 60
mm = mm - 1
Else
ks = mm
While ((ks > kk) And (Abs(s(ks)) <> 0#))
d = 0#
If (ks <> mm) Then d = d + Abs(e(ks))
If (ks <> kk + 1) Then d = d + Abs(e(ks - 1))
dd = Abs(s(ks))
If (dd > eps * d) Then
ks = ks - 1
Else
s(ks) = 0#
End If
Wend
If (ks = kk) Then
kk = kk + 1
d = Abs(s(mm))
t = Abs(s(mm - 1))
If (t > d) Then d = t
t = Abs(e(mm - 1))
If (t > d) Then d = t
t = Abs(s(kk))
If (t > d) Then d = t
t = Abs(e(kk))
If (t > d) Then d = t
sm = s(mm) / d
sm1 = s(mm - 1) / d
em1 = e(mm - 1) / d
sk = s(kk) / d
ek = e(kk) / d
b = ((sm1 + sm) * (sm1 - sm) + em1 * em1) / 2#
c = sm * em1
c = c * c
shh = 0#
If ((b <> 0#) Or (c <> 0#)) Then
shh = Sqr(b * b + c)
If (b < 0#) Then shh = -shh
shh = c / (b + shh)
End If
fg(1) = (sk + sm) * (sk - sm) - shh
fg(2) = sk * ek
For i = kk To mm - 1
Call Cal2(fg, cs)
If (i <> kk) Then e(i - 1) = fg(1)
fg(1) = cs(1) * s(i) + cs(2) * e(i)
e(i) = cs(1) * e(i) - cs(2) * s(i)
fg(2) = cs(2) * s(i + 1)
s(i + 1) = cs(1) * s(i + 1)
If ((cs(1) <> 1#) Or (cs(2) <> 0#)) Then
For j = 1 To n
d = cs(1) * dblV(j, i) + cs(2) * dblV(j, i + 1)
dblV(j, i + 1) = -cs(2) * dblV(j, i) + cs(1) * dblV(j, i + 1)
dblV(j, i) = d
Next j
End If
Call Cal2(fg, cs)
s(i) = fg(1)
fg(1) = cs(1) * e(i) + cs(2) * s(i + 1)
s(i + 1) = -cs(2) * e(i) + cs(1) * s(i + 1)
fg(2) = cs(2) * e(i + 1)
e(i + 1) = cs(1) * e(i + 1)
If (i < m) Then
If ((cs(1) <> 1#) Or (cs(2) <> 0#)) Then
For j = 1 To m
d = cs(1) * dblU(j, i) + cs(2) * dblU(j, i + 1)
dblU(j, i + 1) = -cs(2) * dblU(j, i) + cs(1) * dblU(j, i + 1)
dblU(j, i) = d
Next j
End If
End If
Next i
e(mm - 1) = fg(1)
it = it - 1
Else
If (ks = mm) Then
kk = kk + 1
fg(2) = e(mm - 1)
e(mm - 1) = 0#
For ll = kk To mm - 1
i = mm + kk - ll - 1
fg(1) = s(i)
Call Cal2(fg, cs)
s(i) = fg(1)
If (i <> kk) Then
fg(2) = -cs(2) * e(i - 1)
e(i - 1) = cs(1) * e(i - 1)
End If
If ((cs(1) <> 1#) Or (cs(2) <> 0#)) Then
For j = 1 To n
d = cs(1) * dblV(j, i) + cs(2) * dblV(j, mm)
dblV(j, mm) = -cs(2) * dblV(j, i) + cs(1) * dblV(j, mm)
dblV(j, i) = d
Next j
End If
Next ll
Else
kk = ks + 1
fg(2) = e(kk - 1)
e(kk - 1) = 0#
For i = kk To mm
fg(1) = s(i)
Call Cal2(fg, cs)
s(i) = fg(1)
fg(2) = -cs(2) * e(i)
e(i) = cs(1) * e(i)
If ((cs(1) <> 1#) Or (cs(2) <> 0#)) Then
For j = 1 To m
d = cs(1) * dblU(j, i) + cs(2) * dblU(j, kk - 1)
dblU(j, kk - 1) = -cs(2) * dblU(j, i) + cs(1) * dblU(j, kk - 1)
dblU(j, i) = d
Next j
End If
Next i
End If
End If
End If
Wend
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 模块名：MatrixModule.bas
' 函数名：Cal1
' 功能： 内部过程，供MUav函数调用
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Cal1(dblA() As Double, e() As Double, s() As Double, dblV() As Double, m As Integer, n As Integer)
Dim i As Integer, j As Integer, p As Integer, q As Integer
Dim d As Double
If (m >= n) Then
i = n
Else
i = m
End If
For j = 1 To i - 1
dblA(j, j) = s(j)
dblA(j, j + 1) = e(j)
Next j
dblA(i, i) = s(i)
If (m < n) Then dblA(i, i + 1) = e(i)
For i = 1 To n - 1
For j = i + 1 To n
d = dblV(i, j)
dblV(i, j) = dblV(j, i)
dblV(j, i) = d
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -