sort.bas

求矩阵特征值、解方程组

Attribute VB_Name = "Sort"
Option Explicit
'下面是一些排序方法
'实际应用时可改变数据类型(缺省为长整型)
'数组a(0)应为空

Sub Swap(a As Long, b As Long)
Dim t As Long
t = a
a = b
b = t
End Sub

'选择排序
'数据个数应小于32767
'time: ssort(1000):0.2474s
Sub Ssort(a() As Long, n As Long)
Dim i As Long, j As Long, t As Long
For i = 1 To n - 1
    t = i
    For j = i + 1 To n
        If a(t) > a(j) Then t = j
    Next j
    If t <> i Then Swap a(i), a(t)
Next i
End Sub

Sub dui(a() As Long, low As Long, high As Long)
Dim i As Long, j As Long, x As Long
i = low: j = i + i: x = a(i)
Do While j <= high
    If j < high Then
        If a(j) < a(j + 1) Then j = j + 1
    End If
    If x < a(j) Then
        a(i) = a(j): i = j: j = i + i
    Else
        Exit Do
    End If
Loop
a(i) = x
End Sub

'堆排序
'time: dsort(10000):0.2285s
Sub Dsort(a() As Long, n As Long)
Dim i As Long, j As Long
For i = n \ 2 To 1 Step -1
    dui a(), i, n
Next i
For i = n To 2 Step -1
    Swap a(1), a(i)
    dui a(), 1, i - 1
Next i
End Sub

'Shell排序
'ShellSort2快
'time: ShellSort(10000):0.266s
Sub ShellSort1(a() As Long, n As Long)
Dim e As Long, m As Long
Dim i As Long, j As Long
Dim ic As Long
If n = 1 Then Exit Sub
ic = 2
Do While ic < n
ic = ic + ic - 1
Loop
Do
    ic = (ic + 1) \ 2
    For i = 1 + ic To n
        e = a(i)
        m = i
        For j = i - ic To 1 Step -ic
            If e < a(j) Then
                a(m) = a(j): m = j
            Else
                Exit For
            End If
        Next j
        a(m) = e
    Next i
Loop Until ic = 1
End Sub

Sub ShellSort2(a() As Long, n As Long)
Dim e As Long, m As Long
Dim i As Long, j As Long
Dim ic As Long
If n = 1 Then Exit Sub
ic = 4
Do While ic < n
ic = ic + ic + ic + 1
Loop
Do
    ic = (ic - 1) / 3
    For i = 1 + ic To n
        e = a(i)
        m = i
        For j = i - ic To 1 Step -ic
            If e < a(j) Then
                a(m) = a(j): m = j
            Else
                Exit For
            End If
        Next j
        a(m) = e
    Next i
Loop Until ic = 1
End Sub

Sub quick1(a() As Long, i As Long, j As Long)
Dim l As Long, r As Long, x As Long
l = i: r = j: x = a((i + j) \ 2)
Do
    Do While a(l) < x
        l = l + 1
    Loop
    Do While a(r) > x
        r = r - 1
    Loop
    If l <= r Then
        Swap a(r), a(l)
        r = r - 1: l = l + 1
    End If
Loop Until l >= r
If r > i Then quick1 a(), i, r
If l < j Then quick1 a(), l, j
End Sub

Sub quick2(a() As Long, i As Long, j As Long)
Dim m As Long, r As Long, l As Long, x As Long
m = (i + j) \ 2: l = i: r = j: x = a(m): a(m) = a(j)
Do
    For l = l To r - 1
        If a(l) > x Then Exit For
    Next l
    If l < r Then
        a(r) = a(l): r = r - 1
    End If
    For r = r To l + 1 Step -1
        If a(r) < x Then Exit For
    Next r
    If l < r Then
       a(l) = a(r): l = l + 1
    End If
Loop Until l = r
a(l) = x
If i < l - 1 Then quick2 a(), i, l - 1
If j > l + 1 Then quick2 a(), l + 1, j
End Sub

'快速排序
'time: quick1(10000):0.1332s;quick2(10000):0.1394s
'建议使用quick2
Sub QSort(a() As Long, n As Long)
quick2 a(), 1, n
End Sub

'有问题
'非递归算法
Sub QSort2(a() As Long, n As Long)
Dim l As Long, u As Long, p As Long, i As Long, j As Long
Dim r() As Long, t() As Long
Dim k As Long
k = Int(Log(n))
k = k + k
ReDim r(k), t(k)
l = 1: u = n: p = 0: i = l: j = u
Do
    Do
        If a(i) > a(j) Then Swap a(i), a(j): i = i + 1 Else j = j - 1
    Loop While i < j
    If i + 1 < u Then p = p + 1: r(p) = i + 1: t(p) = u
    u = i - 1
    If l >= u Then
        If p = 0 Then Exit Do
        l = r(p): u = t(p): p = p - 1
    End If
    i = l: j = u
Loop While True
End Sub

'两分查找
'未找到时返回0
Function Lfind(a() As Long, x As Long, n As Long) As Long
Dim l As Long, h As Long, m As Long
h = n
Do While l <= h
    m = (l + h) \ 2
    If x > a(m) Then
        l = m + 1
    ElseIf x < a(m) Then
        h = m - 1
    Else
        Lfind = m: Exit Function
    End If
Loop
Lfind = 0
End Function