module1.bas

采用vb程序语言编写

Attribute VB_Name = "Module1"
Option Explicit

Public Function MRinv(n As Integer, mtxA() As Double) As Boolean

'****************************************************************************************
'  功能：  实矩阵求逆的全选主元高斯－约当法
'  参数：  n      - Integer型变量，矩阵的阶数
'          mtxA   - Double型二维数组，体积为n x n。存放原矩阵A；返回时存放其逆矩阵A-1。
'  返回值：Boolean型，失败为False，成功为True
'****************************************************************************************

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
'****************************************
'矩阵求和函数
'*******************************************
Public Function Msum(M As Integer, n As Integer, Matrixsum() As Double, Matrix1() As Double, Matrix2() As Double)
   Dim i1 As Integer, i2 As Integer
   ReDim Matrixsum(1 To M, 1 To n)
   For i1 = 1 To M
        For i2 = 1 To n
            Matrixsum(i1, i2) = Matrix1(i1, i2) + Matrix2(i1, i2)
        Next i2
        
    Next i1
       
End Function
'****************************************
'矩阵求差函数
'*******************************************
Public Function Mminus(M As Integer, n As Integer, MatrixMinus() As Double, Matrix1() As Double, Matrix2() As Double)
    Dim i1 As Integer, i2 As Integer
    ReDim MatrixMinus(1 To M, 1 To n)
    For i1 = 1 To M
        For i2 = 1 To n
        MatrixMinus(i1, i2) = Matrix1(i1, i2) - Matrix2(i1, i2)
     Next i2
    Next i1
End Function
'****************************************
'矩阵转置函数  Matrix1(）需转置的矩阵，Matrixchange()为转置后的矩阵
'*******************************************
Public Function Mchange(M As Integer, n As Integer, Matrixchange() As Double, Matrix1() As Double)
    Dim i1 As Integer, i2 As Integer
    ReDim Matrixchange(1 To n, 1 To M) '动态分配用来存储转置后的矩阵
    For i1 = 1 To M
        For i2 = 1 To n
        Matrixchange(i2, i1) = Matrix1(i1, i2)
        Next i2
        Next i1
End Function
'****************************************
'矩阵想乘函数，MatrixMultiply()为存储AB后的矩阵，Matrix1()为A矩阵，Matrix2()为B矩阵,注意矩阵想乘的顺序
'Mi为行，Ni为列,i=1,2
'*******************************************
Public Function Mmultiply(M1 As Integer, n1 As Integer, M2 As Integer, n2 As Integer, MatrixMultiply() As Double, Matrix1() As Double, Matrix2() As Double)
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    If n1 <> M2 Then
        MsgBox "两矩阵不能想乘，请检查！", vbOKCancel + vbCritical + vbDefaultButton1
        Exit Function
  End If
   
    ReDim MatrixMultiply(1 To M1, 1 To n2)
   ' If n2 <> 1 Then
    For i1 = 1 To M1
     
        For i2 = 1 To n2
         MatrixMultiply(i1, i2) = 0
            For i3 = 1 To n1
             MatrixMultiply(i1, i2) = MatrixMultiply(i1, i2) + Matrix1(i1, i3) * Matrix2(i3, i2)
         
         Next i3
         Next i2
        Next i1
  'Else
    '  For i1 = 1 To M1
     
      '  For i2 = 1 To n2
       '  MatrixMultiply(i1, i2) = 0
          '  For i3 = 1 To n1
         '    MatrixMultiply(i1, i2) = MatrixMultiply(i1, i2) + Matrix1(i1, i3) * Matrix2(i3)
         
       '  Next i3
       '  Next i2
      '  Next i1
     'End If
End Function