module2.bas

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

'         dblAR  - single型 n x n 二维数组，线性代数方程组的系数矩阵的实部
'         dblAI   - single型 n x n 二维数组，线性代数方程组的系数矩阵的虚部
'         dblBR  - single型长度为 n 的一维数组，线性代数方程组的常数向量的实部，返回方程组的解向量的实部
'         dblBI   - single型长度为 n 的一维数组，线性代数方程组的常数向量的虚部，返回方程组的解向量的虚部
'  返回值：Boolean型，求解成功为True，无解或求解失败为False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LECpxGauss(n As Integer, dblAR() As Single, dblAI() As Single, dblBR() As Single, dblBI() 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, p As Single, q As Single, s As Single
    
    ' 开始求解
    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

Public Function CGetA(R, I As Single) As Double

CGetA = Sqr(R * R + I * I)

End Function

Public Function CGetalpha(R, I As Single) As Single
If R = 0 And I > 0 Then
  CGetalpha = 90
ElseIf R = 0 And I < 0 Then
  CGetalpha = 270
ElseIf R > 0 And I = 0 Then
  CGetalpha = 0
ElseIf R < 0 And I = 0 Then
  CGetalpha = 180
ElseIf R > 0 Then
  CGetalpha = Atn(I / R) * 180 / pi
ElseIf R < 0 Then
  CGetalpha = 180 - Atn(I / R) * 180 / pi
End If
End Function
Public Function MRinv2(n As Integer, mtxA() As Single) As Boolean
    ' 局部变量
    ReDim nIs(n) As Integer, nJs(n) As Integer
    Dim I As Integer, j As Integer, k As Integer
    Dim d As Single, p As Single

    ' 全选主元，消元
    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
            MRinv2 = 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
    
    ' 求解成功
    MRinv2 = True

End Function