metodo gauss-jordan

tito
11 de Octubre del 2005
si alguno de ustedes tiene el codigo del metodo de GAUSS-JORDAN se los agradeceria si me lo mandaran
por favor

alex_j50
11 de Octubre del 2005

Public ing As String
Public ne As Integer
Private Sub Command2_Click()
resp = MsgBox("Esta seguro de " & vbCrLf & "borrar la matriz", vbInformation + vbYesNo + vbDefaultButton2, "Eliminación de Gauss")
If resp = 6 Then
answer.Clear
matrix.Clear
ing = 0
ing = InputBox("Ingrese el número de ecuaciones", "Eliminación de Gauss")
If ing = "" Then
txtingreso.SetFocus

Else
txtingreso.SetFocus
txtingreso.Text = Str(ing)
matrix.Cols = ing + 1
matrix.Rows = ing
Call tamaño
End If
Else
Exit Sub
End If
End Sub

Private Sub Command3_Click()
End
End Sub

Private Sub Form_Activate()
txtingreso.SetFocus
End Sub
Private Sub Command1_Click()
ne = Val(txtingreso.Text)
answer.Rows = ne
' ne: es el número de ecuaciones
ReDim Sistema(1 To ne + 5, 1 To ne + 10) As Double
ReDim Solución(1 To ne) As Double
If matrix.Text = "" Then
MsgBox "Ingrese sus datos ", vbCritical + vbOKOnly, "Menzaje": Exit Sub
Else
For i = 1 To ne
For j = 1 To ne + 1
Sistema(i, j) = matrix.TextMatrix(i - 1, j - 1)
Next j
Next i
ReDim Solución(1 To ne) As Double
If Gauss(Sistema(), Solución()) Then
For i = 0 To ne - 1
answer.TextMatrix(i, 0) = Format(Solución(i + 1), "0.000")
Next i
Else
MsgBox "El sistema de ecuaciones no tiene solución...", vbCritical + vbOKOnly, "Atención"
End If
End If
tamaño
End Sub

Private Sub Form_Load()
matrix.TextMatrix(0, 0) = 1
matrix.TextMatrix(0, 1) = 1
matrix.TextMatrix(0, 2) = 1
matrix.TextMatrix(0, 3) = 6
matrix.TextMatrix(1, 0) = 1
matrix.TextMatrix(1, 1) = 0
matrix.TextMatrix(1, 2) = 1
matrix.TextMatrix(1, 3) = 4
matrix.TextMatrix(2, 0) = 1
matrix.TextMatrix(2, 1) = 1
matrix.TextMatrix(2, 2) = 0
matrix.TextMatrix(2, 3) = 1
tamaño
End Sub

Private Sub matrix_KeyPress(KeyAscii As Integer)
'NUMEROS DE 48-57
'. EL PUNTO "." 46
'LETRAS 65 -90
If KeyAscii >= 46 And KeyAscii <= 57 Then
matrix.Text = matrix.Text & Chr(KeyAscii)
End If
End Sub

Private Sub matrix_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyDelete
matrix.Text = ""
Case vbKeyBack
If Len(matrix.Text) > 0 Then
matrix.Text = Left(matrix.Text, Len(matrix.Text) - 1)
End If
End Select
End Sub

Private Sub txtingreso_KeyPress(KeyAscii As Integer)
n = Val(txtingreso.Text)
ne = n
If KeyAscii = 13 Then
matrix.Cols = n + 1
matrix.Rows = n
tamaño
End If

End Sub
Private Sub txtingreso_LostFocus()
n = Val(txtingreso.Text)
matrix.Cols = n + 1
matrix.Rows = n
End Sub
'Esta es una subrutina bajada de Internet
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
Else: j = k
End If
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
Exit Function
Gauss_Err: Gauss = False
End Function
Sub tamaño()
ne = Val(txtingreso.Text)
matrix.Height = matrix.RowHeight(1) * (ne + 0.5)
matrix.Width = (matrix.ColWidth(1)) * (ne + 1.12)
answer.Height = answer.RowHeight(1) * (ne + 0.5)
End Sub

'esta en visual solo tienes que poner los objetos....