d6r10.frm

常用的数值算法的VB程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4875
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5025
   LinkTopic       =   "Form1"
   ScaleHeight     =   4875
   ScaleWidth      =   5025
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   3240
      TabIndex        =   0
      Top             =   4320
      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 D6R10
    'Driver for routine IRBIT1
    'Calculate distribution of runs of zeros
    NBIN = 15: NTRIES = 10000
    Dim DELAY(15)
    ISEED = 12345
    For I = 1 To NBIN
        DELAY(I) = 0#
    Next I
    IPTS = 0
    For I = 1 To NTRIES
        If IRBIT1(ISEED) = 1 Then
            IPTS = IPTS + 1
            IFLG = 0
            For J = 1 To NBIN
                If (IRBIT1(ISEED) = 1) And (IFLG = 0) Then
                    IFLG = 1
                    DELAY(J) = DELAY(J) + 1#
                End If
            Next J
        End If
    Next I
    Print "Distribution of runs of N zeros"
    Print "    N     Probability   Expected"
    For N = 1 To NBIN
        Print Tab(5); Format$(N - 1, "####0");
        Print Tab(12); Format$(DELAY(N) / IPTS, "#.#####0");
        Print Tab(25); Format$(1# / (2# ^ N), "#.#####0")
    Next N
End Sub
Static Function IRBIT1(ISEED)
    IB1 = 1: IB3 = 4: IB5 = 16: IB14 = 8192
    NEWBIT% = (ISEED And IB14) <> 0
    If (ISEED And IB5) <> 0 Then NEWBIT% = Not NEWBIT%
    If (ISEED And IB3) <> 0 Then NEWBIT% = Not NEWBIT%
    If (ISEED And IB1) <> 0 Then NEWBIT% = Not NEWBIT%
    If ISEED > 2 ^ 14 Then ISEED = ISEED - 2 ^ 14
    ISEED = 2 * ISEED
    If NEWBIT% Then
        IRBIT1 = 1
        ISEED = ISEED Or IB1
    Else
        IRBIT1 = 0
        ISEED = ISEED And (Not IB1)
    End If
End Function