' Generates Semi Nearly Bimagic Squares of order 7
' Based on Generators of order 7 (7 Bimagic Rows, 1 Bimagic Column)
' Tested with Office 365 under Windows 10
Sub CnstrSqrs7a()
Dim a1(7, 7), a(49), b(49), c(49), s(7)
Dim Chk2(16, 6)
y = MsgBox("Blocked", vbExclamation, "CnstrSqrs7a")
End
ShtNm1 = "GenLns7"
s1 = 175: s2 = 5775
k1 = 1: k2 = 1: n9 = 0
' Define Cases 1 ... 15
Chk2(1, 1) = 0: Chk2(1, 2) = 0: Chk2(1, 3) = 1: Chk2(1, 4) = 1: Chk2(1, 5) = 1: Chk2(1, 6) = 1:
Chk2(2, 1) = 0: Chk2(2, 2) = 1: Chk2(2, 3) = 0: Chk2(2, 4) = 1: Chk2(2, 5) = 1: Chk2(2, 6) = 1:
Chk2(3, 1) = 0: Chk2(3, 2) = 1: Chk2(3, 3) = 1: Chk2(3, 4) = 0: Chk2(3, 5) = 1: Chk2(3, 6) = 1:
Chk2(4, 1) = 0: Chk2(4, 2) = 1: Chk2(4, 3) = 1: Chk2(4, 4) = 1: Chk2(4, 5) = 0: Chk2(4, 6) = 1:
Chk2(5, 1) = 0: Chk2(5, 2) = 1: Chk2(5, 3) = 1: Chk2(5, 4) = 1: Chk2(5, 5) = 1: Chk2(5, 6) = 0:
Chk2(6, 1) = 1: Chk2(6, 2) = 0: Chk2(6, 3) = 0: Chk2(6, 4) = 1: Chk2(6, 5) = 1: Chk2(6, 6) = 1:
Chk2(7, 1) = 1: Chk2(7, 2) = 0: Chk2(7, 3) = 1: Chk2(7, 4) = 0: Chk2(7, 5) = 1: Chk2(7, 6) = 1:
Chk2(8, 1) = 1: Chk2(8, 2) = 0: Chk2(8, 3) = 1: Chk2(8, 4) = 1: Chk2(8, 5) = 0: Chk2(8, 6) = 1:
Chk2(9, 1) = 1: Chk2(9, 2) = 0: Chk2(9, 3) = 1: Chk2(9, 4) = 1: Chk2(9, 5) = 1: Chk2(9, 6) = 0:
Chk2(10, 1) = 1: Chk2(10, 2) = 1: Chk2(10, 3) = 0: Chk2(10, 4) = 0: Chk2(10, 5) = 1: Chk2(10, 6) = 1:
Chk2(11, 1) = 1: Chk2(11, 2) = 1: Chk2(11, 3) = 0: Chk2(11, 4) = 1: Chk2(11, 5) = 0: Chk2(11, 6) = 1:
Chk2(12, 1) = 1: Chk2(12, 2) = 1: Chk2(12, 3) = 0: Chk2(12, 4) = 1: Chk2(12, 5) = 1: Chk2(12, 6) = 0:
Chk2(13, 1) = 1: Chk2(13, 2) = 1: Chk2(13, 3) = 1: Chk2(13, 4) = 0: Chk2(13, 5) = 0: Chk2(13, 6) = 1:
Chk2(14, 1) = 1: Chk2(14, 2) = 1: Chk2(14, 3) = 1: Chk2(14, 4) = 0: Chk2(14, 5) = 1: Chk2(14, 6) = 0:
Chk2(15, 1) = 1: Chk2(15, 2) = 1: Chk2(15, 3) = 1: Chk2(15, 4) = 1: Chk2(15, 5) = 0: Chk2(15, 6) = 0:
' Check Non Existance Semi Bimagic Squares (Case 16)
Chk2(16, 1) = 1: Chk2(16, 2) = 1: Chk2(16, 3) = 1: Chk2(16, 4) = 1: Chk2(16, 5) = 1: Chk2(16, 6) = 1:
t1 = Timer
For j200 = 1 To 15 'Cases 1 ... 15
Cells(1, 1).Value = j200
For j100 = 326 To 487 'Test Batch (Boyer)
Cells(2, 1).Value = j100
Erase a, a1, b
' Read Generator
i1 = 1: i2 = 0
For i3 = 1 To 49
i2 = i2 + 1
If i2 = 8 Then i2 = 1: i1 = i1 + 1
a1(i1, i2) = Sheets(ShtNm1).Cells(j100, i3).Value
Next i3
' Sequence Top Row Case Dependant
a(1) = a1(1, 1):
i2 = 8
For i1 = 1 To 6:
If Chk2(j200, i1) = 0 Then i2 = i2 - 1: a(i2) = a1(1, i1 + 1)
Next i1
i2 = 1
For i1 = 1 To 6:
If Chk2(j200, i1) = 1 Then i2 = i2 + 1: a(i2) = a1(1, i1 + 1)
Next i1
' Left Column
For i1 = 1 To 7: a(7 * (i1 - 1) + 1) = a1(i1, 1): Next i1
' Used Integers
For i1 = 1 To 49: b(a(i1)) = a(i1): Next i1
' Calcualte Columns to ensure Semi Magic (s1)
For j44 = 2 To 7
x = a1(7, j44): If b(x) = 0 Then b(x) = x: c(44) = x Else GoTo 440
a(44) = a1(7, j44)
For j37 = 2 To 7
x = a1(6, j37): If b(x) = 0 Then b(x) = x: c(37) = x Else GoTo 370
a(37) = a1(6, j37)
For j30 = 2 To 7
x = a1(5, j30): If b(x) = 0 Then b(x) = x: c(30) = x Else GoTo 300
a(30) = a1(5, j30)
For j23 = 2 To 7
x = a1(4, j23): If b(x) = 0 Then b(x) = x: c(23) = x Else GoTo 230
a(23) = a1(4, j23)
For j16 = 2 To 7
x = a1(3, j16): If b(x) = 0 Then b(x) = x: c(16) = x Else GoTo 160
a(16) = a1(3, j16)
For j9 = 2 To 7
x = a1(2, j9): If b(x) = 0 Then b(x) = x: c(9) = x Else GoTo 90
a(9) = a1(2, j9)
s11 = a(9) + a(2) + a(16) + a(23) + a(30) + a(37) + a(44)
If s11 <> s1 Then GoTo 85
s21 = a(2) ^ 2 + a(9) ^ 2 + a(16) ^ 2 + a(23) ^ 2 + a(30) ^ 2 + a(37) ^ 2 + a(44) ^ 2
If s21 <> s2 Then GoTo 85
For j45 = 2 To 7
x = a1(7, j45): If b(x) = 0 Then b(x) = x: c(45) = x Else GoTo 450
a(45) = a1(7, j45)
For j38 = 2 To 7
x = a1(6, j38): If b(x) = 0 Then b(x) = x: c(38) = x Else GoTo 380
a(38) = a1(6, j38)
For j31 = 2 To 7
x = a1(5, j31): If b(x) = 0 Then b(x) = x: c(31) = x Else GoTo 310
a(31) = a1(5, j31)
For j24 = 2 To 7
x = a1(4, j24): If b(x) = 0 Then b(x) = x: c(24) = x Else GoTo 241
a(24) = a1(4, j24)
For j17 = 2 To 7
x = a1(3, j17): If b(x) = 0 Then b(x) = x: c(17) = x Else GoTo 170
a(17) = a1(3, j17)
For j10 = 2 To 7
x = a1(2, j10): If b(x) = 0 Then b(x) = x: c(10) = x Else GoTo 100
a(10) = a1(2, j10)
s11 = a(10) + a(3) + a(17) + a(24) + a(31) + a(38) + a(45)
If s11 <> s1 Then GoTo 95
s21 = a(3) ^ 2 + a(10) ^ 2 + a(17) ^ 2 + a(24) ^ 2 + a(31) ^ 2 + a(38) ^ 2 + a(45) ^ 2
If s21 <> s2 Then GoTo 95
For j46 = 2 To 7
x = a1(7, j46): If b(x) = 0 Then b(x) = x: c(46) = x Else GoTo 460
a(46) = a1(7, j46)
For j39 = 2 To 7
x = a1(6, j39): If b(x) = 0 Then b(x) = x: c(39) = x Else GoTo 390
a(39) = a1(6, j39)
For j32 = 2 To 7
x = a1(5, j32): If b(x) = 0 Then b(x) = x: c(32) = x Else GoTo 320
a(32) = a1(5, j32)
For j25 = 2 To 7
x = a1(4, j25): If b(x) = 0 Then b(x) = x: c(25) = x Else GoTo 250
a(25) = a1(4, j25)
For j18 = 2 To 7
x = a1(3, j18): If b(x) = 0 Then b(x) = x: c(18) = x Else GoTo 180
a(18) = a1(3, j18)
For j11 = 2 To 7
x = a1(2, j11): If b(x) = 0 Then b(x) = x: c(11) = x Else GoTo 110
a(11) = a1(2, j11)
s11 = a(11) + a(4) + a(18) + a(25) + a(32) + a(39) + a(46)
If s11 <> s1 Then GoTo 105
s21 = a(4) ^ 2 + a(11) ^ 2 + a(18) ^ 2 + a(25) ^ 2 + a(32) ^ 2 + a(39) ^ 2 + a(46) ^ 2
If s21 <> s2 Then GoTo 105
For j47 = 2 To 7
x = a1(7, j47): If b(x) = 0 Then b(x) = x: c(47) = x Else GoTo 470
a(47) = a1(7, j47)
For j40 = 2 To 7
x = a1(6, j40): If b(x) = 0 Then b(x) = x: c(40) = x Else GoTo 400
a(40) = a1(6, j40)
For j33 = 2 To 7
x = a1(5, j33): If b(x) = 0 Then b(x) = x: c(33) = x Else GoTo 330
a(33) = a1(5, j33)
For j26 = 2 To 7
x = a1(4, j26): If b(x) = 0 Then b(x) = x: c(26) = x Else GoTo 260
a(26) = a1(4, j26)
For j19 = 2 To 7
x = a1(3, j19): If b(x) = 0 Then b(x) = x: c(19) = x Else GoTo 190
a(19) = a1(3, j19)
For j12 = 2 To 7
x = a1(2, j12): If b(x) = 0 Then b(x) = x: c(12) = x Else GoTo 120
a(12) = a1(2, j12)
s12 = a(12) + a(5) + a(19) + a(26) + a(33) + a(40) + a(47)
If s12 <> s1 Then GoTo 115
s21 = a(5) ^ 2 + a(12) ^ 2 + a(19) ^ 2 + a(26) ^ 2 + a(33) ^ 2 + a(40) ^ 2 + a(47) ^ 2
If s21 <> s2 Then GoTo 115
For j48 = 2 To 7
x = a1(7, j48): If b(x) = 0 Then b(x) = x: c(48) = x Else GoTo 480
a(48) = a1(7, j48)
For j41 = 2 To 7
x = a1(6, j41): If b(x) = 0 Then b(x) = x: c(41) = x Else GoTo 410
a(41) = a1(6, j41)
For j34 = 2 To 7
x = a1(5, j34): If b(x) = 0 Then b(x) = x: c(34) = x Else GoTo 340
a(34) = a1(5, j34)
For j27 = 2 To 7
x = a1(4, j27): If b(x) = 0 Then b(x) = x: c(27) = x Else GoTo 270
a(27) = a1(4, j27)
For j20 = 2 To 7
x = a1(3, j20): If b(x) = 0 Then b(x) = x: c(20) = x Else GoTo 200
a(20) = a1(3, j20)
For j13 = 2 To 7
x = a1(2, j13): If b(x) = 0 Then b(x) = x: c(13) = x Else GoTo 130
a(13) = a1(2, j13)
s12 = a(13) + a(6) + a(20) + a(27) + a(34) + a(41) + a(48)
If s12 <> s1 Then GoTo 125
'' s21 = a(6) ^ 2 + a(13) ^ 2 + a(20) ^ 2 + a(27) ^ 2 + a(34) ^ 2 + a(41) ^ 2 + a(48) ^ 2
'' If s21 <> s2 Then GoTo 125
a(14) = s1 - a(8) - a(9) - a(10) - a(11) - a(12) - a(13)
a(21) = s1 - a(15) - a(16) - a(17) - a(18) - a(19) - a(20)
a(28) = s1 - a(22) - a(23) - a(24) - a(25) - a(26) - a(27)
a(35) = s1 - a(29) - a(30) - a(31) - a(32) - a(33) - a(34)
a(42) = s1 - a(36) - a(37) - a(38) - a(39) - a(40) - a(41)
a(49) = s1 - a(43) - a(44) - a(45) - a(46) - a(47) - a(48)
'' s21 = a(7) ^ 2 + a(14) ^ 2 + a(21) ^ 2 + a(28) ^ 2 + a(35) ^ 2 + a(42) ^ 2 + a(49) ^ 2
'' If s21 <> s2 Then GoTo 125
n9 = n9 + 1: GoSub 650 'Print Squares
125 b(c(13)) = 0: c(13) = 0
130 Next j13
b(c(20)) = 0: c(20) = 0
200 Next j20
b(c(27)) = 0: c(27) = 0
270 Next j27
b(c(34)) = 0: c(34) = 0
340 Next j34
b(c(41)) = 0: c(41) = 0
410 Next j41
b(c(48)) = 0: c(48) = 0
480 Next j48
115 b(c(12)) = 0: c(12) = 0
120 Next j12
b(c(19)) = 0: c(19) = 0
190 Next j19
b(c(26)) = 0: c(26) = 0
260 Next j26
b(c(33)) = 0: c(33) = 0
330 Next j33
b(c(40)) = 0: c(40) = 0
400 Next j40
b(c(47)) = 0: c(47) = 0
470 Next j47
105 b(c(11)) = 0: c(11) = 0
110 Next j11
b(c(18)) = 0: c(18) = 0
180 Next j18
b(c(25)) = 0: c(25) = 0
250 Next j25
b(c(32)) = 0: c(32) = 0
320 Next j32
b(c(39)) = 0: c(39) = 0
390 Next j39
b(c(46)) = 0: c(46) = 0
460 Next j46
95 b(c(10)) = 0: c(10) = 0
100 Next j10
b(c(17)) = 0: c(17) = 0
170 Next j17
b(c(24)) = 0: c(24) = 0
241 Next j24
b(c(31)) = 0: c(31) = 0
310 Next j31
b(c(38)) = 0: c(38) = 0
380 Next j38
b(c(45)) = 0: c(45) = 0
450 Next j45
85 b(c(9)) = 0: c(9) = 0
90 Next j9
b(c(16)) = 0: c(16) = 0
160 Next j16
b(c(23)) = 0: c(23) = 0
230 Next j23
b(c(30)) = 0: c(30) = 0
300 Next j30
b(c(37)) = 0: c(37) = 0
370 Next j37
b(c(44)) = 0: c(44) = 0
440 Next j44
1000 Next j100
2000 Next j200
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs7a")
End
' Print Results (Lines)
640 i3 = 0
For i3 = 1 To 49
Cells(n9, i3).Value = a(i3)
Next i3
Cells(n9, 50).Value = j100
Return
' Print Results (Squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 8: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 8
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = j100
i3 = 0
For i1 = 1 To 7
For i2 = 1 To 7
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
