d6r7.frm

常用的数值算法的VB程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5415
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6255
   LinkTopic       =   "Form1"
   ScaleHeight     =   5415
   ScaleWidth      =   6255
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   4680
      TabIndex        =   0
      Top             =   4680
      Width           =   1095
   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 D6R7
    'Driver for routine GAMDEV
    N = 20: NPTS = 10000: ISCAL = 200: LLEN = 50
    Dim DIST(21), Text$(50)
    IDUM& = -13
    Do
        For J = 1 To 21
            DIST(J) = 0#
        Next J
        Print "  Order of Gamma distribution (n=1..20); -1 to end."
        IA = 4
        Print Tab(3); IA
        If IA <= 0 Then End
    Loop While IA > 20
    For I = 1 To NPTS
        J = Int(GAMDEV(IA, IDUM&)) + 1
        If (J >= 1) And (J <= 21) Then DIST(J) = DIST(J) + 1
    Next I
    Print "  Gamma-distribution deviate, order "; IA; "of "; NPTS; " points"
    Print "   x      p(x)         graph:"
    For J = 1 To 20
        DIST(J) = DIST(J) / NPTS
        For K = 1 To 50
            Text$(K) = " "
        Next K
        KLIM = Int(ISCAL * DIST(J))
        If KLIM > LLEN Then KLIM = LLEN
        For K = 1 To KLIM
            Text$(K) = "*"
        Next K
        Print Tab(3); Format$(CSng(J), "####.#0");
        Print Tab(10); Format$(DIST(J), "#####.###0");
        Print "   ";
        For M = 1 To 50
            Print Text$(M);
        Next M
    Next J
End Sub
Function GAMDEV(IA, IDUM&)
    If IA < 1 Then Print "Abnormal exit": Exit Function
    If IA < 6 Then
        X = 1#
        For J = 1 To IA
            X = X * RAN1(IDUM&)
        Next J
        X = -Log(X)
    Else
      Do
        Do
          Do
            V1 = 2# * RAN1(IDUM&) - 1#
            V2 = 2# * RAN1(IDUM&) - 1#
          Loop While V1 ^ 2 + V2 ^ 2 > 1#
          Y = V2 / V1
          AM = IA - 1
          S = Sqr(2# * AM + 1#)
          X = S * Y + AM
        Loop While X <= 0!
        E = (1# + Y ^ 2) * Exp(AM * Log(X / AM) - S * Y)
      Loop While RAN1(IDUM&) > E
    End If
    GAMDEV = X
End Function
Static Function RAN1(IDUM&)
    Dim R(97)
    M1& = 259200: IA1& = 7141: IC1& = 54773: RM1 = 0.0000038580247
    M2& = 134456: IA2& = 8121: IC2& = 28411: RM2 = 0.0000074373773
    M3& = 243000: IA3& = 4561: IC3& = 51349
    If IDUM& < 0 Or IFF = 0 Then
        IFF = 1
        IX1& = (IC1& - IDUM&) Mod M1&
        IX1& = (IA1& * IX1& + IC1&) Mod M1&
        IX2& = IX1& Mod M2&
        IX1& = (IA1& * IX1& + IC1&) Mod M1&
        IX3& = IX1& Mod M3&
        For J = 1 To 97
            IX1& = (IA1& * IX1& + IC1&) Mod M1&
            IX2& = (IA2& * IX2& + IC2&) Mod M2&
            R(J) = (CSng(IX1&) + CSng(IX2&) * RM2) * RM1
        Next J
        IDUM& = 1
      End If
      IX1& = (IA1& * IX1& + IC1&) Mod M1&
      IX2& = (IA2& * IX2& + IC2&) Mod M2&
      IX3& = (IA3& * IX3& + IC3&) Mod M3&
      J = 1 + Int((97 * IX3&) / M3&)
      If J > 97 Or J < 1 Then Print "Abnormal exit": Exit Function
      RAN1 = R(J)
      R(J) = (CSng(IX1&) + CSng(IX2&) * RM2) * RM1
End Function