d1r1.frm

矩阵特征值的求解过程之二

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3795
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3795
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   2880
      TabIndex        =   0
      Top             =   3120
      Width           =   1455
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
    'program D1R1
    'Driver program for routine GAUSSJ
    N = 3
    Dim A(3, 3), B(3), A1(3, 3), B1(3)
    '输入已知的方程组的系数矩阵
    A(1, 1) = 2: A(1, 2) = 1: A(1, 3) = 2
    A(2, 1) = 5: A(2, 2) = -1: A(2, 3) = 1
    A(3, 1) = 1: A(3, 2) = -3: A(3, 3) = -4
    '输入已知的方程组的右端向量B
    B(1) = 5
    B(2) = 8
    B(3) = -4
    Print
    Print Tab(5); "已知的方程组的右端向量"
    Print Tab(14); Format$(B(1), "##.##")
    Print Tab(14); Format$(B(2), "##.##")
    Print Tab(14); Format$(B(3), "##.##")
    For I = 1 To N
        For J = 1 To 3
        A1(I, J) = A(I, J)
        Next J
    Next I
    Call GAUSSJ(A(), N, B())
    Print
    Print Tab(5); "计算出的方程组的解"
    Print Tab(14); Format$(B(1), "##.##")
    Print Tab(14); Format$(B(2), "##.##")
    Print Tab(14); Format$(B(3), "##.##")
    '将计算出的解B乘以系数矩阵，以验证计算结果正确
    For L = 1 To N
        B1(L) = 0#
        For J = 1 To N
            B1(L) = B1(L) + A1(L, J) * B(J)
        Next J
    Next L
    Print
    Print Tab(5); "计算出的解乘以系数矩阵的结果"
    Print Tab(14); Format$(B1(1), "##.##")
    Print Tab(14); Format$(B1(2), "##.##")
    Print Tab(14); Format$(B1(3), "##.##")
End Sub
Sub GAUSSJ(A(), N, B())
    Dim IPIV(50), INDXR(50), INDXC(50)
    For J = 1 To N
        IPIV(J) = 0
    Next J
    For I = 1 To N
        BIG = 0#
        For J = 1 To N
            If IPIV(J) <> 1 Then
                For K = 1 To N
                If IPIV(K) = 0 Then
                    If Abs(A(J, K)) >= BIG Then
                        BIG = Abs(A(J, K))
                        IROW = J
                        ICOL = K
                    End If
                ElseIf IPIV(K) > 1 Then
                    Print "Singular matrix"
                End If
                Next K
            End If
        Next J
        IPIV(ICOL) = IPIV(ICOL) + 1
        If IROW <> ICOL Then
            For L = 1 To N
                DUM = A(IROW, L)
                A(IROW, L) = A(ICOL, L)
                A(ICOL, L) = DUM
            Next L
            DUM = B(IROW)
            B(IROW) = B(ICOL)
            B(ICOL) = DUM
        End If
        INDXR(I) = IROW
        INDXC(I) = ICOL
        If A(ICOL, ICOL) = 0# Then Print "Singular matrix."
        PIVINV = 1# / A(ICOL, ICOL)
        A(ICOL, ICOL) = 1#
        For L = 1 To N
            A(ICOL, L) = A(ICOL, L) * PIVINV
        Next L
        B(ICOL) = B(ICOL) * PIVINV
        For LL = 1 To N
            If LL <> ICOL Then
                DUM = A(LL, ICOL)
                A(LL, ICOL) = 0#
                For L = 1 To N
                    A(LL, L) = A(LL, L) - A(ICOL, L) * DUM
                Next L
                B(LL) = B(LL) - B(ICOL) * DUM
            End If
        Next LL
    Next I
    For L = N To 1 Step -1
        If INDXR(L) <> INDXC(L) Then
            For K = 1 To N
                DUM = A(K, INDXR(L))
                A(K, INDXR(L)) = A(K, INDXC(L))
                A(K, INDXC(L)) = DUM
            Next K
        End If
    Next L
End Sub