module2.bas

来自「采用VB编写的一个电路分析系统」· BAS 代码 · 共 474 行 · 第 1/2 页

Attribute VB_Name = "Module2"
Public Function LEGauss(n As Integer, dblA() As Single, dblB() As Single) As Boolean
    ' 局部变量
    Dim I As Integer, j As Integer, k As Integer
    Dim nIs As Integer
    ReDim nJs(n) As Integer
    Dim d As Single, t As Single
    
    ' 开始求解
    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
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：MatrixModule.bas
'  函数名：MRinv
'  功能：  实矩阵求逆的全选主元高斯－约当法
'  参数：  n      - Integer型变量，矩阵的阶数
'          mtxA   - Double型二维数组，体积为n x n。存放原矩阵A；返回时存放其逆矩阵A-1。
'  返回值：Boolean型，失败为False，成功为True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function MRinv(n As Integer, mtxA() As Integer) As Boolean
    ' 局部变量
    ReDim nIs(n) As Integer, nJs(n) As Integer
    Dim I As Integer, j As Integer, k As Integer
    Dim d As Double, p As Double

    ' 全选主元，消元
    For k = 1 To n
        d = 0#
        For I = k To n
            For j = k To n
                p = Abs(mtxA(I, j))
                If (p > d) Then
                    d = p
                    nIs(k) = I
                    nJs(k) = j
                End If
            Next j
        Next I
        
        ' 求解失败
        If (d + 1# = 1#) Then
            MRinv = False
            Exit Function
        End If

        If (nIs(k) <> k) Then
            For j = 1 To n
                p = mtxA(k, j)
                mtxA(k, j) = mtxA(nIs(k), j)
                mtxA(nIs(k), j) = p
            Next j
        End If

        If (nJs(k) <> k) Then
            For I = 1 To n
                p = mtxA(I, k)
                mtxA(I, k) = mtxA(I, nJs(k))
                mtxA(I, nJs(k)) = p
            Next I
        End If

        mtxA(k, k) = 1# / mtxA(k, k)
        For j = 1 To n
            If (j <> k) Then mtxA(k, j) = mtxA(k, j) * mtxA(k, k)
        Next j
        For I = 1 To n
            If (I <> k) Then
                For j = 1 To n
                    If (j <> k) Then mtxA(I, j) = mtxA(I, j) - mtxA(I, k) * mtxA(k, j)
                Next j
            End If
        Next I
        For I = 1 To n
            If (I <> k) Then mtxA(I, k) = -mtxA(I, k) * mtxA(k, k)
        Next I
    Next k

    ' 调整恢复行列次序
    For k = n To 1 Step -1
        If (nJs(k) <> k) Then
          For j = 1 To n
              p = mtxA(k, j)
              mtxA(k, j) = mtxA(nJs(k), j)
              mtxA(nJs(k), j) = p
          Next j
        End If
        If (nIs(k) <> k) Then
          For I = 1 To n
              p = mtxA(I, k)
              mtxA(I, k) = mtxA(I, nIs(k))
              mtxA(I, nIs(k)) = p
          Next I
        End If
    Next k
    
    ' 求解成功
    MRinv = True

End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：MatrixModule.bas
'  函数名：MTrans
'  功能：  计算矩阵的转置
'  参数：  m   - Integer型变量，矩阵的行数
'          n   - Integer型变量，矩阵的列数
'          mtxA  - Double型m x n二维数组，存放原矩阵
'          mtxAT  - Double型n x m二维数组，返回转置矩阵
Public Sub MTrans(m As Integer, n As Integer, mtxA() As Integer, mtxAT() As Integer)
    Dim I As Integer, j As Integer

    For I = 1 To m
        For j = 1 To n
            mtxAT(j, I) = mtxA(I, j)
        Next j
    Next I

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：MatrixModule.bas
'  函数名：MMul
'  功能：  计算矩阵的乘法
'  参数：  m   - Integer型变量，相乘的左边矩阵的行数
'          n   - Integer型变量，相乘的左边矩阵的列数和右边矩阵的行数
'          l   -  Integer型变量，相乘的右边矩阵的列数
'          mtxA  - Double型m x n二维数组，存放相乘的左边矩阵
'          mtxB  - Double型n x l二维数组，存放相乘的右边矩阵
'          mtxC  - Double型m x l二维数组，返回矩阵乘积矩阵
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Sub MMul(m As Integer, n As Integer, l As Integer, mtxA() As Integer, mtxB() As Integer, mtxC() As Integer)
    Dim I As Integer, j As Integer, k As Integer

    For I = 1 To m
        For j = 1 To l
            mtxC(I, j) = 0#
            For k = 1 To n
                mtxC(I, j) = mtxC(I, j) + mtxA(I, k) * mtxB(k, j)
            Next k
        Next j
    Next I

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  模块名：LEModule.bas
'  函数名：LECpxGauss
'  功能：  使用全选主元高斯消去法求解复系数线性代数方程组
'  参数    n     - Integer型变量，线性代数方程组的阶数