tred2.txt

用VB实现矩阵特征值的求解算法集。包括：对称矩阵的雅可比变换

Sub TRED2(A(), N, D(), E())
    If N > 1 Then
        For I = N To 2 Step -1
            L = I - 1
            H = 0#
            SCALE1 = 0#
            If L > 1 Then
                For K = 1 To L
                    SCALE1 = SCALE1 + Abs(A(I, K))
                Next K
                If SCALE1 = 0# Then
                    E(I) = A(I, L)
                Else
                    For K = 1 To L
                        A(I, K) = A(I, K) / SCALE1
                        H = H + A(I, K) ^ 2
                    Next K
                    F = A(I, L)
                    G = -Sqr(H) * Sgn(F)
                    E(I) = SCALE1 * G
                    H = H - F * G
                    A(I, L) = F - G
                    F = 0#
                    For J = 1 To L
                        A(J, I) = A(I, J) / H
                        G = 0#
                        For K = 1 To J
                            G = G + A(J, K) * A(I, K)
                        Next K
                        If L > J Then
                            For K = J + 1 To L
                                G = G + A(K, J) * A(I, K)
                            Next K
                        End If
                        E(J) = G / H
                        F = F + E(J) * A(I, J)
                    Next J
                    HH = F / (H + H)
                    For J = 1 To L
                        F = A(I, J)
                        G = E(J) - HH * F
                        E(J) = G
                        For K = 1 To J
                            A(J, K) = A(J, K) - F * E(K) - G * A(I, K)
                        Next K
                    Next J
                End If
            Else
                E(I) = A(I, L)
            End If
            D(I) = H
        Next I
    End If
    'Omit following line if finding only eigenvalues.
    D(1) = 0#
    E(1) = 0#
    For I = 1 To N
    'Delete lines from here ...
        L = I - 1
        If D(I) <> 0# Then
            For J = 1 To L
                G = 0#
                For K = 1 To L
                    G = G + A(I, K) * A(K, J)
                Next K
                For K = 1 To L
                    A(K, J) = A(K, J) - G * A(K, I)
                Next K
            Next J
        End If
     '... to here when finding only eibenvalues.
        D(I) = A(I, I)
    'Also delete lines from here ...
        A(I, I) = 1#
        If L >= 1 Then
            For J = 1 To L
                A(I, J) = 0#
                A(J, I) = 0#
            Next J
        End If
    '... to here when finding only eigenvalues.
    Next I
End Sub