' Generates Bimagic Squares of order 8, Magic Sum 260, Gil Lamb
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs12()
y = MsgBox("Locked", vbCritical, "Routine CnstrSqrs12")
End
Dim A(8, 8) 'Base Square A
Dim B(8, 8) 'Base Square B
Dim C(8, 8) 'Resulting Square C = 8 * (A - 1) + B
Dim D(64), s(20)
Sheets("Klad1").Select
t1 = Timer
k1 = 1: k2 = 1: n9 = 0: m2 = 8
For j1 = 1 To m2
j5 = 9 - j1
For j2 = 1 To m2
If j2 = j1 Or j2 = j5 Then GoTo 120
j6 = 9 - j2
For j3 = 1 To m2
If j3 = j2 Or j3 = j1 Or j3 = j6 Or j3 = j5 Then GoTo 130
j7 = 9 - j3
For j4 = 1 To m2
If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 140
If j4 = j7 Or j4 = j6 Or j4 = j5 Then GoTo 140
j8 = 9 - j4
GoSub 200 'Fill Matrix A
GoSub 300 'Fill Matrix B
GoSub 400 'Calculate Matrix C = 8 * (A - 1) + B
' Check Magic Properties
GoSub 900: If fl1 = 0 Then GoTo 140
' Check Bimagic Properties
GoSub 950: If fl1 = 0 Then GoTo 140
' Check Identical Integers
GoSub 800: If fl1 = 0 Then GoTo 140
n9 = n9 + 1
' GoSub 645 'Print results (Selected Numbers)
GoSub 650 'Print results (Squares)
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 CnstrSqrs12")
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) = j4: A(2, 2) = j3: A(2, 3) = j2: A(2, 4) = j1 'First 4 columns Row 2
A(3, 1) = j2: A(3, 2) = j1: A(3, 3) = j4: A(3, 4) = j3 'First 4 columns Row 3
A(4, 1) = j3: A(4, 2) = j4: A(4, 3) = j1: A(4, 4) = j2 'First 4 columns Row 4
For i1 = 1 To 4
For i2 = 1 To 4
A(i1, i2 + 4) = A(i1, i2)
Next i2
Next i1
For i1 = 5 To 8
For i2 = 1 To 8
A(i1, i2) = 9 - A(i1 - 4, i2)
Next i2
Next i1
Return
' Fill Matrix B
300 B(1, 1) = A(8, 1): B(1, 2) = A(3, 1): B(1, 3) = A(2, 1): B(1, 4) = A(5, 1):
B(2, 1) = A(8, 2): B(2, 2) = A(3, 2): B(2, 3) = A(2, 2): B(2, 4) = A(5, 2):
B(3, 1) = A(8, 3): B(3, 2) = A(3, 3): B(3, 3) = A(2, 3): B(3, 4) = A(5, 3):
B(4, 1) = A(8, 4): B(4, 2) = A(3, 4): B(4, 3) = A(2, 4): B(4, 4) = A(5, 4):
For i1 = 1 To 4
For i2 = 1 To 4
B(i1 + 4, i2) = B(i1, i2)
Next i2
Next i1
For i1 = 1 To 8
For i2 = 5 To 8
B(i1, i2) = 9 - B(i1, i2 - 4)
Next i2
Next i1
Return
' Calculate Matrix B = 8 * (A-1) + B
400 i3 = 0
For i1 = 1 To m2
For i2 = 1 To m2
C(i1, i2) = 8 * (A(i1, i2) - 1) + B(i1, i2)
i3 = i3 + 1: D(i3) = C(i1, i2)
Next i2
Next i1
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 = C(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 = 1
Else
If n9 > 1 Then k2 = k2 + m2 + 1
End If
Cells(k1 + 1, k2 + 1).Select
Cells(k1, k2 + 1).Value = n9
For i1 = 1 To m2
For i2 = 1 To m2
Cells(k1 + i1, k2 + i2).Value = C(i1, i2)
Next i2
Next i1
Return
' Check Magic Properties (Back Check)
900 fl1 = 1: s2 = 260
Erase s
s(1) = D(1) + D(2) + D(3) + D(4) + D(5) + D(6) + D(7) + D(8)
s(2) = D(9) + D(10) + D(11) + D(12) + D(13) + D(14) + D(15) + D(16)
s(3) = D(17) + D(18) + D(19) + D(20) + D(21) + D(22) + D(23) + D(24)
s(4) = D(25) + D(26) + D(27) + D(28) + D(29) + D(30) + D(31) + D(32)
s(5) = D(33) + D(34) + D(35) + D(36) + D(37) + D(38) + D(39) + D(40)
s(6) = D(41) + D(42) + D(43) + D(44) + D(45) + D(46) + D(47) + D(48)
s(7) = D(49) + D(50) + D(51) + D(52) + D(53) + D(54) + D(55) + D(56)
s(8) = D(57) + D(58) + D(59) + D(60) + D(61) + D(62) + D(63) + D(64)
s(9) = D(1) + D(9) + D(17) + D(25) + D(33) + D(41) + D(49) + D(57)
s(10) = D(2) + D(10) + D(18) + D(26) + D(34) + D(42) + D(50) + D(58)
s(11) = D(3) + D(11) + D(19) + D(27) + D(35) + D(43) + D(51) + D(59)
s(12) = D(4) + D(12) + D(20) + D(28) + D(36) + D(44) + D(52) + D(60)
s(13) = D(5) + D(13) + D(21) + D(29) + D(37) + D(45) + D(53) + D(61)
s(14) = D(6) + D(14) + D(22) + D(30) + D(38) + D(46) + D(54) + D(62)
s(15) = D(7) + D(15) + D(23) + D(31) + D(39) + D(47) + D(55) + D(63)
s(16) = D(8) + D(16) + D(24) + D(32) + D(40) + D(48) + D(56) + D(64)
s(17) = D(1) + D(10) + D(19) + D(28) + D(37) + D(46) + D(55) + D(64)
s(18) = D(8) + D(15) + D(22) + D(29) + D(36) + D(43) + D(50) + D(57)
' Check Simple Magic
For j20 = 1 To 18
If s(j20) <> s2 Then fl1 = 0: Exit For
Next j20
Return
' Check Bimagic Properties
950 fl1 = 1: s2 = 11180
Erase s
s(1) = D(1) ^ 2 + D(2) ^ 2 + D(3) ^ 2 + D(4) ^ 2 + D(5) ^ 2 + D(6) ^ 2 + D(7) ^ 2 + D(8) ^ 2
s(2) = D(9) ^ 2 + D(10) ^ 2 + D(11) ^ 2 + D(12) ^ 2 + D(13) ^ 2 + D(14) ^ 2 + D(15) ^ 2 + D(16) ^ 2
s(3) = D(17) ^ 2 + D(18) ^ 2 + D(19) ^ 2 + D(20) ^ 2 + D(21) ^ 2 + D(22) ^ 2 + D(23) ^ 2 + D(24) ^ 2
s(4) = D(25) ^ 2 + D(26) ^ 2 + D(27) ^ 2 + D(28) ^ 2 + D(29) ^ 2 + D(30) ^ 2 + D(31) ^ 2 + D(32) ^ 2
s(5) = D(33) ^ 2 + D(34) ^ 2 + D(35) ^ 2 + D(36) ^ 2 + D(37) ^ 2 + D(38) ^ 2 + D(39) ^ 2 + D(40) ^ 2
s(6) = D(41) ^ 2 + D(42) ^ 2 + D(43) ^ 2 + D(44) ^ 2 + D(45) ^ 2 + D(46) ^ 2 + D(47) ^ 2 + D(48) ^ 2
s(7) = D(49) ^ 2 + D(50) ^ 2 + D(51) ^ 2 + D(52) ^ 2 + D(53) ^ 2 + D(54) ^ 2 + D(55) ^ 2 + D(56) ^ 2
s(8) = D(57) ^ 2 + D(58) ^ 2 + D(59) ^ 2 + D(60) ^ 2 + D(61) ^ 2 + D(62) ^ 2 + D(63) ^ 2 + D(64) ^ 2
s(9) = D(1) ^ 2 + D(9) ^ 2 + D(17) ^ 2 + D(25) ^ 2 + D(33) ^ 2 + D(41) ^ 2 + D(49) ^ 2 + D(57) ^ 2
s(10) = D(2) ^ 2 + D(10) ^ 2 + D(18) ^ 2 + D(26) ^ 2 + D(34) ^ 2 + D(42) ^ 2 + D(50) ^ 2 + D(58) ^ 2
s(11) = D(3) ^ 2 + D(11) ^ 2 + D(19) ^ 2 + D(27) ^ 2 + D(35) ^ 2 + D(43) ^ 2 + D(51) ^ 2 + D(59) ^ 2
s(12) = D(4) ^ 2 + D(12) ^ 2 + D(20) ^ 2 + D(28) ^ 2 + D(36) ^ 2 + D(44) ^ 2 + D(52) ^ 2 + D(60) ^ 2
s(13) = D(5) ^ 2 + D(13) ^ 2 + D(21) ^ 2 + D(29) ^ 2 + D(37) ^ 2 + D(45) ^ 2 + D(53) ^ 2 + D(61) ^ 2
s(14) = D(6) ^ 2 + D(14) ^ 2 + D(22) ^ 2 + D(30) ^ 2 + D(38) ^ 2 + D(46) ^ 2 + D(54) ^ 2 + D(62) ^ 2
s(15) = D(7) ^ 2 + D(15) ^ 2 + D(23) ^ 2 + D(31) ^ 2 + D(39) ^ 2 + D(47) ^ 2 + D(55) ^ 2 + D(63) ^ 2
s(16) = D(8) ^ 2 + D(16) ^ 2 + D(24) ^ 2 + D(32) ^ 2 + D(40) ^ 2 + D(48) ^ 2 + D(56) ^ 2 + D(64) ^ 2
s(17) = D(1) ^ 2 + D(10) ^ 2 + D(19) ^ 2 + D(28) ^ 2 + D(37) ^ 2 + D(46) ^ 2 + D(55) ^ 2 + D(64) ^ 2
s(18) = D(8) ^ 2 + D(15) ^ 2 + D(22) ^ 2 + D(29) ^ 2 + D(36) ^ 2 + D(43) ^ 2 + D(50) ^ 2 + D(57) ^ 2
' Check Simple Bimagic
n8 = 0
For j20 = 1 To 18
If s(j20) <> s2 Then fl1 = 0: Exit For
''If s(j20) = s2 Then n8 = n8 + 1
Next j20
Return
' Check Identical Integers
800 fl1 = 1
For i1 = 1 To 64
c2 = D(i1)
For i2 = (1 + i1) To 64
If c2 = D(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
End Sub
