PDA

Vollständige Version anzeigen : Lösen Linearer Gleichungssysteme


FW
20.08.2006, 23:32
Hallo Forum,

ich habe, beim Durchstöbern meiner Sourcen, folgenden Code gefunden und
gedacht, vielleicht ist der ja auch für andere von Interesse.

Viel Spaß
Frank


Lösen Linearer Gleichungssysteme der Form

a(1; 1) * x(1) + a(1; 2) * x(2) + ... + a(1; n) * x(n) = b(1)
a(2; 1) * x(1) + a(2; 2) * x(2) + ... + a(2; n) * x(n) = b(2)
.
.
.
a(n; 1) * x(1) + a(n; 2) * x(2) + ... + a(n; n) * x(n) = b(n)

Ein solches Gleichungssystem besitzt keine, genau eine oder unendlich viele
Lösungen.
Die vorgestellte Funktion löst solche Gleichungssysteme mit Hilfe des
"Gaußschen Algorithmus" und "Vollständiger Pivotsuche"
Der interessierte Anwender kann hierzu mehr in der einschlägigen Literatur
finden.
Die folgende Funktion erwartet als Übergabeparameter eine quadratische Matrix A
als Variant in der Form
a(1; 1), a(1; 2), ... a(1; n)
a(2; 1), a(2; 2), ... a(2; n)
.
.
.
a(n; 1), a(n; 2), ... a(n; n)
und den Ergebnisvektor B als Variant in der Form b(1), b(2), ... b(n).
Als weiteren Parameter erwartet die Funktion eine Variable vom Typ Variant, die
den Lösungsvektor X in der Form x(1), x(2), ... x(n) enthält.
Die Funktion ist vom Typ Integer und kann folgende Werte zurückliefern:

-9: Falsche Dimensionierung
-1: Unendlich viele Lösungen
0: Keine Lösung
1: Genau eine Lösung.

Function Lgs(ByVal varA As Variant, ByVal varB As Variant, ByRef varX As Variant) As Integer
Dim lngC() As Long, lngRC As Long, lngRow As Long, lngCol As Long
Dim lngVar1 As Long, lngVar2 As Long, lngVar3 As Long, lngVar4 As Long
Dim dblA() As Double, dblB() As Double, dblX() As Double, dblVar As Double

' Initialisierung
varX = Null
Lgs = 1
' Dimensionierungen prüfen
lngVar1 = UBound(varA) - LBound(varA)
lngVar2 = UBound(varA, 2) - LBound(varA, 2)
lngVar3 = UBound(varB) - LBound(varB)
If lngVar1 <> lngVar2 Or lngVar2 <> lngVar3 Then
Lgs = -9
Exit Function
End If
' Felder dimensionieren
lngRC = lngVar1
ReDim dblA(lngRC, lngRC)
ReDim dblB(lngRC)
ReDim dblX(lngRC)
ReDim lngC(lngRC)
' Felder füllen
lngVar1 = LBound(varA)
lngVar2 = LBound(varA, 2)
For lngVar3 = 0 To lngRC
For lngVar4 = 0 To lngRC
dblA(lngVar3, lngVar4) = varA(lngVar1 + lngVar3, lngVar2 + lngVar4)
Next lngVar4
Next lngVar3
lngVar1 = LBound(varB)
For lngVar2 = 0 To lngRC
dblB(lngVar2) = varB(lngVar1 + lngVar2)
lngC(lngVar2) = lngVar2
Next lngVar2
' Gleichungssystem lösen
For lngVar1 = 0 To lngRC - 1
' Pivotsuche
lngRow = lngVar1
lngCol = lngVar1
For lngVar2 = lngVar1 To lngRC
For lngVar3 = lngVar1 To lngRC
If Abs(dblA(lngRow, lngCol)) < Abs(dblA(lngVar2, lngVar3)) Then
lngRow = lngVar2
lngCol = lngVar3
End If
Next lngVar3
Next lngVar2
If dblA(lngRow, lngCol) <> 0 Then
' Zeilen-/Spaltentausch
For lngVar2 = lngVar1 To lngRC
dblVar = dblA(lngVar1, lngVar2)
dblA(lngVar1, lngVar2) = dblA(lngRow, lngVar2)
dblA(lngRow, lngVar2) = dblVar
Next lngVar2
dblVar = dblB(lngVar1)
dblB(lngVar1) = dblB(lngRow)
dblB(lngRow) = dblVar
For lngVar2 = 0 To lngRC
dblVar = dblA(lngVar2, lngVar1)
dblA(lngVar2, lngVar1) = dblA(lngVar2, lngCol)
dblA(lngVar2, lngCol) = dblVar
Next lngVar2
dblVar = lngC(lngVar1)
lngC(lngVar1) = lngC(lngCol)
lngC(lngCol) = dblVar
' Gaußscher Algorithmus
For lngVar2 = lngVar1 + 1 To lngRC
For lngVar3 = lngVar1 + 1 To lngRC
dblA(lngVar2, lngVar3) = dblA(lngVar2, lngVar3) - dblA(lngVar1, lngVar3) * dblA(lngVar2, lngVar1) / dblA(lngVar1, lngVar1)
Next lngVar3
dblB(lngVar2) = dblB(lngVar2) - dblB(lngVar1) * dblA(lngVar2, lngVar1) / dblA(lngVar1, lngVar1)
Next lngVar2
End If
Next lngVar1
' Rückeinsetzung
For lngVar1 = lngRC To 0 Step -1
For lngVar2 = lngVar1 + 1 To lngRC
dblB(lngVar1) = dblB(lngVar1) - dblA(lngVar1, lngVar2) * dblX(lngC(lngVar2))
Next lngVar2
If dblA(lngVar1, lngVar1) = 0 And dblB(lngVar1) <> 0 Then
' Keine Lösung
Lgs = 0
Exit Function
End If
If dblA(lngVar1, lngVar1) = 0 Then
' Unendlich viele Lösungen
dblX(lngC(lngVar1)) = 0
Lgs = -1
Else
dblX(lngC(lngVar1)) = dblB(lngVar1) / dblA(lngVar1, lngVar1)
End If
Next lngVar1
' Zuweisung
varX = dblX
End Function

Als Beispiele sollen folgende Gleichungssysteme dienen:

1x + 1y = 3
1x + 2y = 5
mit der eindeutigen Lösung x=1 und y=2

1x + 1y = 3
2x + 2y = 6
mit der mehrdeutigen Lösung x=3 und y=0

1x + 1y = 3
1x + 1y = 4
ohne Lösung

Sub test()
Dim a(1, 1) As Double, b(1) As Double, x As Variant

a(0, 0) = 1: a(0, 1) = 1: b(0) = 3
a(1, 0) = 1: a(1, 1) = 2: b(1) = 5
Debug.Print Lgs(a, b, x)
Debug.Print x(0), x(1)

a(0, 0) = 1: a(0, 1) = 1: b(0) = 3
a(1, 0) = 2: a(1, 1) = 2: b(1) = 6
Debug.Print Lgs(a, b, x)
Debug.Print x(0), x(1)

a(0, 0) = 1: a(0, 1) = 1: b(0) = 3
a(1, 0) = 1: a(1, 1) = 1: b(1) = 4
Debug.Print Lgs(a, b, x)
Debug.Print x
End Sub