d3r10.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3540
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3540
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   2880
      TabIndex        =   0
      Top             =   2880
      Width           =   1335
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim XMAX, X, Y, Z
Private Sub Command1_Click()
    'PROGRAM D3R10
    'Driver for routine QUAD3D
    PI = 3.1415926
    NVAL = 10
    Print
    Print "Integral of r^2 over a spherical volume"
    Print
    Print Tab(5); "Radius       QUAD3D       Actual"
    For I = 1 To NVAL
        XMAX = 0.1 * I
        XMIN = -XMAX
        Call QUAD3D(XMIN, XMAX, S)
        Print Tab(5); Format$(XMAX, "#.#0");
        Print Tab(18); Format$(S, "#.###0");
        Print Tab(31); Format$(4# * PI * (XMAX ^ 5) / 5#, "#.###0")
    Next I
End Sub
Function FUNC(X, Y, Z)
    FUNC = X ^ 2 + Y ^ 2 + Z ^ 2
End Function
Function Z1(X, Y)
    Z1 = -Sqr(Abs(XMAX ^ 2 - X ^ 2 - Y ^ 2))
End Function
Function Z2(X, Y)
    Z2 = Sqr(Abs(XMAX ^ 2 - X ^ 2 - Y ^ 2))
End Function
Function Y1(X)
    Y1 = -Sqr(Abs(XMAX ^ 2 - X ^ 2))
End Function
Function Y2(X)
    Y2 = Sqr(Abs(XMAX ^ 2 - X ^ 2))
End Function
Sub QGAUSX(DUM, A, B, SS)
    Dim X1(5), W(5)
    X1(1) = 0.1488743389: X1(2) = 0.4333953941: X1(3) = 0.6794095682
    X1(4) = 0.8650633666: X1(5) = 0.9739065285
    W(1) = 0.2955242247: W(2) = 0.2692667193: W(3) = 0.2190863625
    W(4) = 0.1494513491: W(5) = 0.0666713443
    XM = 0.5 * (B + A)
    XR = 0.5 * (B - A)
    SS = 0#
    For J = 1 To 5
        DX = XR * X1(J)
        SS = SS + W(J) * (H(XM + DX) + H(XM - DX))
    Next J
    SS = XR * SS
    Erase W(), X1()
End Sub
Sub QGAUSY(DUM, A, B, SS)
    Dim X1(5), W(5)
    X1(1) = 0.1488743389: X1(2) = 0.4333953941: X1(3) = 0.6794095682
    X1(4) = 0.8650633666: X1(5) = 0.9739065285
    W(1) = 0.2955242247: W(2) = 0.2692667193: W(3) = 0.2190863625
    W(4) = 0.1494513491: W(5) = 0.0666713443
    XM = 0.5 * (B + A)
    XR = 0.5 * (B - A)
    SS = 0#
    For J = 1 To 5
        DX = XR * X1(J)
        SS = SS + W(J) * (G(XM + DX) + G(XM - DX))
    Next J
    SS = XR * SS
    Erase W(), X1()
End Sub
Sub QGAUSZ(DUM, A, B, SS)
    Dim X1(5), W(5)
    X1(1) = 0.1488743389: X1(2) = 0.4333953941: X1(3) = 0.6794095682
    X1(4) = 0.8650633666: X1(5) = 0.9739065285
    W(1) = 0.2955242247: W(2) = 0.2692667193: W(3) = 0.2190863625
    W(4) = 0.1494513491: W(5) = 0.0666713443
    XM = 0.5 * (B + A)
    XR = 0.5 * (B - A)
    SS = 0#
    For J = 1 To 5
        DX = XR * X1(J)
        SS = SS + W(J) * (F(XM + DX) + F(XM - DX))
    Next J
    SS = XR * SS
    Erase W(), X1()
End Sub
Sub QUAD3D(XX1, XX2, SS)
    Call QGAUSX(DUM, XX1, XX2, SS)
End Sub
Function F(ZZ)
    Z = ZZ
    F = FUNC(X, Y, Z)
End Function
Function G(YY)
    Y = YY
    B1 = Z1(X, Y)
    B2 = Z2(X, Y)
    Call QGAUSZ(DUM, B1, B2, SS)
    G = SS
End Function
Function H(XX)
    X = XX
    A1 = Y1(X)
    A2 = Y2(X)
    Call QGAUSY(DUM, A1, A2, SS)
    H = SS
End Function