md.bas

用VB实现的线性方程组求解的代码。 用的是线性代数上学的东西。

Attribute VB_Name = "md"
Public Const js = 100, jq = 0.000005, xaioshu = 5
Public hangsj As String, hangl As String, z As String, w As String, xl As String
Public y As Integer, hangleng As Integer, xa As Integer, count As Integer
Public shuzhu(js, js) As Double, cax(js) As Double, sor(js, js) As Double


Public Sub sj()
Do
hangsj = LTrim(hangsj)
If Left(hangsj, 1) = Chr(10) Or Left(hangsj, 1) = Chr(13) Then
hangsj = Right(hangsj, Len(hangsj) - 2)
Else
Exit Do
End If
Loop

Do
hangsj = RTrim(hangsj)
If Right(hangsj, 1) = Chr(10) Or Right(hangsj, 1) = Chr(13) Then
hangsj = Left(hangsj, Len(hangsj) - 2)
Else
Exit Do
End If
Loop

Do
    md.y = md.y + 1
    hangleng = InStr(hangsj, Chr(13))
    If hangleng > 0 Then
    md.hang ((Left(hangsj, hangleng - 1)))
    hangsj = Right(hangsj, Len(hangsj) - hangleng)
    Else
    md.hang (hangsj)
    
    Exit Do
    End If
Loop

End Sub





Public Sub hang(hangl As String)
Dim x As Integer, s1 As Integer
Dim su1 As String
If Mid(hangl, 1, 1) = Chr(13) Or Mid(hangl, 1, 1) = Chr(10) Then hangl = Right(hangl, Len(hangl) - 1)
hangl = Trim(hangl)

Do
    s1 = InStr(hangl, Chr(32))
    x = x + 1
    If s1 = 0 Then
        su1 = hangl
        shuzhu(x, y) = Val(su1)
        hangl = Right(hangl, Len(hangl) - s1)
        Exit Do
    Else
        su1 = Left(hangl, s1 - 1)
        shuzhu(x, y) = Val(su1)
        Do
            If Mid(hangl, s1 + 1, 1) = Chr(32) Then s1 = s1 + 1 Else Exit Do
        Loop
        hangl = Right(hangl, Len(hangl) - s1)
    End If
Loop
If xa < x Then xa = x
End Sub

Public Sub gaoss()
Dim i As Integer, p As Integer, t As Integer, temx As Integer, temy As Integer, cc As Integer
Dim tem As Double, k As Double, c As Double
Dim suu(js) As Double

    For p = 1 To xa
    tem = shuzhu(p, p)
    temx = p
    temy = p
    For i = p To y
    If Abs(tem) < Abs(shuzhu(p, i)) Then tem = shuzhu(p, i): temx = p: temy = i
    Next
    For t = 1 To xa
    suu(t) = shuzhu(t, temy)
    Next
    For t = 1 To xa
    shuzhu(t, temy) = shuzhu(t, p)
    Next
    For t = 1 To xa
    shuzhu(t, p) = suu(t)
    Next

    For i = p To y - 1
    If shuzhu(p, p) <> 0 Then
    k = shuzhu(p, i + 1) / shuzhu(p, p)
    For t = p To xa
    shuzhu(t, i + 1) = shuzhu(t, i + 1) - k * shuzhu(t, p)
    Next
    End If
    Next
    
    

Next

     If Abs(shuzhu(y, y) - 0) < jq Then Form1.Text2.Text = "此方程组无解或无惟一解！": GoTo er
    cax(y) = shuzhu(y + 1, y) / shuzhu(y, y)
    For i = y - 1 To 1 Step -1
    cax(i) = 0
    For t = y To i + 1 Step -1
    cax(i) = cax(i) + shuzhu(t, i) * cax(t)
    Next
    cax(i) = (shuzhu(xa, i) - cax(i)) / shuzhu(i, i)
    Next
    
   cc = 0
    For i = 1 To y
    c = 0
    For t = 1 To y
    c = shuzhu(t, i) * cax(t) + c
    Next
    If Abs(c - shuzhu(xa, i)) >= jq Then cc = 1: GoTo en
    Next
en: z = ""
If cc = 1 Then z = z & "计算发生错误，值验算不符！" & Chr(13) & Chr(10) & Chr(13) & Chr(10) Else z = z & "计算成功,验算正确！" & Chr(13) & Chr(10) & "----------------" & Chr(13) & Chr(10)
    
    For i = 1 To y
    For t = 1 To xa
    z = z & FormatNumber(shuzhu(t, i), xaioshu, vbTrue) & "   "
    Next
    z = z & Chr(13) & Chr(10)
Next
 z = z & Chr(13) & Chr(10) & "----------------" & Chr(13) & Chr(10) & " 结果为：" & Chr(13) & Chr(10)
    
    For i = 1 To y
    z = z & FormatNumber(cax(i), xaioshu, vbTrue) & "   "
    Next
Form1.Text2.Text = z

 

er: End Sub


Public Sub sordd()
Dim i As Integer, s1 As Integer, j As Integer, fs As Integer, cc As Integer
Dim p As Double, maxx As Double, maxx0 As Double, c As Double
Dim zz As String, su1 As String



If Mid(xl, 1, 1) = Chr(13) Or Mid(xl, 1, 1) = Chr(10) Then xl = Right(xl, Len(hangl) - 1)
xl = Trim(xl)

Do
    i = i + 1
    s1 = InStr(xl, Chr(32))
    If s1 = 0 Then
        su1 = xl
        cax(i) = Val(su1)
        xl = Right(xl, Len(xl) - s1)
        Exit Do
    Else
        su1 = Left(xl, s1 - 1)
        cax(i) = Val(su1)
        Do
            If Mid(xl, s1 + 1, 1) = Chr(32) Then s1 = s1 + 1 Else Exit Do
        Loop
        xl = Right(xl, Len(xl) - s1)
    End If
Loop


z = ""
count = 0
For i = 1 To xa - 1
For j = 1 To xa - 1
    If shuzhu(i, i) = 0 Then Form1.Text2.Text = " 增广矩阵不符合迭代要求！": GoTo ddd
    If i <> j Then sor(j, i) = -w * shuzhu(j, i) / shuzhu(i, i) Else sor(j, i) = 1 - w
    Next
    Next
For i = 1 To xa - 1
sor(xa, i) = shuzhu(xa, i) * w / shuzhu(i, i)
Next
maxx = 9999999
fs = 0
Do While (maxx >= jq)
maxx = 0
    For i = 1 To xa - 1
    p = 0
    For j = 1 To xa - 1
        p = p + sor(j, i) * cax(j)
        Next
    p = p + sor(xa, i)
    If Abs(cax(i) - p) > maxx Then maxx = Abs(cax(i) - p)
    cax(i) = p
    Next
count = count + 1
If count = 1 Then maxx0 = maxx
If maxx0 * 2 < maxx Then fs = 1: Exit Do
Loop

For i = 1 To xa
z = z & FormatNumber(cax(i), 5, vbTrue) & "    "
Next

zz = "迭代矩阵为：" & Chr(13) & Chr(10) & "-----------------------" & Chr(13) & Chr(10)

For i = 1 To y
For j = 1 To xa
zz = zz & FormatNumber(sor(j, i), xaioshu, vbTrue) & "   "
Next
zz = zz & Chr(13) & Chr(10)
Next
z = zz & "----------------" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & z
z = z & Chr(13) & Chr(10) & "----------------" & Chr(13) & Chr(10) & "迭代次数：" & " " & count & " 次"

   cc = 0
    For i = 1 To y
    c = 0
    For t = 1 To y
    c = shuzhu(t, i) * cax(t) + c
    Next
    If Abs(c - shuzhu(xa, i)) >= jq * 5 Then cc = 1: GoTo en
    Next
en:
If fs = 1 Then zz = "对初始向量的迭代结果发散！" & Chr(13) & Chr(10) & Chr(13) & Chr(10): GoTo dd
If cc = 1 Then zz = "计算发生错误，值验算不符！" & Chr(13) & Chr(10) & Chr(13) & Chr(10) Else zz = "计算成功,验算正确！" & Chr(13) & Chr(10) & "----------------" & Chr(13) & Chr(10) & Chr(13) & Chr(10)

dd:
Form1.Text2.Text = zz & z
ddd:
End Sub