' Generates Bimagic Squares of order 8, Magic Sum 260, Generalised
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs11b()
y = MsgBox("Locked", vbCritical, "Routine CnstrSqrs11b")
End
Dim a8(64), a(64), b(64), c(64), d(64), e(64), f(64) 'Input
Dim R(64), s(20) 'Results
Dim m(6)
Sheets("Klad1").Select
t1 = Timer
k1 = 1: k2 = 1: n9 = 0: m2 = 8
m(1) = 1: m(2) = 2: m(3) = 4: m(4) = 8: m(5) = 16: m(6) = 32
n10 = 2: n20 = 2 'start row : column
n40 = 0: i40 = 0 'current square
For j100 = 1 To 8 * 36 'Square nr j100 current
n40 = n40 + 1: n20 = 2 + (n40 - 1) * 9: i40 = i40 + 1
''Cells(n10, n20).Select
''y = MsgBox(CStr(j100), vbInformation, "Test " + CStr(i40))
i4 = 0
For j1 = n10 To n10 + 7 'Row within square j3
For j2 = n20 To n20 + 7 'Column within square j3
i4 = i4 + 1
a8(i4) = Sheets("Decomp8").Cells(j1, j2).Value 'load square
Next j2
Next j1
Select Case i40
Case 2
For i1 = 1 To 64: a(i1) = a8(i1): Next i1
Case 3
For i1 = 1 To 64: b(i1) = a8(i1): Next i1
Case 4
For i1 = 1 To 64: c(i1) = a8(i1): Next i1
Case 6
For i1 = 1 To 64: d(i1) = a8(i1): Next i1
Case 7
For i1 = 1 To 64: e(i1) = a8(i1): Next i1
Case 8
For i1 = 1 To 64: f(i1) = a8(i1): Next i1
End Select
If n40 = 4 Then n40 = 0: n10 = n10 + 9: n20 = 2
If i40 = 8 Then ' Matrices A ... F Defined
For j1 = 1 To 6
For j2 = 1 To 6
If j2 = j1 Then GoTo 20
For j3 = 1 To 6
If j3 = j2 Or j3 = j1 Then GoTo 30
For j4 = 1 To 6
If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 40
For j5 = 1 To 6
If j5 = j4 Or j5 = j3 Or j5 = j2 Or j5 = j1 Then GoTo 50
For j6 = 1 To 6
If j6 = j5 Or j6 = j4 Or j6 = j3 Or j6 = j2 Or j6 = j1 Then GoTo 60
' Calculate Matrix R
For i1 = 1 To 64
R(i1) = m(j1) * a(i1) + m(j2) * b(i1) + m(j3) * c(i1) + m(j4) * d(i1) + m(j5) * e(i1) + m(j6) * f(i1) + 1
Next i1
' Check Magic Properties
GoSub 900: If fl1 = 0 Then GoTo 60
' Check Bimagic Properties
GoSub 950: If fl1 = 0 Then GoTo 60
' Check Identical Integers
GoSub 800: If fl1 = 0 Then GoTo 60
n9 = n9 + 1
' GoSub 645 'Print results (Selected Numbers)
GoSub 650 'Print results (Squares)
60 Next j6
50 Next j5
40 Next j4
30 Next j3
20 Next j2
10 Next j1
i40 = 0
End If
Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs11b")
End
' Print Results (Selected Numbers)
645 i3 = 0
For i1 = 1 To m2
For i2 = 1 To m2
i3 = i3 + 1
Cells(n9, i3).Value = R(i3)
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
i3 = 0
For i1 = 1 To m2
For i2 = 1 To m2
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = R(i3)
Next i2
Next i1
Return
' Check Magic Properties (Back Check)
900 fl1 = 1: s2 = 260
Erase s
s(1) = R(1) + R(2) + R(3) + R(4) + R(5) + R(6) + R(7) + R(8)
s(2) = R(9) + R(10) + R(11) + R(12) + R(13) + R(14) + R(15) + R(16)
s(3) = R(17) + R(18) + R(19) + R(20) + R(21) + R(22) + R(23) + R(24)
s(4) = R(25) + R(26) + R(27) + R(28) + R(29) + R(30) + R(31) + R(32)
s(5) = R(33) + R(34) + R(35) + R(36) + R(37) + R(38) + R(39) + R(40)
s(6) = R(41) + R(42) + R(43) + R(44) + R(45) + R(46) + R(47) + R(48)
s(7) = R(49) + R(50) + R(51) + R(52) + R(53) + R(54) + R(55) + R(56)
s(8) = R(57) + R(58) + R(59) + R(60) + R(61) + R(62) + R(63) + R(64)
s(9) = R(1) + R(9) + R(17) + R(25) + R(33) + R(41) + R(49) + R(57)
s(10) = R(2) + R(10) + R(18) + R(26) + R(34) + R(42) + R(50) + R(58)
s(11) = R(3) + R(11) + R(19) + R(27) + R(35) + R(43) + R(51) + R(59)
s(12) = R(4) + R(12) + R(20) + R(28) + R(36) + R(44) + R(52) + R(60)
s(13) = R(5) + R(13) + R(21) + R(29) + R(37) + R(45) + R(53) + R(61)
s(14) = R(6) + R(14) + R(22) + R(30) + R(38) + R(46) + R(54) + R(62)
s(15) = R(7) + R(15) + R(23) + R(31) + R(39) + R(47) + R(55) + R(63)
s(16) = R(8) + R(16) + R(24) + R(32) + R(40) + R(48) + R(56) + R(64)
s(17) = R(1) + R(10) + R(19) + R(28) + R(37) + R(46) + R(55) + R(64)
s(18) = R(8) + R(15) + R(22) + R(29) + R(36) + R(43) + R(50) + R(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) = R(1) ^ 2 + R(2) ^ 2 + R(3) ^ 2 + R(4) ^ 2 + R(5) ^ 2 + R(6) ^ 2 + R(7) ^ 2 + R(8) ^ 2
s(2) = R(9) ^ 2 + R(10) ^ 2 + R(11) ^ 2 + R(12) ^ 2 + R(13) ^ 2 + R(14) ^ 2 + R(15) ^ 2 + R(16) ^ 2
s(3) = R(17) ^ 2 + R(18) ^ 2 + R(19) ^ 2 + R(20) ^ 2 + R(21) ^ 2 + R(22) ^ 2 + R(23) ^ 2 + R(24) ^ 2
s(4) = R(25) ^ 2 + R(26) ^ 2 + R(27) ^ 2 + R(28) ^ 2 + R(29) ^ 2 + R(30) ^ 2 + R(31) ^ 2 + R(32) ^ 2
s(5) = R(33) ^ 2 + R(34) ^ 2 + R(35) ^ 2 + R(36) ^ 2 + R(37) ^ 2 + R(38) ^ 2 + R(39) ^ 2 + R(40) ^ 2
s(6) = R(41) ^ 2 + R(42) ^ 2 + R(43) ^ 2 + R(44) ^ 2 + R(45) ^ 2 + R(46) ^ 2 + R(47) ^ 2 + R(48) ^ 2
s(7) = R(49) ^ 2 + R(50) ^ 2 + R(51) ^ 2 + R(52) ^ 2 + R(53) ^ 2 + R(54) ^ 2 + R(55) ^ 2 + R(56) ^ 2
s(8) = R(57) ^ 2 + R(58) ^ 2 + R(59) ^ 2 + R(60) ^ 2 + R(61) ^ 2 + R(62) ^ 2 + R(63) ^ 2 + R(64) ^ 2
s(9) = R(1) ^ 2 + R(9) ^ 2 + R(17) ^ 2 + R(25) ^ 2 + R(33) ^ 2 + R(41) ^ 2 + R(49) ^ 2 + R(57) ^ 2
s(10) = R(2) ^ 2 + R(10) ^ 2 + R(18) ^ 2 + R(26) ^ 2 + R(34) ^ 2 + R(42) ^ 2 + R(50) ^ 2 + R(58) ^ 2
s(11) = R(3) ^ 2 + R(11) ^ 2 + R(19) ^ 2 + R(27) ^ 2 + R(35) ^ 2 + R(43) ^ 2 + R(51) ^ 2 + R(59) ^ 2
s(12) = R(4) ^ 2 + R(12) ^ 2 + R(20) ^ 2 + R(28) ^ 2 + R(36) ^ 2 + R(44) ^ 2 + R(52) ^ 2 + R(60) ^ 2
s(13) = R(5) ^ 2 + R(13) ^ 2 + R(21) ^ 2 + R(29) ^ 2 + R(37) ^ 2 + R(45) ^ 2 + R(53) ^ 2 + R(61) ^ 2
s(14) = R(6) ^ 2 + R(14) ^ 2 + R(22) ^ 2 + R(30) ^ 2 + R(38) ^ 2 + R(46) ^ 2 + R(54) ^ 2 + R(62) ^ 2
s(15) = R(7) ^ 2 + R(15) ^ 2 + R(23) ^ 2 + R(31) ^ 2 + R(39) ^ 2 + R(47) ^ 2 + R(55) ^ 2 + R(63) ^ 2
s(16) = R(8) ^ 2 + R(16) ^ 2 + R(24) ^ 2 + R(32) ^ 2 + R(40) ^ 2 + R(48) ^ 2 + R(56) ^ 2 + R(64) ^ 2
s(17) = R(1) ^ 2 + R(10) ^ 2 + R(19) ^ 2 + R(28) ^ 2 + R(37) ^ 2 + R(46) ^ 2 + R(55) ^ 2 + R(64) ^ 2
s(18) = R(8) ^ 2 + R(15) ^ 2 + R(22) ^ 2 + R(29) ^ 2 + R(36) ^ 2 + R(43) ^ 2 + R(50) ^ 2 + R(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 = R(i1)
For i2 = (1 + i1) To 64
If c2 = R(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
End Sub
