d10r1.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5400
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6840
   LinkTopic       =   "Form1"
   ScaleHeight     =   5400
   ScaleWidth      =   6840
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   5160
      TabIndex        =   0
      Top             =   4680
      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 D10R1
    'Driver for routine SCRSHO
    Print Tab(5); "Graph of the Bessel Function J0:"
    Print Tab(5)
    Call SCRSHO(DUM)
End Sub
Function FUNC(X)
    FUNC = BESSJ0(X)
End Function
Sub SCRSHO(DUM)
    ISCR% = 60
    JSCR% = 21
    Dim Y(60), SCR$(60, 21)
    BLANK$ = " "
    ZERO$ = "-"
    YY$ = "1"
    XX$ = "-"
    FF$ = "x"
    'Enter X1,X2 (X1=X2 to stop)
    X1 = -5#
    X2 = 5#
    If X1 = X2 Then Exit Sub
    For J = 1 To JSCR%
        SCR$(1, J) = YY$
        SCR$(ISCR%, J) = YY$
    Next J
    For I = 2 To ISCR% - 1
        SCR$(I, 1) = XX$
        SCR$(I, JSCR%) = XX$
        For J = 2 To JSCR% - 1
            SCR$(I, J) = BLANK$
        Next J
    Next I
    DX = (X2 - X1) / (ISCR% - 1)
    X = X1
    YBIG = 0#
    YSML = YBIG
    For I = 1 To ISCR%
        Y(I) = FUNC(X)
        If Y(I) < YSML Then YSML = Y(I)
        If Y(I) > YBIG Then YBIG = Y(I)
        X = X + DX
    Next I
    If YBIG = YSML Then YBIG = YSML + 1#
    DYJ = (JSCR% - 1) / (YBIG - YSML)
    JZ = 1 - YSML * DYJ
    For I = 1 To ISCR%
        SCR$(I, JZ) = ZERO$
        J = 1 + (Y(I) - YSML) * DYJ
        SCR$(I, J) = FF$
    Next I
    Print Format$(YBIG, "##.#######");
    Print " ";
    For I = 1 To ISCR%
        Print SCR$(I, JSCR%);
    Next I
    Print
    For J = JSCR% - 1 To 2 Step -1
        Print "         ";
        For I = 1 To ISCR%
            Print SCR$(I, J);
        Next I
        Print
    Next J
    Print Format$(YSML, "##.######");
    Print " ";
    For I = 1 To ISCR%
        Print SCR$(I, 1);
    Next I
    Print
    Print "         ";
    Print Format$(X1, "##.#######");
    Print Tab(70);
    Print Format$(X2, "##.#######")
End Sub
Function BESSJ0(X)
    P1# = 1#
    P2# = -0.001098628627
    P3# = 0.00002734510407
    P4# = -0.000002073370639
    P5# = 2.093887211E-07
    Q1# = -0.01562499995
    Q2# = 0.0001430488765
    Q3# = -0.000006911147651
    Q4# = 7.621095161E-07
    Q5# = -9.34945152E-08
    R1# = 57568490574#
    R2# = -13362590354#
    R3# = 651619640.7
    R4# = -11214424.18
    R5# = 77392.33017
    R6# = -184.9052456
    S1# = 57568490411#
    S2# = 1029532985#
    S3# = 9494680.718
    S4# = 59272.64853
    S5# = 267.8532712
    S6# = 1#
    If Abs(X) < 8# Then
       Y# = X * X
       BBB# = Y# * (R4# + Y# * (R5# + Y# * R6#))
       AAA# = R1# + Y# * (R2# + Y# * (R3# + BBB#))
       CCC# = Y# * (S3# + Y# * (S4# + Y# * (S5# + Y# * S6#)))
       BESSJ0 = AAA / (S1# + Y# * (S2# + CCC#))
    Else
       AX# = Abs(X)
       Z# = 8# / AX#
       Y# = Z# * Z#
       XX = AX# - 0.785398164
       CCC# = Y# * (P3# + Y# * (P4# + Y# * P5#))
       AAA# = P1# + Y# * (P2# + CCC#)
       DDD# = Y# * (Q3# + Y# * (Q4# + Y# * Q5#))
       EEE# = Z# * Sin(XX) * (Q1# + Y# * (Q2# + DDD#))
       BESSJ0 = Sqr(0.636619772 / AX#) * (Cos(XX) * AAA# - EEE#)
    End If
End Function