gaosijordan消去法.bas

本程序能偶准确算出储层某一时刻的地层压力

Attribute VB_Name = "GaosiJordan消去法"

'''GAUSS-Jordan-??????????.TXT
Sub GAUSSJ(A() As Double, n, B() As Double)
    ReDim IPIV(n), INDXR(n), INDXC(n)
    For J = 1 To n
        IPIV(J) = 0
    Next J
    For i = 1 To n
        BIG = 0#
        For J = 1 To n
            If IPIV(J) <> 1 Then
                For k = 1 To n
                If IPIV(k) = 0 Then
                    If Abs(A(J, k)) >= BIG Then
                        BIG = Abs(A(J, k))
                        IROW = J
                        ICOL = k
                    End If
                ElseIf IPIV(k) > 1 Then
                   
                    MsgBox "Singular matrix", 48, "'"""
                   Stop
                End If
                Next k
            End If
        Next J
        IPIV(ICOL) = IPIV(ICOL) + 1
        If IROW <> ICOL Then
            For L = 1 To n
                DUM = A(IROW, L)
                A(IROW, L) = A(ICOL, L)
                A(ICOL, L) = DUM
            Next L
            DUM = B(IROW)
            B(IROW) = B(ICOL)
            B(ICOL) = DUM
        End If
        INDXR(i) = IROW
        INDXC(i) = ICOL
        If A(ICOL, ICOL) = 0# Then MsgBox "Singular matrix", 48, "警告  ": Stop '"""
              
        
        PIVINV = 1# / A(ICOL, ICOL)
        A(ICOL, ICOL) = 1#
        For L = 1 To n
            A(ICOL, L) = A(ICOL, L) * PIVINV
        Next L
        B(ICOL) = B(ICOL) * PIVINV
        For LL = 1 To n
            If LL <> ICOL Then
                DUM = A(LL, ICOL)
                A(LL, ICOL) = 0#
                For L = 1 To n
                    A(LL, L) = A(LL, L) - A(ICOL, L) * DUM
                Next L
                B(LL) = B(LL) - B(ICOL) * DUM
            End If
        Next LL
    Next i
    For L = n To 1 Step -1
        If INDXR(L) <> INDXC(L) Then
            For k = 1 To n
                DUM = A(k, INDXR(L))
                A(k, INDXR(L)) = A(k, INDXC(L))
                A(k, INDXC(L)) = DUM
            Next k
        End If
    Next L
End Sub