IamOverlord
جمعه 17 شهریور 1391, 02:04 صبح
سلام دوستان.
این برنامه ای که می ذارم کارش حل دستگاه n معادله و n مجهول خطی با روش Gauss Jordan Elimination هست که با استفاده از ماژول چهار عمل اصلی روی اعداد بزرگ محدودیت عددیش رو حذف کردم.
مرحله ی بعدی پیدا کردن رابطه ی بازگشتی برای دنباله ی عددی ورودی بر مبنای این برنامه هستش...
IamOverlord
جمعه 17 شهریور 1391, 20:37 عصر
سلام دوستان.
به یه باگی برخوردم. خواهشا کمک کنید رفع بشه. به تصویر ضمیمه نگاه کنید. تا زمانی که برنامه بدون ماژول اعداد بزرگ بود، این مشکل وجود نداشت، اما با ماژول اعداد بزرگ به این مشکل می خوریم. نمی دونم اون عددی که توش E داره از کجا اومده!!!
IamOverlord
جمعه 17 شهریور 1391, 22: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.