d1r11.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4845
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   4845
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   3000
      TabIndex        =   0
      Top             =   4200
      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 D1R11
    'Driver program for routine QRBKSB,QRDCMP
    N = 5
    Dim A(5, 5), B(5), Q(5, 5), C(5, 5), R(5), X(5)
    '输入已知的方程组的系数矩阵
    A(1, 1) = 1.4: A(1, 2) = 2.1: A(1, 3) = 2.1: A(1, 4) = 7.4: A(1, 5) = 9.6
    A(2, 1) = 1.6: A(2, 2) = 1.5: A(2, 3) = 1.1: A(2, 4) = 0.7: A(2, 5) = 5#
    A(3, 1) = 3.8: A(3, 2) = 8#:  A(3, 3) = 9.6: A(3, 4) = 5.4: A(3, 5) = 8.8
    A(4, 1) = 4.6: A(4, 2) = 8.2: A(4, 3) = 8.4: A(4, 4) = 0.4: A(4, 5) = 8#
    A(5, 1) = 2.6: A(5, 2) = 2.9: A(5, 3) = 0.1: A(5, 4) = 9.9: A(5, 5) = 7.7
    '输入已知的方程组的右端向量B
    B(1) = 1.1
    B(2) = 1.6
    B(3) = 4.7
    B(4) = 9.1
    B(5) = 0.1
    Print
    Print Tab(5); "已知的方程组的右端向量"
    Print Tab(14); Format$(B(1), "##.##")
    Print Tab(14); Format$(B(2), "##.##")
    Print Tab(14); Format$(B(3), "##.##")
    Print Tab(14); Format$(B(4), "##.##")
    Print Tab(14); Format$(B(5), "##.##")
    For I = 1 To N
        For J = 1 To N
           C(I, J) = A(I, J)
        Next J
    Next I
    Call QRDCMP(C(), N, N, Q())
    For I = 1 To N
        R(I) = B(I)
    Next I
    Call QRBKSB(C(), N, Q(), R(), X())
    Print
    Print Tab(5); "计算出的方程组的解"
    Print Tab(10); Format$(X(1), "#.####E+00")
    Print Tab(10); Format$(X(2), "#.####E+00")
    Print Tab(10); Format$(X(3), "#.####E+00")
    Print Tab(10); Format$(X(4), "#.####E+00")
    Print Tab(10); Format$(X(5), "#.####E+00")
    '将计算出的解乘以系数矩阵，以验证计算结果正确
    For L = 1 To N
        B(L) = 0#
        For J = 1 To N
            B(L) = B(L) + A(L, J) * X(J)
        Next J
    Next L
    Print
    Print Tab(5); "计算出的解乘以系数矩阵的结果"
    Print Tab(14); Format$(B(1), "##.##")
    Print Tab(14); Format$(B(2), "##.##")
    Print Tab(14); Format$(B(3), "##.##")
    Print Tab(14); Format$(B(4), "##.##")
    Print Tab(14); Format$(B(5), "##.##")
End Sub
Sub QRDCMP(A(), M, N, Q())
    For I = 1 To M
        For J = 1 To M
            Q(I, J) = 0#
        Next J
        Q(I, I) = 1#
    Next I
    For K = 1 To M - 1
        S = 0#
        For I = K To M
            S = S + Abs(A(I, K))
        Next I
        If S <> 0# Then
            T = 0#
            For I = K To M
                A(I, K) = A(I, K) / S
                T = T + A(I, K) * A(I, K)
            Next I
            T = -Sqr(T) * Sgn(A(K, K))
            A(K, K) = A(K, K) - T
            H = -T * A(K, K)
            For J = K + 1 To N
                F = 0#
                For I = K To M
                    F = F + A(I, K) * A(I, J)
                Next I
                F = F / H
                For I = K To M
                    A(I, J) = A(I, J) - A(I, K) * F
                Next I
            Next J
            For J = 1 To M
                F = 0#
                For I = K To M
                    F = F + A(I, K) * Q(I, J)
                Next I
                F = F / H
                For I = K To M
                    Q(I, J) = Q(I, J) - A(I, K) * F
                Next I
            Next J
            A(K, K) = T * S
            For I = K + 1 To M
                A(I, K) = 0#
            Next I
        End If
    Next K
End Sub
Sub QRBKSB(A(), N, Q(), B(), X())
    For I = 1 To N
        Sum = 0#
        For J = 1 To N
            Sum = Sum + Q(I, J) * B(J)
        Next J
        X(I) = Sum
    Next I
    For I = N To 1 Step -1
        Sum = X(I)
        For J = I + 1 To N
            Sum = Sum - A(I, J) * X(J)
        Next J
        If A(I, I) = 0# Then Print "A is singular matrix.'"
        X(I) = Sum / A(I, I)
    Next I
End Sub