IamOverlord
جمعه 17 شهریور 1391, 01:04 صبح
سلام دوستان.
این برنامه ای که می ذارم کارش حل دستگاه n معادله و n مجهول خطی با روش Gauss Jordan Elimination هست که با استفاده از ماژول چهار عمل اصلی روی اعداد بزرگ محدودیت عددیش رو حذف کردم.
مرحله ی بعدی پیدا کردن رابطه ی بازگشتی برای دنباله ی عددی ورودی بر مبنای این برنامه هستش...
IamOverlord
جمعه 17 شهریور 1391, 19:37 عصر
سلام دوستان.
به یه باگی برخوردم. خواهشا کمک کنید رفع بشه. به تصویر ضمیمه نگاه کنید. تا زمانی که برنامه بدون ماژول اعداد بزرگ بود، این مشکل وجود نداشت، اما با ماژول اعداد بزرگ به این مشکل می خوریم. نمی دونم اون عددی که توش E داره از کجا اومده!!!
IamOverlord
جمعه 17 شهریور 1391, 21:48 عصر
چه کنیم از دست خطاهای کوچیک تو یه خروار کد!!!
باید ورودی تابع make_one از double به string تغییر پیدا می کرد، چون اعداد بزرگ تو string ها ذخیره می شن...
پس Matrix_Mod این طوری می شه:
Option Explicit
Public Var As Byte
Public Eq As Byte
Public Matrix() 'As Double
Public no_diag As Boolean
Dim i As Byte
Dim j As Byte
Dim t As Byte
Dim max As Byte
Dim next_col As Byte
Dim TempNumber 'As Double
Dim diag 'As Double
Dim X As Integer
Dim Y As Integer
Dim lim As Boolean
Dim zero_row As Boolean
Public Sub Solve()
j = 0
next_col = 0
no_diag = False
'//If the last column has only zeros the system is Homogeneous and the solution is
'//trivial or non-trivial unless you have entered the Zero Matrix
If Homogeneous_system = True Then MsgBox "The sytem has a trivial or non-trivial" _
& " solution", vbInformation, "Homogeneous System": Exit Sub
'//Asigns the leading entry of the matrix
For i = 0 To (Eq - 1)
lim = False
If j < Var Then diag = Matrix(i, j)
next_col = j
Do
If next_col < Var Then
'If diag = 0 Then change_rows (next_col)
If FCompare(diag, "0.0") = 0 Then change_rows (next_col)
'//If all the elements in the column are zeros that means you need to find the
'//non zero column moving from the left to the right
If lim = True And next_col <= Var Then
next_col = next_col + 1
diag = Matrix(i, next_col)
no_diag = True
End If
End If
'Loop While (diag = 0 And next_col < Var)
Loop While (FCompare(diag, "0.0") = 0 And next_col < Var)
If next_col < Var Then
'If Matrix(i, next_col) <> 1 And Matrix(i, next_col) <> 0 Then make_one (diag)
If FCompare(Matrix(i, next_col), "1.0") <> 0 And FCompare(Matrix(i, next_col), "0.0") <> 0 Then make_one (diag)
If i < (Var - 1) And FCompare(diag, "0.0") <> 0 Then make_zeros_below (next_col)
End If
j = next_col + 1
Next i
'Hasta aqui ya tenemos Gauss, la siguiente subrutina se utiliza para Gauss-Jordan
'//We have zeros under leading entry 1, we need to do the same above
If no_diag = False Then
For i = 0 To (Eq - 2)
make_zeros_above
Next i
Else
j = 1
zero_row = False
For i = 1 To (Eq - 1)
make_zeros_above_2
If zero_row = True Then Exit For
Next i
End If
End Sub
'//The passed argument was next_row as col
Private Sub change_rows(col As Byte)
Dim temp_change 'As Double
X = i
lim = False
'Do While (Matrix(x, col) = 0 And x < Eq - 1)
Do While (FCompare(Matrix(X, col), "0.0") = 0 And X < Eq - 1)
diag = Matrix(X + 1, col)
'If diag <> 0 Then
If FCompare(diag, "0.0") <> 0 Then
For Y = 0 To Var
temp_change = Matrix(i, Y)
Matrix(i, Y) = Matrix(X + 1, Y)
Matrix(X + 1, Y) = temp_change
Next Y
Exit Do
Else
X = X + 1
End If
Loop
If X = (Eq - 1) Then lim = True
End Sub
Private Function Homogeneous_system() As Boolean
Dim myvalue As Double
For X = 0 To (Eq - 1)
'If Matrix(x, Var) = 0 Then myvalue = myvalue + 1
If FCompare(Matrix(X, Var), "0.0") = 0 Then myvalue = myvalue + 1
Next X
If myvalue = Eq Then Homogeneous_system = True
End Function
'//The passed argument was diag as pivot
Private Sub make_one(pivot)
For Y = Var To i Step -1
'Matrix(i, y) = Matrix(i, y) / pivot
Matrix(i, Y) = FDivide(Matrix(i, Y), pivot)
'Debug.Print Matrix(i, y)
Next Y
End Sub
'//The passed argument was next_row as col
Private Sub make_zeros_below(col As Byte)
X = i + 1
max = Eq - i - 1
For t = 1 To max
TempNumber = Matrix(X, col)
'If TempNumber <> 0 Then
If FCompare(TempNumber, "0.0") <> 0 Then
For Y = col To Var
'Matrix(x, y) = Round(Matrix(x, y) - TempNumber * Matrix(i, y), 12)
Matrix(X, Y) = FSubtract(Matrix(X, Y), FMultiply(TempNumber, Matrix(i, Y)))
'Debug.Print Matrix(x, y)
Next Y
End If
X = X + 1
Next t
End Sub
Private Sub make_zeros_above()
X = i
max = i + 1
For t = 0 To i
TempNumber = Matrix(X, i + 1)
'If TempNumber <> 0 Then
If FCompare(TempNumber, "0.0") <> 0 Then
For Y = max To Var
'Matrix(x, y) = Round(Matrix(x, y) - (TempNumber * Matrix(i + 1, y)), 12)
Matrix(X, Y) = FSubtract(Matrix(X, Y), FMultiply(TempNumber, Matrix(i + 1, Y)))
'Debug.Print Matrix(x, y)
Next Y
End If
X = X - 1
Next t
End Sub
Private Sub make_zeros_above_2()
'//I could used the Subroutine make_zeros_below, I needed to change the limits in For
'//Statement but I decided to do another Procedure to keep separate when you enter a
'//Linear System that produce a Non Dominant Matrix Form
Do
'If Matrix(i, j) <> 1 And j < Var - 1 Then
If FCompare(Matrix(i, j), "1.0") <> 0 And j < Var - 1 Then
j = j + 1
ElseIf j >= Var - 1 Then
zero_row = True
Exit Sub
End If
'Loop Until Matrix(i, j) = 1 And j < Var
Loop Until FCompare(Matrix(i, j), "1.0") = 0 And j < Var
For t = 0 To (i - 1)
TempNumber = Matrix(t, j)
'If TempNumber <> 0 Then
If FCompare(TempNumber, "0.0") <> 0 Then
For Y = j To Var
'Matrix(t, y) = Round(Matrix(t, y) - (TempNumber * Matrix(i, y)), 12)
Matrix(t, Y) = FSubtract(Matrix(t, Y), FMultiply(TempNumber, Matrix(i, Y)))
'Debug.Print Matrix(t, y)
Next Y
End If
Next t
j = j + 1
End Sub
vBulletin® v4.2.5, Copyright ©2000-1404, Jelsoft Enterprises Ltd.