Colaboración de Harvey Triana (2)

Rutina para la Solución de Ecuaciones Lineales

Lo que nos dice el autor sobre esta rutina:

Solución de Ecuaciones Lineales
======================
La solución de un sistema de 'n' ecuaciones lineales con 'n' incógnitas es un interesante reto a los programadores.
El siguiente código lo escribí inicialmente en Fortran, aquí te presento la versión Visual Basic.
He utilizado esta función en programación de Simuladores de Flujo y Solución del Método de los Mínimos Cuadrados.
En general, la función tiene múltiples usos en procedimientos matemáticos.

Es un código bastante complicado de seguir, pero si necesitas una guía, es el método de Eliminación de Gauss.

'Esto acelerará los cálculos
DefInt A-Z

Private Sub EjemploSencillo()
   
   'Se tiene el siguiente sistema de ecuaciones lineales que debe ser resuelto:
   '|1 1 1 6|
   '|1 0 1 4|
   '|1 1 0 3|

    Dim Sistema(1 To 3, 1 To 4) As Double 'Almacenará el sistema de ecuaciones
    Dim Solución(1 To 3) As Double        'Almacenará la solución del sistema
    
    Sistema(1, 1) = 1: Sistema(1, 2) = 1: Sistema(1, 3) = 1: Sistema(1, 4) = 6
    Sistema(2, 1) = 1: Sistema(2, 2) = 0: Sistema(2, 3) = 1: Sistema(2, 4) = 4
    Sistema(3, 1) = 1: Sistema(3, 2) = 1: Sistema(3, 3) = 0: Sistema(3, 4) = 3
    
    If Gauss(Sistema(), Solución()) Then
       Debug.Print "Solución:"
       Debug.Print "C1 = "; Solución(1)
       Debug.Print "C2 = "; Solución(2)
       Debug.Print "C3 = "; Solución(3)
       Stop
    Else
       MsgBox "El sistema de ecuaciones no tiene solución..."
    End If
End Sub


'-------------------------------------------------------------------------
'Matrix Solution. Return True if then function was successful
'-------------------------------------------------------------------------
Static Function Gauss(ByRef A() As Double, ByRef C() As Double) As Boolean
   
    Dim Tem As Double, Sum As Double, i, l, j, k, n, m
    
    On Error GoTo Gauss_Err
    n = UBound(C)
    m = n + 1
    For l = 1 To n - 1
        j = l
        For k = l + 1 To n
            If (Abs(A(j, l)) < Abs(A(k, l))) Then j = k
        Next
        If Not (j = l) Then
           For i = 1 To m
               Tem = A(l, i)
               A(l, i) = A(j, i)
               A(j, i) = Tem
           Next
        End If
        For j = l + 1 To n
            Tem = A(j, l) / A(l, l)
            For i = 1 To m
                A(j, i) = A(j, i) - Tem * A(l, i)
            Next
        Next
    Next
    C(n) = A(n, m) / A(n, n)
    For i = 1 To n - 1
        j = n - i
        Sum = 0
        For l = 1 To i
            k = j + l
            Sum = Sum + A(j, k) * C(k)
        Next
        C(j) = (A(j, m) - Sum) / A(j, j)
    Next
    Gauss = True
    
   'Programmed by Harvey Triana ©
    Exit Function
    
Gauss_Err: Gauss = False
End Function