d7r9.frm

常用的数值算法的VB程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5880
   ClientLeft      =   2055
   ClientTop       =   750
   ClientWidth     =   6615
   LinkTopic       =   "Form1"
   ScaleHeight     =   5880
   ScaleWidth      =   6615
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   4680
      TabIndex        =   0
      Top             =   5280
      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 D7R9
    'Driver for routine QCKSRT
    Dim A(100)
    Open "D:\VB常用数值算法集\DATA\TARRAY.DAT" For Input As #2
    For I = 1 To 10
        Line Input #2, DUM$
        For J = 1 To 10
            A(10 * (I - 1) + J) = Val(Mid(DUM$, 6 * J - 5, 6))
        Next J
    Next I
    Close (2)
    'Print Original array
    Print "Original array:"
    For I = 1 To 10
        For J = 1 To 10
            Print Tab(7 * (J - 1) + 2); Format$(A(10 * (I - 1) + J), "###.#0");
        Next J
        Print
    Next I
    'Sort array
    Call QCKSRT(100, A())
    'Print sorted array
    Print "Sorted array:"
    For I = 1 To 10
        For J = 1 To 10
            Print Tab(7 * (J - 1) + 2); Format$(A(10 * (I - 1) + J), "###.#0"); "  ";
        Next J
        Print
    Next I
End Sub
Sub QCKSRT(N, ARR())
    M = 7: NSTACK = 50: FM = 7875: FA = 211: FC = 1663: FMI = 0.00012698413
    Dim ISTACK(50)
    JSTACK = 0
    L = 1
    IR = N
    FX = 0
    Do
      If IR - L < M Then
          For J = L + 1 To IR
              A = ARR(J)
              For I = J - 1 To 1 Step -1
                  If ARR(I) <= A Then Exit For
                  ARR(I + 1) = ARR(I)
              Next I
              If ARR(I) = 0 Then I = 0
              ARR(I + 1) = A
          Next J
          If JSTACK = 0 Then Exit Sub
          IR = ISTACK(JSTACK)
          L = ISTACK(JSTACK - 1)
          JSTACK = JSTACK - 2
      Else
          I = L
          J = IR
          FX = FX * FA + FC - FM * Int((FX * FA + FC) / FM)
          IQ = L + (IR - L + 1) * (FX * FMI)
          A = ARR(IQ)
          ARR(IQ) = ARR(L)
          Do
            Do
              If J > 0 Then
                If A < ARR(J) Then
                    J = J - 1
                    DONE% = 0
                Else
                    DONE% = -1
                End If
              End If
            Loop While Not DONE%
            If J <= I Then
                ARR(I) = A
                Exit Do
            End If
            ARR(I) = ARR(J)
            I = I + 1
            Do
              If I <= N Then
                If A > ARR(I) Then
                  I = I + 1
                  DONE% = 0
                Else
                  DONE% = -1
                End If
              End If
            Loop While Not DONE%
            If J <= I Then
              ARR(J) = A
              I = J
              Exit Do
            End If
            ARR(J) = ARR(I)
            J = J - 1
          Loop
          JSTACK = JSTACK + 2
          If JSTACK > NSTACK Then Print "NSTACK must be made larger.": Exit Sub
          If IR - I >= I - L Then
              ISTACK(JSTACK) = IR
              ISTACK(JSTACK - 1) = I + 1
              IR = I - 1
          Else
              ISTACK(JSTACK) = I - 1
              ISTACK(JSTACK - 1) = L
              L = I + 1
          End If
      End If
    Loop
End Sub