d8r3.frm

VB常用数值算法集 内含有解线性代数方程组

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3780
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4260
   LinkTopic       =   "Form1"
   ScaleHeight     =   3780
   ScaleWidth      =   4260
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   2880
      TabIndex        =   0
      Top             =   3120
      Width           =   1095
   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 D8R3
    'Driver for routine TRED2
    NP = 3
    Dim A(3, 3), C(3, 3), D(3), E(3), F(3, 3)
    A(1, 1) = 1#: A(1, 2) = 2#: A(1, 3) = 3#
    A(2, 1) = 2#: A(2, 2) = 2#: A(2, 3) = 3#
    A(3, 1) = 3#: A(3, 2) = 3#: A(3, 3) = 3#
    For I = 1 To NP
        For J = 1 To NP
            C(I, J) = A(I, J)
        Next J
    Next I
    Call TRED2(C(), NP, D(), E())
    Print
    Print Tab(5); "Diagonal elements"
    Print Tab(5)
    For I = 1 To NP
        Print Format$(D(I), "#.000000"),
    Next I
    Print Tab(5)
    Print Tab(5); " 'Off-diagonal elements"
    Print Tab(5)
    For I = 2 To NP
        Print Format$(E(I), "#.000000"),
    Next I
    'Check transformation matrix
    For J = 1 To NP
        For K = 1 To NP
            F(J, K) = 0#
            For L = 1 To NP
                For M = 1 To NP
                    F(J, K) = F(J, K) + C(L, J) * A(L, M) * C(M, K)
                Next M
            Next L
        Next K
    Next J
    'How does it look?
    Print Tab(5)
    Print Tab(5); "Tridiagonal matrix"
    Print Tab(5)
    For I = 1 To NP
        For J = 1 To NP
            Print Format$(F(I, J), "0.000000"),
        Next J
        Print
    Next I
End Sub
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