d7r3.frm

常用的数值算法的VB程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6240
   ClientLeft      =   2055
   ClientTop       =   750
   ClientWidth     =   7155
   LinkTopic       =   "Form1"
   ScaleHeight     =   6240
   ScaleWidth      =   7155
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   5280
      TabIndex        =   0
      Top             =   5520
      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 D7R3
    'Driver for routine SHELL
    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 SHELL(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 SHELL(N, ARR())
    ALN2I = 1.442695: TINY = 0.00001
    LOGNB2 = Int(Log(CSng(N)) * ALN2I + TINY)
    M = N
    For NN = 1 To LOGNB2
        M = Int(M / 2)
        K = N - M
        For J = 1 To K
            I = J
            Do
              DONE% = -1
              L = I + M
              If ARR(L) < ARR(I) Then
                T = ARR(I)
                ARR(I) = ARR(L)
                ARR(L) = T
                I = I - M
                If I >= 1 Then DONE% = 0
              End If
            Loop While Not DONE%
        Next J
    Next NN
End Sub