' Reduces equations describing Magic Cubes of order 3

' Tested with Office 2007 under Windows 7

```Sub Algorithm3()

y = MsgBox("Locked", vbCritical, "Routine Algoritm3")
End

'   lost een stelsel vergelijkingen op en schrijft het oplossings algoritme

Dim a(33, 28)

Sheets("Matrix3").Select

k10 = 33: k20 = 28

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 = 27: k2 = 33: n1 = 0

For j1 = 1 To k1

GoSub 100                            'check op factoren

n1 = n1 + 34: 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 + 34: 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 + 34: GoSub 500
Cells(n1, 1).Select: Cells(n1, 1).Value = "Na verwisselen (Indien nodig)"

Next j1

GoSub 1000                              'normeren
GoSub 1050                              'comprimeren

n1 = n1 + 34: 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\Cubes\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
```