' Generates Pan Magic Squares of order 8, Magic Sum 260, based on Matrix Operation
' Tested with Office 2007 under Windows 7
Sub MgcSqr8a()
y = MsgBox("Locked", vbCritical, "Routine MgcSqr8a")
End
Dim A(8, 8) 'Base Square
Dim R(8, 8) 'Rotated
Dim B(8, 8) 'Resulting Square B = 8 * R + A - 8
Sheets("Klad1").Select
t1 = Timer
n9 = 0: m2 = 8
For j1 = 1 To m2
For j2 = 1 To m2
If j2 = j1 Then GoTo 120
For j3 = 1 To m2
If j3 = j2 Or j3 = j1 Then GoTo 130
For j4 = 1 To m2
If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 140
For j5 = 1 To m2
If j5 = j4 Or j5 = j3 Or j5 = j2 Or j5 = j1 Then GoTo 150
For j6 = 1 To m2
If j6 = j5 Or j6 = j4 Or j6 = j3 Or j6 = j2 Or j6 = j1 Then GoTo 160
For j7 = 1 To m2
If j7 = j6 Or j7 = j5 Or j7 = j4 Or j7 = j3 Or j7 = j2 Or j7 = j1 Then GoTo 170
For j8 = 1 To m2
If j8 = j7 Or j8 = j6 Or j8 = j5 Or j8 = j4 Or j8 = j3 Or j8 = j2 Or j8 = j1 Then GoTo 180
GoSub 550 'Check sum of halfrow elements (=9)
If fl = 1 Then
GoSub 200 'Fill Matrix A
GoSub 300 'Rotate Matrix A
GoSub 400 'Calculate Matrix B = 8 * R + A - 8
n9 = n9 + 1
' GoSub 645 'Print results (Selected Numbers)
GoSub 650 'Print results (Squares)
End If
180 Next j8
170 Next j7
160 Next j6
150 Next j5
140 Next j4
130 Next j3
120 Next j2
110 Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr8a")
End
' Fill Matrix A
200 A(1, 1) = j1: A(1, 2) = j2: A(1, 3) = j3: A(1, 4) = j4 'First 4 columns Row 1
A(2, 1) = j5: A(2, 2) = j6: A(2, 3) = j7: A(2, 4) = j8 'First 4 columns Row 2
A(3, 1) = A(1, 1): A(3, 2) = A(1, 2): A(3, 3) = A(1, 3): A(3, 4) = A(1, 4) 'First 4 columns Row 3
A(4, 1) = A(2, 1): A(4, 2) = A(2, 2): A(4, 3) = A(2, 3): A(4, 4) = A(2, 4) 'First 4 columns Row 4
A(5, 1) = A(1, 1): A(5, 2) = A(1, 2): A(5, 3) = A(1, 3): A(5, 4) = A(1, 4) 'First 4 columns Row 5
A(6, 1) = A(2, 1): A(6, 2) = A(2, 2): A(6, 3) = A(2, 3): A(6, 4) = A(2, 4) 'First 4 columns Row 6
A(7, 1) = A(1, 1): A(7, 2) = A(1, 2): A(7, 3) = A(1, 3): A(7, 4) = A(1, 4) 'First 4 columns Row 7
A(8, 1) = A(2, 1): A(8, 2) = A(2, 2): A(8, 3) = A(2, 3): A(8, 4) = A(2, 4) 'First 4 columns Row 8
For j5 = 2 To 8 'Fill remainder of square
For j6 = 5 To 8
A(j5, j6) = A(j5 - 1, j6 - 4)
Next j6
Next j5
A(1, 5) = A(8, 1): A(1, 6) = A(8, 2): A(1, 7) = A(8, 3): A(1, 8) = A(8, 4)
Return
' Rotate Matrix A
300 For i1 = 1 To m2
For i2 = 1 To m2
R(i1, i2) = A(i2, 8 - i1 + 1)
Next i2
Next i1
Return
' Calculate Matrix B = 8 * R + A - 8
400 For i1 = 1 To m2
For i2 = 1 To m2
B(i1, i2) = 8 * R(i1, i2) + A(i1, i2) - 8
Next i2
Next i1
Return
' Check sum of halfrow elements (=9)
550 c1 = j1 + j5: If c1 <> 9 Then fl = 0: Return
c2 = j2 + j6: If c2 <> 9 Then fl = 0: Return
c3 = j3 + j7: If c3 <> 9 Then fl = 0: Return
c4 = j4 + j8: If c4 <> 9 Then fl = 0: Return
fl = 1
Return
' Print Results (Selected Numbers)
645 i3 = 0
For i1 = 1 To m2
For i2 = 1 To m2
i3 = i3 + 1
Cells(n9, i3).Value = B(i1, i2)
Next i2
Next i1
Return
' Print Results (Squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + m2 + 1: k2 = 0
Else
If n9 > 1 Then k2 = k2 + m2 + 1
End If
Cells(k1 + 1, k2 + 1).Select
For i1 = 1 To m2
For i2 = 1 To m2
Cells(k1 + i1, k2 + i2).Value = B(i1, i2) 'B
Next i2
Next i1
Return
End Sub
