lemodule.bas

科学与工程数值计算算法（Visual Basic版） 附赠的光盘包含了本书中全部的源代码

Attribute VB_Name = "LEModule"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：LEModule.bas
'  功能：  求解线性方程组
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：LEModule.bas
'  函数名：LEGauss
'  功能：  使用全选主元高斯消去法求解线性方程组
'  参数    n     - Integer型变量，线性方程组的阶数
'         dblA   - Double型 n x n 二维数组，线性方程组的系数矩阵
'         dblB   - Double型长度为 n 的一维数组，线性方程组的常数向量，返回方程组的解向量
'  返回值：Boolean型，求解成功为True，无解或求解失败为False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LEGauss(n As Integer, dblA() As Double, dblB() As Double) As Boolean
    ' 局部变量
    Dim i As Integer, j As Integer, k As Integer
    Dim nIs As Integer
    ReDim nJs(n) As Integer
    Dim d As Double, t As Double
    
    ' 开始求解
    For k = 1 To n - 1
        d = 0#
        
        ' 归一
        For i = k To n
            For j = k To n
                t = Abs(dblA(i, j))
                If t > d Then
                    d = t
                    nJs(k) = j
                    nIs = i
                End If
            Next j
        Next i
        
        ' 无解，返回
        If d + 1# = 1# Then
            LEGauss = False
            Exit Function
        End If
        
        ' 消元
        If nJs(k) <> k Then
            For i = 1 To n
                t = dblA(i, k)
                dblA(i, k) = dblA(i, nJs(k))
                dblA(i, nJs(k)) = t
            Next i
        End If
        
        If nIs <> k Then
            For j = k To n
                t = dblA(k, j)
                dblA(k, j) = dblA(nIs, j)
                dblA(nIs, j) = t
            Next j
            t = dblB(k)
            dblB(k) = dblB(nIs)
            dblB(nIs) = t
        End If
        
        d = dblA(k, k)
        For j = k + 1 To n
            dblA(k, j) = dblA(k, j) / d
        Next j
        
        dblB(k) = dblB(k) / d
        For i = k + 1 To n
            For j = k + 1 To n
                dblA(i, j) = dblA(i, j) - dblA(i, k) * dblA(k, j)
            Next j
            dblB(i) = dblB(i) - dblA(i, k) * dblB(k)
        Next i
    Next k
    
    d = dblA(n, n)
    
    ' 无解，返回
    If Abs(d) + 1# = 1# Then
        LEGauss = False
        Exit Function
    End If
    
    ' 回代
    dblB(n) = dblB(n) / d
    For i = n - 1 To 1 Step -1
        t = 0#
        For j = i + 1 To n
          t = t + dblA(i, j) * dblB(j)
        Next j
        dblB(i) = dblB(i) - t
    Next i
    
    ' 调整解的次序
    nJs(n) = n
    For k = n To 1 Step -1
        If nJs(k) <> k Then
            t = dblB(k)
            dblB(k) = dblB(nJs(k))
            dblB(nJs(k)) = t
        End If
    Next k
    
    ' 求解成功
    LEGauss = True
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：LEModule.bas
'  函数名：LEGaussJordan
'  功能：  使用全选主元高斯－约当消去法求解线性方程组
'  参数    n     - Integer型变量，线性方程组的阶数
'          m    - Integer型变量，线性方程组的个数，即右端常数矩阵列向量的个数
'         dblA   - Double型 n x n 二维数组，线性方程组的系数矩阵
'         dblB   - Double型n x m二维数组，线性方程组的常数矩阵，返回方程组的解矩阵
'  返回值：Boolean型，求解成功为True，无解或求解失败为False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LEGaussJordan(n As Integer, m As Integer, dblA() As Double, dblB() As Double) As Boolean
    ' 局部变量
    Dim i As Integer, j As Integer, k As Integer
    Dim nIs As Integer
    ReDim nJs(n) As Integer
    Dim d As Double, q As Double
    
    ' 开始求解
    For k = 1 To n
        q = 0#
        
        ' 归一
        For i = k To n
            For j = k To n
                If Abs(dblA(i, j)) > q Then
                    q = Abs(dblA(i, j))
                    nJs(k) = j
                    nIs = i
                End If
            Next j
        Next i
        
        ' 无解，返回
        If q + 1# = 1# Then
            LEGaussJordan = False
            Exit Function
        End If
        
        ' 消元
        ' A->
        For j = k To n
            d = dblA(k, j)
            dblA(k, j) = dblA(nIs, j)
            dblA(nIs, j) = d
        Next j
        ' B->
        For j = 1 To m
            d = dblB(k, j)
            dblB(k, j) = dblB(nIs, j)
            dblB(nIs, j) = d
        Next j
        'A->
        For i = 1 To n
            d = dblA(i, k)
            dblA(i, k) = dblA(i, nJs(k))
            dblA(i, nJs(k)) = d
        Next i
        
        For j = k + 1 To n
            dblA(k, j) = dblA(k, j) / dblA(k, k)
        Next j
        For j = 1 To m
            dblB(k, j) = dblB(k, j) / dblA(k, k)
        Next j
        
        ' 回代
        For j = k + 1 To n
          For i = 1 To n
            If i <> k Then
              dblA(i, j) = dblA(i, j) - dblA(i, k) * dblA(k, j)
            End If
          Next i
        Next j
      
        For j = 1 To m
          For i = 1 To n
            If i <> k Then
              dblB(i, j) = dblB(i, j) - dblA(i, k) * dblB(k, j)
            End If
          Next i
        Next j
    Next k
        
    ' 调整解的次序
    For k = n To 1 Step -1
        For j = 1 To m
            d = dblB(k, j)
            dblB(k, j) = dblB(nJs(k), j)
            dblB(nJs(k), j) = d
        Next j
    Next k
    
    ' 求解成功
    LEGaussJordan = True
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：LEModule.bas
'  函数名：LECpxGauss
'  功能：  使用全选主元高斯消去法求解复系数线性代数方程组
'  参数    n     - Integer型变量，线性代数方程组的阶数
'         dblAR  - Double型 n x n 二维数组，线性代数方程组的系数矩阵的实部
'         dblAI   - Double型 n x n 二维数组，线性代数方程组的系数矩阵的虚部
'         dblBR  - Double型长度为 n 的一维数组，线性代数方程组的常数向量的实部，返回方程组的解向量的实部
'         dblBI   - Double型长度为 n 的一维数组，线性代数方程组的常数向量的虚部，返回方程组的解向量的虚部
'  返回值：Boolean型，求解成功为True，无解或求解失败为False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LECpxGauss(n As Integer, dblAR() As Double, dblAI() As Double, dblBR() As Double, dblBI() As Double) As Boolean
    ' 局部变量
    Dim i As Integer, j As Integer, k As Integer
    Dim nIs As Integer
    ReDim nJs(n) As Integer
    Dim d As Double, p As Double, q As Double, s As Double
    
    ' 开始求解
    For k = 1 To n - 1
        d = 0#
        
        ' 归一
        For i = k To n
            For j = k To n
                p = dblAR(i, j) * dblAR(i, j) + dblAI(i, j) * dblAI(i, j)
                If p > d Then
                    d = p
                    nJs(k) = j
                    nIs = i
                End If
            Next j
        Next i
        
        ' 无解，返回
        If d + 1# = 1# Then
            LECpxGauss = False
            Exit Function
        End If
        
        ' 消元
        For j = k To n
            p = dblAR(k, j)
            dblAR(k, j) = dblAR(nIs, j)
            dblAR(nIs, j) = p
            p = dblAI(k, j)
            dblAI(k, j) = dblAI(nIs, j)
            dblAI(nIs, j) = p
        Next j
        
        p = dblBR(k)
        dblBR(k) = dblBR(nIs)
        dblBR(nIs) = p
        p = dblBI(k)
        dblBI(k) = dblBI(nIs)
        dblBI(nIs) = p
        
        For i = 1 To n
            p = dblAR(i, k)
            dblAR(i, k) = dblAR(i, nJs(k))
            dblAR(i, nJs(k)) = p
            p = dblAI(i, k)
            dblAI(i, k) = dblAI(i, nJs(k))
            dblAI(i, nJs(k)) = p
        Next i
        
        ' 复数运算
        For j = k + 1 To n
            p = dblAR(k, j) * dblAR(k, k)
            q = -dblAI(k, j) * dblAI(k, k)
            s = (dblAR(k, k) - dblAI(k, k)) * (dblAR(k, j) + dblAI(k, j))
            dblAR(k, j) = (p - q) / d
            dblAI(k, j) = (s - p - q) / d
        Next j
        
        p = dblBR(k) * dblAR(k, k)
        q = -dblBI(k) * dblAI(k, k)
        s = (dblAR(k, k) - dblAI(k, k)) * (dblBR(k) + dblBI(k))
        dblBR(k) = (p - q) / d
        dblBI(k) = (s - p - q) / d
        
        For i = k + 1 To n
            For j = k + 1 To n
                p = dblAR(i, k) * dblAR(k, j)
                q = dblAI(i, k) * dblAI(k, j)
                s = (dblAR(i, k) + dblAI(i, k)) * (dblAR(k, j) + dblAI(k, j))
                dblAR(i, j) = dblAR(i, j) - p + q
                dblAI(i, j) = dblAI(i, j) - s + p + q
            Next j
            p = dblAR(i, k) * dblBR(k)
            q = dblAI(i, k) * dblBI(k)
            s = (dblAR(i, k) + dblAI(i, k)) * (dblBR(k) + dblBI(k))
            dblBR(i) = dblBR(i) - p + q
            dblBI(i) = dblBI(i) - s + p + q
        Next i
    Next k
        
    d = dblAR(n, n) * dblAR(n, n) + dblAI(n, n) * dblAI(n, n)

    ' 无解，返回
    If d + 1# = 1# Then
        LECpxGauss = False
        Exit Function
    End If
    
    p = dblAR(n, n) * dblBR(n)
    q = -dblAI(n, n) * dblBI(n)
    s = (dblAR(n, n) - dblAI(n, n)) * (dblBR(n) + dblBI(n))
    dblBR(n) = (p - q) / d
    dblBI(n) = (s - p - q) / d
        
    ' 回代
    For i = n - 1 To 1 Step -1
        For j = i + 1 To n
            p = dblAR(i, j) * dblBR(j)
            q = dblAI(i, j) * dblBI(j)
            s = (dblAR(i, j) + dblAI(i, j)) * (dblBR(j) + dblBI(j))
            dblBR(i) = dblBR(i) - p + q
            dblBI(i) = dblBI(i) - s + p + q
        Next j
    Next i
    
    ' 调整解的次序
    nJs(n) = n
    For k = n To 1 Step -1
        p = dblBR(k)
        dblBR(k) = dblBR(nJs(k))
        dblBR(nJs(k)) = p
        
        p = dblBI(k)
        dblBI(k) = dblBI(nJs(k))
        dblBI(nJs(k)) = p
    Next k
    
    ' 求解成功
    LECpxGauss = True
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：LEModule.bas
'  函数名：LECpxGaussJordan
'  功能：  使用全选主元高斯－约当消去法求解复系数线性代数方程组
'  参数    n    - Integer型变量，线性代数方程组的阶数
'          m    - Integer型变量，方程组右端复常数向量的个数
'         dblAR - Double型 n x n 二维数组，线性代数方程组的系数矩阵的实部
'         dblAI - Double型 n x n 二维数组，线性代数方程组的系数矩阵的虚部
'         dblBR - Double型长度为 n X m 的二维数组，存放方程组右端的m组常数向量的实部，
'                 返回时存放m组解向量的实部
'         dblBI - Double型长度为 n x m 的二维数组，存放方程组右端的m组常数向量的虚部，
'                 返回时存放m组解向量的虚部
'  返回值：Boolean型，求解成功为True，无解或求解失败为False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LECpxGaussJordan(n As Integer, m As Integer, dblAR() As Double, dblAI() As Double, dblBR() As Double, dblBI() As Double) As Boolean
    ' 局部变量
    Dim i As Integer, j As Integer, k As Integer
    Dim nIs As Integer
    ReDim nJs(n) As Integer
    Dim d As Double, p As Double, q As Double, s As Double
    
    ' 开始求解
    For k = 1 To n
        d = 0#
        
        ' 归一
        For i = k To n
            For j = k To n
                p = dblAR(i, j) * dblAR(i, j) + dblAI(i, j) * dblAI(i, j)
                If p > d Then
                    d = p
                    nJs(k) = j
                    nIs = i
                End If
            Next j
        Next i
        
        ' 无解，返回
        If d + 1# = 1# Then
            LECpxGaussJordan = False
            Exit Function
        End If
        
        ' 消元
        If nIs <> k Then
            ' A->
            For j = k To n
                p = dblAR(k, j)
                dblAR(k, j) = dblAR(nIs, j)
                dblAR(nIs, j) = p
                p = dblAI(k, j)
                dblAI(k, j) = dblAI(nIs, j)
                dblAI(nIs, j) = p
            Next j
            ' B ->
            For j = 1 To m
                p = dblBR(k, j)
                dblBR(k, j) = dblBR(nIs, j)
                dblBR(nIs, j) = p
                p = dblBI(k, j)
                dblBI(k, j) = dblBI(nIs, j)
                dblBI(nIs, j) = p
            Next j
        End If
        If nJs(k) <> k Then
            ' A->
            For i = 1 To n
                p = dblAR(i, k)
                dblAR(i, k) = dblAR(i, nJs(k))
                dblAR(i, nJs(k)) = p
                p = dblAI(i, k)
                dblAI(i, k) = dblAI(i, nJs(k))
                dblAI(i, nJs(k)) = p
            Next i
        End If
        
        ' 复数运算
        For j = k + 1 To n
            p = dblAR(k, j) * dblAR(k, k)