VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   2880
      TabIndex        =   0
      Top             =   2520
      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 D13R3
    'Driver for routine MDIAN2
    NPTS = 50
    Dim DATA(50)
    IDUM& = -5
    For I = 1 To NPTS
        DATA(I) = GASDEV(IDUM&)
    Next I
    Call MDIAN2(DATA(), NPTS, XMED)
    Print
    Print Tab(5); "Gaussian distrib., zero mean, unit variance"
    Print
    Print Tab(5); "Median according to MDIAN2 is   ";
    Print Format$(XMED, "#.#####0")
    Call MDIAN1(DATA(), NPTS, XMED)
    Print Tab(5); "Median according to MDIAN1 is   ";
    Print Format$(XMED, "#.#####0")
End Sub
Sub MDIAN2(X(), N, XMED)
    BIG = 1E+30
    AFAC = 1.5
    AMP = 1.5
    A = 0.5 * (X(1) + X(N))
    EPS = Abs(X(N) - X(1))
    AP = BIG
    AM = -BIG
1   Sum = 0#
    SUMX = 0#
    NP = 0
    NM = 0
    XP = BIG
    XM = -BIG
    For J = 1 To N
        XX = X(J)
        If XX <> A Then
            If XX > A Then
                NP = NP + 1
                If XX < XP Then XP = XX
            ElseIf XX < A Then
                NM = NM + 1
                If XX > XM Then XM = XX
            End If
            DUM = 1# / (EPS + Abs(XX - A))
            Sum = Sum + DUM
            SUMX = SUMX + XX * DUM
        End If
    Next J
    If NP - NM >= 2 Then
        AM = A
        If SUMX / Sum - A < 0 Then
            BBB = 0
        Else
            BBB = SUMX / Sum - A
        End If
        AA = XP + BBB * AMP
        If AA > AP Then AA = 0.5 * (A + AP)
        EPS = AFAC * Abs(AA - A)
        A = AA
        GoTo 1
    ElseIf NM - NP >= 2 Then
        AP = A
        If SUMX / Sum - A < 0 Then
            BBB = SUMX / Sum - A
        Else
            BBB = 0
        End If
        AA = XM + BBB * AMP
        If AA < AM Then AA = 0.5 * (A + AM)
        EPS = AFAC * Abs(AA - A)
        A = AA
        GoTo 1
    Else
        If (N Mod 2) = 0 Then
            If NP = NM Then
                XMED = 0.5 * (XP + XM)
            ElseIf NP > NM Then
                XMED = 0.5 * (A + XP)
            Else
                XMED = 0.5 * (XM + A)
            End If
        Else
            If NP = NM Then
                XMED = A
            ElseIf NP > NM Then
                XMED = XP
            Else
                XMED = XM
            End If
        End If
    End If
End Sub
Sub MDIAN1(X(), N, XMED)
    Call SORT(N, X())
    N2 = N / 2
    If 2 * N2 = N Then
        XMED = 0.5 * (X(N2) + X(N2 + 1))
    Else
        XMED = X(N2 + 1)
    End If
End Sub
Function GASDEV(IDUM&)
    Static ISET, GSET
    If ISET = 0 Then
      Do
        V1 = 2# * RAN1(IDUM&) - 1#
        V2 = 2# * RAN1(IDUM&) - 1#
        R = V1 ^ 2 + V2 ^ 2
      Loop While R >= 1# Or R = 0
      FAC = Sqr(-2# * Log(R) / R)
      GSET = V1 * FAC
      GASDEV = V2 * FAC
      ISET = 1
    Else
      GASDEV = GSET
      ISET = 0
    End If
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
   Sub SORT(N, RA())
      L = N / 2 + 1
      IR = N
10    If L > 1 Then
          L = L - 1
          RRA = RA(L)
      Else
          RRA = RA(IR)
          RA(IR) = RA(1)
          IR = IR - 1
          If IR = 1 Then
              RA(1) = RRA
              Exit Sub
          End If
      End If
      I = L
      J = L + L
20    If J <= IR Then
          If J < IR Then
              If RA(J) < RA(J + 1) Then J = J + 1
          End If
          If RRA < RA(J) Then
              RA(I) = RA(J)
              I = J
              J = J + J
          Else
              J = IR + 1
          End If
          GoTo 20
      End If
      RA(I) = RRA
      GoTo 10
End Sub