' Generates Bimagic Squares of order 9, Magic Sum 369, Tarry-Cazalas
' Based on Arithmetic Series
' Tested with Office 365 under Windows 10
Sub CnstrSqrs48()
' Check Determinant
Dim r1(4), r2(4), s1(4), s2(4), d9(6)
Dim Sr1s1(4), Sr2s2(4), Vr1s1(4), Vr2s2(4)
' Construct and Check Bimagic Squares
Dim M(4, 9, 9), Txt9(9, 9), a9(81), s(20)
y = MsgBox("Blocked", vbCritical, "CnstrSqrs48")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
For j1 = 2 To 673
For i1 = 1 To 4: r1(i1) = Sheets("Series9").Cells(j1, i1 + 7).Value: Next i1
For i1 = 1 To 4: r2(i1) = Sheets("Series9").Cells(j1, i1 + 13).Value: Next i1
d11 = Sheets("Series9").Cells(j1, 12).Value
d21 = Sheets("Series9").Cells(j1, 18).Value
For j2 = j1 + 1 To 673
For i1 = 1 To 4: s1(i1) = Sheets("Series9").Cells(j2, i1 + 7).Value: Next i1
For i1 = 1 To 4: s2(i1) = Sheets("Series9").Cells(j2, i1 + 13).Value: Next i1
d12 = Sheets("Series9").Cells(j2, 12).Value
d22 = Sheets("Series9").Cells(j2, 18).Value
If d12 <= d11 Then GoTo 20 'Prevent Transposition
If d11 = d12 Or d11 = d22 Then GoTo 20
If d21 = d12 Or d21 = d22 Then GoTo 20
GoSub 100 'r1() + s1(), r2() + s2()
'r1() - s1(), r2() - s2()
' Check Determinanten
Erase d9
d9(1) = Sr1s1(1) * Sr2s2(2) - Sr1s1(2) * Sr2s2(1)
d9(2) = Sr1s1(1) * Sr2s2(3) - Sr1s1(3) * Sr2s2(1)
d9(3) = Sr1s1(1) * Sr2s2(4) - Sr1s1(4) * Sr2s2(1)
d9(4) = Sr1s1(2) * Sr2s2(3) - Sr1s1(3) * Sr2s2(2)
d9(5) = Sr1s1(2) * Sr2s2(4) - Sr1s1(4) * Sr2s2(2)
d9(6) = Sr1s1(3) * Sr2s2(4) - Sr1s1(4) * Sr2s2(3)
Erase d9
d9(1) = Vr1s1(1) * Vr2s2(2) - Vr1s1(2) * Vr2s2(1)
d9(2) = Vr1s1(1) * Vr2s2(3) - Vr1s1(3) * Vr2s2(1)
d9(3) = Vr1s1(1) * Vr2s2(4) - Vr1s1(4) * Vr2s2(1)
d9(4) = Vr1s1(2) * Vr2s2(3) - Vr1s1(3) * Vr2s2(2)
d9(5) = Vr1s1(2) * Vr2s2(4) - Vr1s1(4) * Vr2s2(2)
d9(6) = Vr1s1(3) * Vr2s2(4) - Vr1s1(4) * Vr2s2(3)
For i1 = 1 To 6
If d9(i1) = 0 Then GoTo 20
Next i1
' Compose Square 9 x 9
Erase M
For i1 = 1 To 4
M(i1, 1, 1) = 0
M(i1, 1, 2) = r1(i1)
M(i1, 2, 1) = s1(i1)
M(i1, 1, 4) = r2(i1)
M(i1, 4, 1) = s2(i1)
Next i1
' Complete Row 1 (top)
For i1 = 1 To 4
x = 2 * M(i1, 1, 2)
While x > 2
x = x - 3
Wend
M(i1, 1, 3) = x
For i2 = 5 To 9
x = M(i1, 1, 4) + M(i1, 1, i2 - 3)
While x > 2
x = x - 3
Wend
M(i1, 1, i2) = x
Next i2
Next i1
' Complete Column 1(left)
For i1 = 1 To 4
x = 2 * M(i1, 2, 1)
While x > 2
x = x - 3
Wend
M(i1, 3, 1) = x
For i2 = 5 To 9
x = M(i1, 4, 1) + M(i1, i2 - 3, 1)
While x > 2
x = x - 3
Wend
M(i1, i2, 1) = x
Next i2
Next i1
' Complete Rows 2 to 9
For i1 = 1 To 4
For i2 = 2 To 9 'Rows
For i3 = 2 To 9 'Columns
x = M(i1, 1, i3) + M(i1, i2, 1)
While x > 2
x = x - 3
Wend
M(i1, i2, i3) = x
Next i3
Next i2
Next i1
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
a9(i3) = 27 * M(1, i1, i2) + 9 * M(2, i1, i2) + 3 * M(3, i1, i2) + M(4, i1, i2) + 1
Next i2
Next i1
' Back Checks
GoSub 800: If fl1 = 0 Then GoTo 20 'Identical Number
GoSub 850: If fl1 = 0 Then GoTo 20 'Magic Sum
GoSub 900: If fl1 = 0 Then GoTo 20 'Bimagic Sum
'' GoSub 500 'Compose Result
''n9 = n9 + 1: GoSub 650 'Print Result 1
''n9 = n9 + 1: GoSub 750 'Print Result 2 (Squares)
n9 = n9 + 1: GoSub 750 'Print Result 2 (Lines)
''n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
20 Next j2
10 Next j1
t2 = Timer
y = MsgBox(CStr(n9) + " Solutons in " + CStr(t2 - t1) + "sec", 0, "CnstrSqrs48")
End
' r1 + s1, r1 - s1, r2 + s2, r2 - s2
100
For i1 = 1 To 4
Sr1s1(i1) = (r1(i1) + s1(i1))
While Sr1s1(i1) > 2
Sr1s1(i1) = Sr1s1(i1) - 3
Wend
Sr2s2(i1) = (r2(i1) + s2(i1))
While Sr2s2(i1) > 2
Sr2s2(i1) = Sr2s2(i1) - 3
Wend
Vr1s1(i1) = (r1(i1) - s1(i1))
While Vr1s1(i1) < 0
Vr1s1(i1) = Vr1s1(i1) + 3
Wend
Vr2s2(i1) = (r2(i1) - s2(i1))
While Vr2s2(i1) < 0
Vr2s2(i1) = Vr2s2(i1) + 3
Wend
Next i1
Return
' Compose Result
500
For i1 = 1 To 9
For i2 = 1 To 9
t9 = ""
For i3 = 1 To 4
t9 = t9 + CStr(M(i3, i1, i2))
Next i3
Txt9(i1, i2) = t9
Next i2
Next i1
Return
' Print results (squares 1)
650 n1 = n1 + 1
If n1 = 4 Then
n1 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
Cells(k1 + i1, k2 + i2).Value = "'" + Txt9(i1, i2)
Next i2
Next i1
Return
' Print results (lines 2)
760
For i1 = 1 To 81
Cells(n9, i1).Value = a9(i1)
Next i1
Cells(n9, 82).Value = n9
Cells(1, 83).Value = n9
Return
' Print results (squares 2)
750 n1 = n1 + 1
If n1 = 4 Then
n1 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a9(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers
800 fl1 = 1
For j10 = 1 To 81
c2 = a9(j10)
For j20 = (1 + j10) To 81
If c2 = a9(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Check Magic Sum
850 fl1 = 1
s(1) = a9(1) + a9(2) + a9(3) + a9(4) + a9(5) + a9(6) + a9(7) + a9(8) + a9(9)
s(2) = a9(10) + a9(11) + a9(12) + a9(13) + a9(14) + a9(15) + a9(16) + a9(17) + a9(18)
s(3) = a9(19) + a9(20) + a9(21) + a9(22) + a9(23) + a9(24) + a9(25) + a9(26) + a9(27)
s(4) = a9(28) + a9(29) + a9(30) + a9(31) + a9(32) + a9(33) + a9(34) + a9(35) + a9(36)
s(5) = a9(37) + a9(38) + a9(39) + a9(40) + a9(41) + a9(42) + a9(43) + a9(44) + a9(45)
s(6) = a9(46) + a9(47) + a9(48) + a9(49) + a9(50) + a9(51) + a9(52) + a9(53) + a9(54)
s(7) = a9(55) + a9(56) + a9(57) + a9(58) + a9(59) + a9(60) + a9(61) + a9(62) + a9(63)
s(8) = a9(64) + a9(65) + a9(66) + a9(67) + a9(68) + a9(69) + a9(70) + a9(71) + a9(72)
s(9) = a9(73) + a9(74) + a9(75) + a9(76) + a9(77) + a9(78) + a9(79) + a9(80) + a9(81)
s(10) = a9(1) + a9(10) + a9(19) + a9(28) + a9(37) + a9(46) + a9(55) + a9(64) + a9(73)
s(11) = a9(2) + a9(11) + a9(20) + a9(29) + a9(38) + a9(47) + a9(56) + a9(65) + a9(74)
s(12) = a9(3) + a9(12) + a9(21) + a9(30) + a9(39) + a9(48) + a9(57) + a9(66) + a9(75)
s(13) = a9(4) + a9(13) + a9(22) + a9(31) + a9(40) + a9(49) + a9(58) + a9(67) + a9(76)
s(14) = a9(5) + a9(14) + a9(23) + a9(32) + a9(41) + a9(50) + a9(59) + a9(68) + a9(77)
s(15) = a9(6) + a9(15) + a9(24) + a9(33) + a9(42) + a9(51) + a9(60) + a9(69) + a9(78)
s(16) = a9(7) + a9(16) + a9(25) + a9(34) + a9(43) + a9(52) + a9(61) + a9(70) + a9(79)
s(17) = a9(8) + a9(17) + a9(26) + a9(35) + a9(44) + a9(53) + a9(62) + a9(71) + a9(80)
s(18) = a9(9) + a9(18) + a9(27) + a9(36) + a9(45) + a9(54) + a9(63) + a9(72) + a9(81)
s(19) = a9(1) + a9(11) + a9(21) + a9(31) + a9(41) + a9(51) + a9(61) + a9(71) + a9(81)
s(20) = a9(73) + a9(65) + a9(57) + a9(49) + a9(41) + a9(33) + a9(25) + a9(17) + a9(9)
' Regular Sub Squares (Optional)
s(21) = a9(1) + a9(2) + a9(3) + a9(10) + a9(11) + a9(12) + a9(19) + a9(20) + a9(21)
s(22) = a9(4) + a9(5) + a9(6) + a9(13) + a9(14) + a9(15) + a9(22) + a9(23) + a9(24)
s(23) = a9(7) + a9(8) + a9(9) + a9(16) + a9(17) + a9(18) + a9(25) + a9(26) + a9(27)
s(24) = a9(28) + a9(29) + a9(30) + a9(37) + a9(38) + a9(39) + a9(46) + a9(47) + a9(48)
s(25) = a9(31) + a9(32) + a9(33) + a9(40) + a9(41) + a9(42) + a9(49) + a9(50) + a9(51)
s(26) = a9(34) + a9(35) + a9(36) + a9(43) + a9(44) + a9(45) + a9(52) + a9(53) + a9(54)
s(27) = a9(55) + a9(56) + a9(57) + a9(64) + a9(65) + a9(66) + a9(73) + a9(74) + a9(75)
s(28) = a9(58) + a9(59) + a9(60) + a9(67) + a9(68) + a9(69) + a9(76) + a9(77) + a9(78)
s(29) = a9(61) + a9(62) + a9(63) + a9(70) + a9(71) + a9(72) + a9(79) + a9(80) + a9(81)
For i1 = 1 To 29 ''20
If s(i1) <> 369 Then fl1 = 0: Return
Next i1
Return
' Check Bimagic Sum
900 fl1 = 1:
s(1) = a9(1)^2 + a9(2)^2 + a9(3)^2 + a9(4)^2 + a9(5)^2 + a9(6)^2 + a9(7)^2 + a9(8)^2 + a9(9)^2
s(2) = a9(10)^2 + a9(11)^2 + a9(12)^2 + a9(13)^2 + a9(14)^2 + a9(15)^2 + a9(16)^2 + a9(17)^2 + a9(18)^2
s(3) = a9(19)^2 + a9(20)^2 + a9(21)^2 + a9(22)^2 + a9(23)^2 + a9(24)^2 + a9(25)^2 + a9(26)^2 + a9(27)^2
s(4) = a9(28)^2 + a9(29)^2 + a9(30)^2 + a9(31)^2 + a9(32)^2 + a9(33)^2 + a9(34)^2 + a9(35)^2 + a9(36)^2
s(5) = a9(37)^2 + a9(38)^2 + a9(39)^2 + a9(40)^2 + a9(41)^2 + a9(42)^2 + a9(43)^2 + a9(44)^2 + a9(45)^2
s(6) = a9(46)^2 + a9(47)^2 + a9(48)^2 + a9(49)^2 + a9(50)^2 + a9(51)^2 + a9(52)^2 + a9(53)^2 + a9(54)^2
s(7) = a9(55)^2 + a9(56)^2 + a9(57)^2 + a9(58)^2 + a9(59)^2 + a9(60)^2 + a9(61)^2 + a9(62)^2 + a9(63)^2
s(8) = a9(64)^2 + a9(65)^2 + a9(66)^2 + a9(67)^2 + a9(68)^2 + a9(69)^2 + a9(70)^2 + a9(71)^2 + a9(72)^2
s(9) = a9(73)^2 + a9(74)^2 + a9(75)^2 + a9(76)^2 + a9(77)^2 + a9(78)^2 + a9(79)^2 + a9(80)^2 + a9(81)^2
s(10) = a9(1)^2 + a9(10)^2 + a9(19)^2 + a9(28)^2 + a9(37)^2 + a9(46)^2 + a9(55)^2 + a9(64)^2 + a9(73)^2
s(11) = a9(2)^2 + a9(11)^2 + a9(20)^2 + a9(29)^2 + a9(38)^2 + a9(47)^2 + a9(56)^2 + a9(65)^2 + a9(74)^2
s(12) = a9(3)^2 + a9(12)^2 + a9(21)^2 + a9(30)^2 + a9(39)^2 + a9(48)^2 + a9(57)^2 + a9(66)^2 + a9(75)^2
s(13) = a9(4)^2 + a9(13)^2 + a9(22)^2 + a9(31)^2 + a9(40)^2 + a9(49)^2 + a9(58)^2 + a9(67)^2 + a9(76)^2
s(14) = a9(5)^2 + a9(14)^2 + a9(23)^2 + a9(32)^2 + a9(41)^2 + a9(50)^2 + a9(59)^2 + a9(68)^2 + a9(77)^2
s(15) = a9(6)^2 + a9(15)^2 + a9(24)^2 + a9(33)^2 + a9(42)^2 + a9(51)^2 + a9(60)^2 + a9(69)^2 + a9(78)^2
s(16) = a9(7)^2 + a9(16)^2 + a9(25)^2 + a9(34)^2 + a9(43)^2 + a9(52)^2 + a9(61)^2 + a9(70)^2 + a9(79)^2
s(17) = a9(8)^2 + a9(17)^2 + a9(26)^2 + a9(35)^2 + a9(44)^2 + a9(53)^2 + a9(62)^2 + a9(71)^2 + a9(80)^2
s(18) = a9(9)^2 + a9(18)^2 + a9(27)^2 + a9(36)^2 + a9(45)^2 + a9(54)^2 + a9(63)^2 + a9(72)^2 + a9(81)^2
s(19) = a9(1)^2 + a9(11)^2 + a9(21)^2 + a9(31)^2 + a9(41)^2 + a9(51)^2 + a9(61)^2 + a9(71)^2 + a9(81)^2
s(20) = a9(73)^2 + a9(65)^2 + a9(57)^2 + a9(49)^2 + a9(41)^2 + a9(33)^2 + a9(25)^2 + a9(17)^2 + a9(9)^2
' Regular Sub Squares (Optional)
s(21) = a9(1)^2 + a9(2)^2 + a9(3)^2 + a9(10)^2 + a9(11)^2 + a9(12)^2 + a9(19)^2 + a9(20)^2 + a9(21)^2
s(22) = a9(4)^2 + a9(5)^2 + a9(6)^2 + a9(13)^2 + a9(14)^2 + a9(15)^2 + a9(22)^2 + a9(23)^2 + a9(24)^2
s(23) = a9(7)^2 + a9(8)^2 + a9(9)^2 + a9(16)^2 + a9(17)^2 + a9(18)^2 + a9(25)^2 + a9(26)^2 + a9(27)^2
s(24) = a9(28)^2 + a9(29)^2 + a9(30)^2 + a9(37)^2 + a9(38)^2 + a9(39)^2 + a9(46)^2 + a9(47)^2 + a9(48)^2
s(25) = a9(31)^2 + a9(32)^2 + a9(33)^2 + a9(40)^2 + a9(41)^2 + a9(42)^2 + a9(49)^2 + a9(50)^2 + a9(51)^2
s(26) = a9(34)^2 + a9(35)^2 + a9(36)^2 + a9(43)^2 + a9(44)^2 + a9(45)^2 + a9(52)^2 + a9(53)^2 + a9(54)^2
s(27) = a9(55)^2 + a9(56)^2 + a9(57)^2 + a9(64)^2 + a9(65)^2 + a9(66)^2 + a9(73)^2 + a9(74)^2 + a9(75)^2
s(28) = a9(58)^2 + a9(59)^2 + a9(60)^2 + a9(67)^2 + a9(68)^2 + a9(69)^2 + a9(76)^2 + a9(77)^2 + a9(78)^2
s(29) = a9(61)^2 + a9(62)^2 + a9(63)^2 + a9(70)^2 + a9(71)^2 + a9(72)^2 + a9(79)^2 + a9(80)^2 + a9(81)^2
For i1 = 1 To 29 ''20
If s(i1) <> 20049 Then fl1 = 0: Return
Next i1
Return
End Sub
