d10r12.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   3120
      TabIndex        =   0
      Top             =   2640
      Width           =   1215
   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 D10R12
    'Driver for routine QROOT
    N = 7
    EPS = 0.000001
    NTRY = 10
    TINY = 0.00001
    Dim P(7), B(10), C(10)
    P(1) = 10#
    P(2) = -18#
    P(3) = 25#
    P(4) = -24#
    P(5) = 16#
    P(6) = -6#
    P(7) = 1#
    Print
    Print Tab(5); "P(x)=x^6-6x^5+16x^4-24x^3+25x^2-18x+10"
    Print
    Print Tab(5); "Quadratic factors x^2+Bx+C"
    Print
    Print Tab(3); "Factor          B             C"
    Print
    NROOT = 0
    For I = 1 To NTRY
        C(I) = 0.5 * I
        B(I) = -0.5 * I
        Call QROOT(P(), N, B(I), C(I), EPS)
        If NROOT = 0 Then
            Print Tab(5); Format$(NROOT, "0");
            Print Tab(15); Format$(B(I), "#.#####0");
            Print Tab(29); Format$(C(I), "#.#####0")
            NROOT = 1
        Else
            NFLAG = 0
            For J = 1 To NROOT
                AAA = Abs(B(I) - B(J))
                BBB = Abs(C(I) - C(J))
                If AAA < TINY And BBB < TINY Then NFLAG = 1
            Next J
            If NFLAG = 0 Then
                Print Tab(5); Format$(NROOT, "#");
                Print Tab(15); Format$(B(I), "#.#####0");
                Print Tab(29); Format$(C(I), "#.#####0")
                NROOT = NROOT + 1
            End If
        End If
    Next I
End Sub
Sub QROOT(P(), N, B, C, EPS)
    ITMAX = 20
    TINY = 0.000001
    Dim Q(20), D(3), REM1(20), QQ(20)
    D(3) = 1#
    For ITER = 1 To ITMAX
        D(2) = B
        D(1) = C
        Call POLDIV(P(), N, D, 3, Q(), REM1())
        S = REM1(1)
        R = REM1(2)
        Call POLDIV(Q(), N - 1, D, 3, QQ(), REM1())
        SC = -REM1(1)
        RC = -REM1(2)
        For I = N - 1 To 1 Step -1
            Q(I + 1) = Q(I)
        Next I
        Q(1) = 0#
        Call POLDIV(Q(), N, D, 3, QQ(), REM1())
        SB = -REM1(1)
        RB = -REM1(2)
        DIV = 1# / (SB * RC - SC * RB)
        DELB = (R * SC - S * RC) * DIV
        DELC = (-R * SB + S * RB) * DIV
        B = B + DELB
        C = C + DELC
        DB = Abs(DELB) - EPS * Abs(B)
        DC = Abs(DELC) - EPS * Abs(C)
        If (DB <= 0# Or Abs(B) < TINY) And (DC <= 0 Or Abs(C) < TINY) Then
            Erase QQ, REM1, D, Q
            Exit Sub
        End If
    Next ITER
    Print "too many iterations in QROOT"
End Sub
Sub POLDIV(U(), N, V(), NV, Q(), R())
    For J = 1 To N
        R(J) = U(J)
        Q(J) = 0#
    Next J
    For K = N - NV To 0 Step -1
        Q(K + 1) = R(NV + K) / V(NV)
        For J = NV + K - 1 To K + 1 Step -1
            R(J) = R(J) - Q(K + 1) * V(J - K)
        Next J
    Next K
    R(NV) = 0#
End Sub