' Reduces equations describing Magic Squares of order 4
' Tested with Office 2007 under Windows 7
Sub Algorithm4()
y = MsgBox("Locked", vbCritical, "Routine Algoritm4")
End
' lost een stelsel vergelijkingen op en schrijft het oplossings algoritme
Dim a(16, 17)
' 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1
' 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1
' 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1
' 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1
' 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1
' 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1
' 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1
' 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1
' 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1
' 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1
' 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1
' 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1
' 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1
' 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1
' 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1
' 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1
Sheets("Matrix4").Select
k10 = 16: k20 = 17
For j1 = 1 To k10
For j2 = 1 To k20
a(j1, j2) = Cells(j1, j2).Value
Next j2
Next j1
' A*x=c
' De aangevulde matrix is:
' A(a11,a12,a13,a14, ... c1)
' A(a21,a22,a23,a24, ... c2)
' A(a31,a32,a33,a34, ... c3)
' ...
k = 1: k1 = 16: k2 = 16: n1 = 0
For j1 = 1 To k1
GoSub 100 'check op factoren
n1 = n1 + 17: GoSub 500
Cells(n1, 1).Select: Cells(n1, 1).Value = "Na check op factoren"
' zoek een element >< 0 in kolom j1
a1 = 0: J = k
For j2 = k To k2
If a(j2, j1) <> 0 Then a1 = Abs(a(j2, j1)): J = j2: GoTo 5
Next j2
' zoek de kleinste (absoluut) in kolom j1
5 For j2 = k To k2
If a(j2, j1) <> 0 And a1 > Abs(a(j2, j1)) Then a1 = Abs(a(j2, j1)): J = j2
Next j2
For j2 = 1 To k2 'vegen
If a1 = 0 Then GoTo 10 'rij met alleen maar nullen
If a(j2, j1) = 0 Then GoTo 10
If j2 = J Then GoTo 10
a1 = a(j, j1): a2 = a(j2, j1): n = a2 / a1
If Abs(n) >= 1 And n = Int(n) Then
For j3 = 1 To k1 + 1
a(j2, j3) = a(j2, j3) - n * (a(j, j3))
If Abs(a(j2, j3)) < 0.000001 Then a(j2, j3) = 0
Next j3
Else 'voorkom breuken
For j3 = 1 To k1 + 1
a(j2, j3) = a1 * a(j2, j3) - a2 * (a(j, j3))
If Abs(a(j2, j3)) < 0.000001 Then a(j2, j3) = 0
Next j3
End If
10 Next j2
n1 = n1 + 17: GoSub 500
Cells(n1, 1).Select: Cells(n1, 1).Value = "Na Vegen"
For j2 = 1 To k1 + 1
a1 = a(J, j2) 'Swap a(j, j2) , a(k, j2)
a(J, j2) = a(k, j2)
a(k, j2) = a1
Next j2
k = k + 1
n1 = n1 + 17: GoSub 500
Cells(n1, 1).Select: Cells(n1, 1).Value = "Na verwisselen (Indien nodig)"
Next j1
GoSub 1000 'normeren
GoSub 1050 'comprimeren
n1 = n1 + 17: GoSub 500
Cells(n1, 1).Select: Cells(n1, 1).Value = "Resultaten"
GoSub 700 'schrijf algoritme
End
' check op factoren
100 For j20 = k To k2
i = 1: a1 = 0
For j10 = 1 To k1 + 1 'zoek een element >< 0
If a(j20, j10) <> 0 Then a1 = Abs(a(j20, j10)): i = j10: GoTo 105
Next j10
If a1 = 0 Then GoTo 110 'rij met alleen maar nullen
105 For j10 = 1 To k1 + 1 'zoek het kleinste element >< 0
If a(j20, j10) <> 0 And a1 > Abs(a(j20, j10)) Then a1 = Abs(a(j20, j10)): i = j10
Next j10
fl = 1
For j10 = 1 To k1 + 1
a2 = a(j20, j10) / a(j20, i)
If a2 <> Int(a2) Then fl = 0
Next j10
If fl = 0 Then GoTo 110
For j10 = 1 To k1 + 1
a(j20, j10) = a(j20, j10) / a1
Next j10
110 Next j20
Return
500 For j10 = 1 To k10
For j20 = 1 To k20
' a(j10, j20) = Round(a(j10, j20), 3) 'Correction floating point error
Cells(n1 + j10, j20).Value = a(j10, j20)
Next j20
Next j10
Return
' Schrijf algoritme
700 Open "C:\Users\jos\WebSite\Entertainment\Descriptions\Excel\Vierkanten\alg.txt" For Output As #1
Print #1, "'": Print #1, "' bepaal mogelijke oplossingen": Print #1, "'"
For j10 = k10 To 1 Step -1
fl = 0
For j20 = 1 To k20
If a(j10, j20) <> 0 Then fl = 1: j30 = j20: GoTo 702 'te bepalen variabele
Next j20
702 If fl = 0 Then GoTo 710
prstr1$ = "a(" + Str$(j30) + ")="
s1 = a(j10, k20)
If s1 <> 0 Then
If Abs(s1) <> 1 Then
prstr1$ = prstr1$ + Str$(s1) + "*s1"
ElseIf s1 > 0 Then
prstr1$ = prstr1$ + "s1"
ElseIf s1 < 0 Then
prstr1$ = prstr1$ + "-s1"
End If
End If
For j20 = j30 + 1 To k20 - 1
a1 = a(j10, j20)
If a1 <> 0 Then
a10$ = Str$(a1)
If a1 > 0 Then
prstr1$ = prstr1$ + "-"
Else
prstr1$ = prstr1$ + "+": a10$ = Mid$(a10$, 2)
End If
If Abs(a1) <> 1 Then
prstr1$ = prstr1$ + a10$ + "*a(" + Str$(j20) + ")"
Else
prstr1$ = prstr1$ + "a(" + Str$(j20) + ")"
End If
End If
705 Next j20
Print #1, prstr1$
710 Next j10
Print #1, "RETURN"
Return
' normeren
1000 For j10 = 1 To k10
fl = 0
For j20 = 1 To k20
If a(j10, j20) <> 0 Then
fl = 1: a1 = a(j10, j20)
For j30 = 1 To k20
a(j10, j30) = a(j10, j30) / a1
Next j30
End If
If fl = 1 Then Exit For
Next j20
Next j10
Return
' comprimeren
1050 k1 = 0
For j10 = 1 To k10
fl1 = 0
While (fl1 = 0 And j10 < k10 - k1)
For j20 = 1 To k20
If a(j10, j20) <> 0 Then fl1 = 1
Next j20
If fl1 = 0 Then
k1 = k1 + 1
For j30 = j10 To k10 - 1
For j20 = 1 To k20
a(j30, j20) = a(j30 + 1, j20)
Next j20
Next j30
For j20 = 1 To k20: a(k10, j20) = 0: Next j20
End If
Wend
Next j10
Return
End Sub
