VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5460
   ClientLeft      =   2460
   ClientTop       =   1950
   ClientWidth     =   6420
   LinkTopic       =   "Form1"
   ScaleHeight     =   5460
   ScaleWidth      =   6420
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   4800
      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 D6R9
    'Driver for routine BNLDEV
    N = 20: NPTS = 10000: ISCAL = 200: LLEN = 50: NN = 100
    Dim DIST(21), Text$(50)
    IDUM& = -133
    For J = 1 To 21
        DIST(J) = 0#
    Next J
    Print "  Mean of binomial distribution (0..20); -1 to end."
    XM = 5
    Print Tab(3); XM
    If XM < 0 Then End
    PP = XM / NN
    For I = 1 To NPTS
        J = Int(BNLDEV(PP, NN, IDUM&))
        If (J >= 0) And (J <= 20) Then DIST(J + 1) = DIST(J + 1) + 1
    Next I
    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 - 1), "####.#0");
        Print Tab(10); Format$(DIST(J), "#####.###0");
        Print "   ";
        For M = 1 To 50
            Print Text$(M);
        Next M
    Next J
End Sub
Function BNLDEV(PP, N, IDUM&)
    PI = 3.141592654
    If PP <= 0.5 Then
        P = PP
    Else
        P = 1# - PP
    End If
    AM = N * P
    If N < 25 Then
        BNL = 0#
        For J = 1 To N
            If RAN1(IDUM&) < P Then BNL = BNL + 1#
        Next J
    ElseIf AM < 1# Then
        G = Exp(-AM)
        T = 1#
        For J = 0 To N
            T = T * RAN1(IDUM&)
            If T < G Then Exit For
        Next J
        If T >= G Then J = N
        BNL = J
    Else
        If N <> NOLD Then
            EN = N
            OLDG = GAMMLN(EN + 1#)
            NOLD = N
        End If
        If P <> POLD Then
            PC = 1# - P
            PLOG = Log(P)
            PCLOG = Log(PC)
            POLD = P
        End If
        SQ = Sqr(2# * AM * PC)
        Do
          Do
            Y = Tan(PI * RAN1(IDUM&))
            EM = SQ * Y + AM
          Loop While (EM < 0) Or (EM >= EN + 1#)
          EM = Int(EM)
          T = EN - EM
          T = Exp(OLDG - GAMMLN(EM + 1#) - GAMMLN(T + 1#) + EM * PLOG + T * PCLOG)
          T = 1.2 * SQ * (1# + Y ^ 2) * T
        Loop While RAN1(IDUM&) > T
        BNL = EM
    End If
    If P <> PP Then BNL = N - BNL
    BNLDEV = BNL
End Function
Function GAMMLN(XX)
    Dim COF(6)
    COF(1) = 76.18009173
    COF(2) = -86.50532033
    COF(3) = 24.01409822
    COF(4) = -1.231739516
    COF(5) = 0.00120858003
    COF(6) = -0.00000536382
    STP = 2.50662827465
    HALF = 0.5
    ONE = 1#
    FPF = 5.5
    X = XX - ONE
    TMP = X + FPF
    TMP = (X + HALF) * Log(TMP) - TMP
    SER = ONE
    For J = 1 To 6
        X = X + ONE
        SER = SER + COF(J) / X
    Next J
    GAMMLN = TMP + Log(STP * SER)
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