d10r13.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   8490
   ClientLeft      =   1665
   ClientTop       =   345
   ClientWidth     =   5475
   LinkTopic       =   "Form1"
   ScaleHeight     =   8490
   ScaleWidth      =   5475
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   4080
      TabIndex        =   0
      Top             =   120
      Width           =   1335
   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 D10R13
    'Driver for routine MNEWT
    NTRIAL = 5
    TOLX = 0.000001
    N = 4
    TOLF = 0.000001
    NP = 15
    Dim X(15), ALPHA(15, 15), BETA(15)
    For KK = -1 To 1 Step 2
        For K = 1 To 3
            XX = 0.2 * K * KK
            Print Tab(5); "Starting vector number"; Format$(K, "#")
            For I = 1 To 4
                X(I) = XX + 0.2 * I
                Print Tab(5); "   X("; Format$(I, "#"); ")= ";
                Print Format$(X(I), "0.#0")
            Next I
            For J = 1 To NTRIAL
                Call MNEWT(1, X(), N, TOLX, TOLF)
                Call USRFUN(X(), ALPHA(), BETA())
                Print Tab(5); "I              X(I)           F"
                For I = 1 To N
                    Print Tab(5); Format$(I, "#");
                    Print Tab(15); Format$(X(I), ".####00E+00");
                    Print Tab(29); Format$(-BETA(I), ".#####0E+00")
                Next I
            Next J
        Next K
    Next KK
End Sub
Sub USRFUN(X(), ALPHA(), BETA())
    NP = 15
    ALPHA(1, 1) = -2# * X(1)
    ALPHA(1, 2) = -2# * X(2)
    ALPHA(1, 3) = -2# * X(3)
    ALPHA(1, 4) = 1#
    ALPHA(2, 1) = 2# * X(1)
    ALPHA(2, 2) = 2# * X(2)
    ALPHA(2, 3) = 2# * X(3)
    ALPHA(2, 4) = 2# * X(4)
    ALPHA(3, 1) = 1#
    ALPHA(3, 2) = -1#
    ALPHA(3, 3) = 0#
    ALPHA(3, 4) = 0#
    ALPHA(4, 1) = 0#
    ALPHA(4, 2) = 1#
    ALPHA(4, 3) = -1#
    ALPHA(4, 4) = 0#
    BETA(1) = X(1) ^ 2 + X(2) ^ 2 + X(3) ^ 2 - X(4)
    BETA(2) = -X(1) ^ 2 - X(2) ^ 2 - X(3) ^ 2 - X(4) ^ 2 + 1#
    BETA(3) = -X(1) + X(2)
    BETA(4) = -X(2) + X(3)
End Sub
Sub MNEWT(NTRIAL, X(), N, TOLX, TOLF)
    Dim ALPHA(15, 15), BETA(15), INDX(15)
    For K = 1 To NTRIAL
        Call USRFUN(X(), ALPHA(), BETA())
        ERRF = 0#
        For I = 1 To N
            ERRF = ERRF + Abs(BETA(I))
        Next I
        If ERRF <= TOLF Then Exit Sub
        Call LUDCMP(ALPHA(), N, INDX(), D)
        Call LUBKSB(ALPHA(), N, INDX(), BETA())
        ERRX = 0#
        For I = 1 To N
            ERRX = ERRX + Abs(BETA(I))
            X(I) = X(I) + BETA(I)
        Next I
        If ERRX <= TOLX Then Exit Sub
    Next K
End Sub
   Sub LUDCMP(A(), N, INDX(), D)
      NMAX = 100
      TINY = 1E-20
      Dim VV(100)
      D = 1#
      For I = 1 To N
          AAMAX = 0#
          For J = 1 To N
              If Abs(A(I, J)) > AAMAX Then AAMAX = Abs(A(I, J))
          Next J
          If AAMAX = 0# Then Print "Singular matrix."
          VV(I) = 1# / AAMAX
      Next I
      For J = 1 To N
          If J > 1 Then
              For I = 1 To J - 1
                  Sum = A(I, J)
                  If I > 1 Then
                      For K = 1 To I - 1
                          Sum = Sum - A(I, K) * A(K, J)
                      Next K
                      A(I, J) = Sum
                  End If
              Next I
          End If
          AAMAX = 0#
          For I = J To N
              Sum = A(I, J)
              If J > 1 Then
                  For K = 1 To J - 1
                      Sum = Sum - A(I, K) * A(K, J)
                  Next K
                  A(I, J) = Sum
              End If
              DUM = VV(I) * Abs(Sum)
              If DUM >= AAMAX Then
                  IMAX = I
                  AAMAX = DUM
              End If
          Next I
          If J <> IMAX Then
              For K = 1 To N
                  DUM = A(IMAX, K)
                  A(IMAX, K) = A(J, K)
                  A(J, K) = DUM
              Next K
              D = -D
              VV(IMAX) = VV(J)
          End If
          INDX(J) = IMAX
          If J <> N Then
              If A(J, J) = 0# Then A(J, J) = TINY
              DUM = 1# / A(J, J)
              For I = J + 1 To N
                  A(I, J) = A(I, J) * DUM
              Next I
          End If
      Next J
      If A(N, N) = 0# Then A(N, N) = TINY
   End Sub
   Sub LUBKSB(A(), N, INDX, B())
      II = 0
      For I = 1 To N
          LL = INDX(I)
          Sum = B(LL)
          B(LL) = B(I)
          If II <> 0 Then
              For J = II To I - 1
                  Sum = Sum - A(I, J) * B(J)
              Next J
          ElseIf Sum <> 0# Then
              II = I
          End If
          B(I) = Sum
      Next I
      For I = N To 1 Step -1
          Sum = B(I)
          If I < N Then
              For J = I + 1 To N
                  Sum = Sum - A(I, J) * B(J)
              Next J
          End If
          B(I) = Sum / A(I, I)
      Next I
   End Sub