d8r6.frm

常用的数值算法的VB程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5670
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6495
   LinkTopic       =   "Form1"
   ScaleHeight     =   5670
   ScaleWidth      =   6495
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   4800
      TabIndex        =   0
      Top             =   4920
      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 D8R6
    'Driver for routine ELMHES
    NP = 5
    Dim A(5, 5), R(5), C(5)
    A(1, 1) = 1#: A(1, 2) = 2#: A(1, 3) = 300#: A(1, 4) = 4#: A(1, 5) = 5#
    A(2, 1) = 2#: A(2, 2) = 3#: A(2, 3) = 400#: A(2, 4) = 5#: A(2, 5) = 6#
    A(3, 1) = 3#: A(3, 2) = 4#: A(3, 3) = 5#:   A(3, 4) = 6#: A(3, 5) = 7#
    A(4, 1) = 4#: A(4, 2) = 5#: A(4, 3) = 600#: A(4, 4) = 7#: A(4, 5) = 8#
    A(5, 1) = 5#: A(5, 2) = 6#: A(5, 3) = 700#: A(5, 4) = 8#: A(5, 5) = 9#
    Print Tab(5)
    Print Tab(5); " ***** Original Matrix *****"
    Print Tab(5)
    For I = 1 To NP
        For J = 1 To NP
            Print Format$(A(I, J), "#.00"),
        Next J
        Print
    Next I
    Print Tab(5)
    Print Tab(5); "***** Balance Matrix *****"
    Print Tab(5)
    Call BALANC(A(), NP)
    For I = 1 To NP
        For J = 1 To NP
            Print Format$(A(I, J), "#.00"),
        Next J
        Print
    Next I
    Print Tab(5)
    Print Tab(5); " *****Reduce to Hessenherg Form *****"
    Print Tab(5)
    Call ELMHES(A(), NP)
    For J = 1 To NP - 2
        For I = J + 2 To NP
            A(I, J) = 0#
        Next I
    Next J
    For I = 1 To NP
        For J = 1 To NP
            Print Format$(A(I, J), ".0000E+00"),
        Next J
        Print
    Next I
End Sub
Sub ELMHES(A(), N)
    If N > 2 Then
        For M = 2 To N - 1
            X = 0#
            I = M
            For J = M To N
                If Abs(A(J, M - 1)) > Abs(X) Then
                    X = A(J, M - 1)
                    I = J
                End If
            Next J
            If I <> M Then
                For J = M - 1 To N
                    Y = A(I, J)
                    A(I, J) = A(M, J)
                    A(M, J) = Y
                Next J
                For J = 1 To N
                    Y = A(J, I)
                    A(J, I) = A(J, M)
                    A(J, M) = Y
                Next J
            End If
            If X <> 0# Then
                For I = M + 1 To N
                    Y = A(I, M - 1)
                    If Y <> 0# Then
                        Y = Y / X
                        A(I, M - 1) = Y
                        For J = M To N
                            A(I, J) = A(I, J) - Y * A(M, J)
                        Next J
                        For J = 1 To N
                            A(J, M) = A(J, M) + Y * A(J, I)
                        Next J
                    End If
                Next I
            End If
        Next M
    End If
End Sub
      Sub BALANC(A(), N)
      RADIX = 2#
      SQRDX = RADIX ^ 2
      RADIX = 2#
      SQRDX = 4#
1         Last = 1
          For I = 1 To N
              C = 0#
              R = 0#
              For J = 1 To N
                  If J <> I Then
                      C = C + Abs(A(J, I))
                      R = R + Abs(A(I, J))
                  End If
              Next J
              If C <> 0# And R <> 0# Then
                  G = R / RADIX
                  F = 1#
                  S = C + R
2                 If C < G Then
                      F = F * RADIX
                      C = C * SQRDX
                      GoTo 2
                  End If
                  G = R * RADIX
3                 If C > G Then
                      F = F / RADIX
                      C = C / SQRDX
                      GoTo 3
                  End If
                  If (C + R) / F < 0.95 * S Then
                      Last = 0
                      G = 1# / F
                      For J = 1 To N
                          A(I, J) = A(I, J) * G
                      Next J
                      For J = 1 To N
                          A(J, I) = A(J, I) * F
                      Next J
                  End If
              End If
          Next I
          If Last = 0 Then GoTo 1
   End Sub