* E Posta Adresiniz:
* Kodu Girin:

N Bilinmeyenli N Doğrusal Denklem Çözümü

NxN Kare Matris Hesaplaması
harunkilic - 19.09.2006 17:40
Yazar: Harun KILIÇ
İçerik: Harun KILIÇ

(Kontrol panelinizde görünür)
Visual Basic 6.0 ile yazılmış BİLGİSAYAR PROGRAMI KODU

Option Explicit

'//// Visual Basic 6.0
'//// N Bilinmeyenli N Dogrusal Denklem Cozumu
'//// NxN KARE MATRIS

Public Type MatNxN
A() As Double
Minor() As Double
Determinant As Double
CoFactor() As Double
Transpose() As Double
Inverse() As Double
End Type


Public Type EQN_
N As Long
MATRIS As MatNxN
SABITLER() As Double
SONUCLAR() As Double
End Type

Public EQN As EQN_

Public Function _
DeterminantOf(SqrMatrix() As Double) As Double

Dim i As Integer
Dim j As Integer
Dim CalcTotal As Double
For i = 1 To 1
For j = 1 To UBound(SqrMatrix)
CalcTotal = CalcTotal + SqrMatrix(i, j) * (-1) ^ (i + j) * MinorOf(SqrMatrix, i, j)
Next j
Next i
DeterminantOf = CalcTotal

End Function

Public Function _
MinorOf(SqrMatrix() As Double, EntityRowID As Integer, _
EntityColID As Integer) As Double

If UBound(SqrMatrix) = 1 Then Exit Function
Dim SubMatrix() As Double
DetermineSubMatrix SqrMatrix, EntityRowID, EntityColID, SubMatrix
If UBound(SubMatrix) = 1 Then
MinorOf = SubMatrix(1, 1)

Else
MinorOf = DeterminantOf(SubMatrix)
End If

End Function

Public Sub _
DetermineSubMatrix(SqrMatrix() As Double, EntityRowID As Integer, _
EntityColID As Integer, SubMatrix() As Double)
Dim i As Integer
Dim j As Integer
Dim subI As Integer
Dim subJ As Integer
ReDim SubMatrix(1 To UBound(SqrMatrix) - 1, 1 To UBound(SqrMatrix) - 1)
subI = 1: subJ = 1
For i = 1 To UBound(SqrMatrix)
If i = EntityRowID Then i = i + 1
For j = 1 To UBound(SqrMatrix)
If j = EntityColID Then j = j + 1
SubMatrix(subI, subJ) = SqrMatrix(i, j)
subJ = subJ + 1
If subJ = UBound(SqrMatrix) Then Exit For
Next j
subI = subI + 1
subJ = 1
If subI = UBound(SqrMatrix) Then Exit For
Next i

End Sub


Public Sub _
GetTransposeAndInverse(CoFactor() As Double, Transpose() As Double, _
Inverse() As Double, Det As Double)

Dim i As Integer
Dim j As Integer

For i = 1 To UBound(CoFactor)
For j = UBound(CoFactor) To 1 Step -1
Transpose(j, i) = CoFactor(i, j)
Inverse(j, i) = Transpose(j, i) / Det
Next j
Next i

End Sub

Public Sub Main()

With EQN

'Denklem sayisini kendi ihtiyaciniza gore degistirin, pozitif tamsayi olmalıdır.
.N = 4

ReDim .SABITLER(1 To EQN.N)
ReDim .MATRIS.A(1 To EQN.N, 1 To EQN.N)

' ORNEK DENKLEMLER - BASLANGIC
' X=x1=1 Y=x2=1 Z=x3=1 W=x4=1

' 3X + 4Y + Z + 5W = 13
' 5X + 2Y - 2Z - W = 4
' -2X + Y + 3Z + 2W = 4
' -9X - Y + 2Z + 2W = -6

'Denklem sayisini kadar katsayilarinizi ve sabit degerlerinizi girin, bu örnekte
'4 adet dogrusal denklem kullanilmistir
'1 numarali denklem
.MATRIS.A(1, 1) = 3 'Katsayi X1
.MATRIS.A(1, 2) = 4 'Katsayi X2
.MATRIS.A(1, 3) = 1 'Katsayi X3
.MATRIS.A(1, 4) = 5 'Katsayi X4
.SABITLER(1) = 13 'denklem sonucu sabit sayi

'2 numarali denklem
.MATRIS.A(2, 1) = 5
.MATRIS.A(2, 2) = 2
.MATRIS.A(2, 3) = -2
.MATRIS.A(2, 4) = -1
.SABITLER(2) = 4
'3 numarali denklem
.MATRIS.A(3, 1) = -2
.MATRIS.A(3, 2) = 1
.MATRIS.A(3, 3) = 3
.MATRIS.A(3, 4) = 2
.SABITLER(3) = 4

'4 numarali denklem
.MATRIS.A(4, 1) = -9
.MATRIS.A(4, 2) = -1
.MATRIS.A(4, 3) = 2
.MATRIS.A(4, 4) = 2
.SABITLER(4) = -6

' ORNEK DENKLEMLER - BITIS


ReDim .MATRIS.CoFactor(1 To .N, 1 To .N)
ReDim .MATRIS.Inverse(1 To .N, 1 To .N)
ReDim .MATRIS.Minor(1 To .N, 1 To .N)
ReDim .MATRIS.Transpose(1 To .N, 1 To .N)

Dim i As Integer
Dim j As Integer

For i = 1 To .N
For j = 1 To .N
.MATRIS.Minor(i, j) = MinorOf(.MATRIS.A, i, j)
.MATRIS.CoFactor(i, j) = (-1) ^ (i + j) * .MATRIS.Minor(i, j)
Next j
Next i

.MATRIS.Determinant = DeterminantOf(.MATRIS.A)
If .MATRIS.Determinant = 0 Then
MsgBox "COZUM BULUNAMIYOR! det(A)=0"
Exit Sub
End If

GetTransposeAndInverse .MATRIS.CoFactor, .MATRIS.Transpose, _
.MATRIS.Inverse, .MATRIS.Determinant

ReDim .SONUCLAR(1 To .N)
Dim X As Double

For i = 1 To .N
For j = 1 To .N
X = X + .MATRIS.Inverse(i, j) * .SABITLER(j)
Next j
.SONUCLAR(i) = X
MsgBox "x" & (i) & " = " & Format(.SONUCLAR(i), "#0.00000000")
X = 0#
Next i

MsgBox "Katsayilari ve sabitleri Excel dosyasindan alan kod için:" & vbCr & _
"hrnkilic@gmail.com"

End With

End Sub
Yorumlar :
hyr   23.01.2010 14:49 #12340  

MsgBox "Burası AutoCad Okulu." & vbCrLf & "Lütfen yazdığınız form başlığına bakarak tekrar deneyiniz", 16, "Hata"

bturcan   07.01.2009 18:08 #10101  

çok güzel

cunal   28.08.2007 16:14 #5272  

Harun bey eline saglık,
iyi güzel yazmıssın lakin ben programcı degilim, ama hevesliyim.
Bu ne işimize yarar nerede kullanabiliriz.
Şoyle bide acıklayıcı bilgilendirici birde yorum yazsan çok mutlu edersin beni.
inanıyorumki başkalarıda cok mutlu olur bu duruma.

Copyright © 2004-2018 | Tüm Hakları Saklıdır | 492 | Site haritası | İstatistikler | Hakkımızda | Kadromuz | Gizlilik | Reklam