d9r8.frm

矩阵特征值的求解过程之一

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6255
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4650
   LinkTopic       =   "Form1"
   ScaleHeight     =   6255
   ScaleWidth      =   4650
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   2880
      TabIndex        =   0
      Top             =   5640
      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 D9R8
    'Driver for routine FRPRMN
    NDIM = 3
    PIO2 = 1.5707963
    FTOL = 0.000001
    Dim P(3)
    Print Tab(5); "PROGRAM finds the minimum of a function"
    Print Tab(5); "with different trial starting vectors."
    Print Tab(5); "True minimum is (0.5, 0.5, 0.5)"
    For K = 0 To 4
        ANGL = PIO2 * K / 4#
        P(1) = 2# * Cos(ANGL)
        P(2) = 2# * Sin(ANGL)
        P(3) = 0#
        Print Tab(5)
        Print Tab(5); "Starting vector: ("; Format$(P(1), "#.#000");
        Print ","; Format$(P(2), "#.#000"); ","; Format$(P(3), "#.#000"); ")"
        Call FRPRMN(P(), NDIM, FTOL, ITER, FRET)
        Print Tab(5); "Iterations: "; Format$(ITER, "##")
        Print Tab(5); "Solution vector: ("; Format$(P(1), "#.#000");
        Print ","; Format$(P(2), "#.#000"); ","; Format$(P(3), "#.#000"); ")"
        Print Tab(5); "Func. value at solution", Format$(FRET, ".######E+00")
    Next K
End Sub
Function FUNC2(X(), N)
    FUNC2 = 1# - BESSJ0(X(1) - 0.5) * BESSJ0(X(2) - 0.5) * BESSJ0(X(3) - 0.5)
End Function
Sub DFUNC(X(), DF())
    DF(1) = BESSJ1(X(1) - 0.5) * BESSJ0(X(2) - 0.5) * BESSJ0(X(3) - 0.5)
    DF(2) = BESSJ0(X(1) - 0.5) * BESSJ1(X(2) - 0.5) * BESSJ0(X(3) - 0.5)
    DF(3) = BESSJ0(X(1) - 0.5) * BESSJ0(X(2) - 0.5) * BESSJ1(X(3) - 0.5)
End Sub
Function FUNC(X)
    FUNC = F1DIM(X)
End Function
Sub FRPRMN(P(), N, FTOL, ITER, FRET)
    ITMAX = 200
    EPS = 0.0000000001
    Dim G(550), H(50), XI(50)
    FP = FUNC2(P(), N)
    Call DFUNC(P(), XI())
    For J = 1 To N
        G(J) = -XI(J)
        H(J) = G(J)
        XI(J) = H(J)
    Next J
    For ITS = 1 To ITMAX
        ITER = ITS
        Call LINMIN(P(), XI(), N, FRET)
        If 2# * Abs(FRET - FP) <= FTOL * (Abs(FRET) + Abs(FP) + EPS) Then
            Exit For
        End If
        FP = FUNC2(P(), N)
        Call DFUNC(P(), XI())
        GG = 0#
        DGG = 0#
        For J = 1 To N
            GG = GG + G(J) ^ 2
            DGG = DGG + XI(J) ^ 2
            DGG = DGG + (XI(J) + G(J)) * XI(J)
        Next J
        If GG = 0# Then Exit For
        GAM = DGG / GG
        For J = 1 To N
            G(J) = -XI(J)
            H(J) = G(J) + GAM * H(J)
            XI(J) = H(J)
        Next J
    Next ITS
    If ITC > ITMAX Then Print "  FRPR maximum iterations exceeded"
    Erase XI, H, G
End Sub