' Generates Inlaid Magic Squares of order 8 (Part 2)
' Sub Squares with Different Magic Sums
' Tested with Office 2007 under Windows 7
Sub Priem8k()
Dim a1(1260), b1(187141), b(187141), c(64), a(9), a8(64), s(4)
y = MsgBox("Locked", vbCritical, "Routine Priem8k")
End
n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
' Generate Squares
For j101 = 3280 To 3309 ''510 To 3278
' Read and Assign Center Squares
Pr8 = Sheets("Sqrs3").Cells(j101, 16).Value 'Pair Sum
s8 = 4 * Pr8 'MC8
For i10 = 1 To 4
i30 = Sheets("Sqrs3").Cells(j101, i10).Value
For i20 = 1 To 9
a(i20) = Sheets("Lines3").Cells(i30, i20).Value
Next i20
GoSub 750 'Assign Center Squares
Next i10
GoSub 850 'Check Identical Integers
If fl1 = 0 Then GoTo 500
Rcrd8 = Sheets("Sqrs3").Cells(j101, 17).Value 'Record Border Pairs
If Rcrd8 = 0 Then GoTo 500
' Read MC3's
For i1 = 5 To 8
s(i1 - 4) = 3 * Sheets("Sqrs3").Cells(j101, i1).Value
Next i1
' Block Used Primes
For i1 = 1 To 64
b(a8(i1)) = a8(i1)
Next i1
' Pairs72 Pairs8
nVar1 = Sheets("Pairs8").Cells(Rcrd8, 5).Value ' 9 5
Erase b1
For i1 = 1 To nVar1
x = Sheets("Pairs8").Cells(Rcrd8, 6 + i1).Value ' 9 + i1 6 + i1
b1(x) = x: a1(i1) = x
Next i1
m1 = 1: m2 = nVar1
GoSub 2000 'Select Border
If fl1 = 0 Then GoTo 500
GoSub 850 'Double Check Identical Integers
If fl1 = 1 Then
' n9 = n9 + 1: GoSub 645 'Print Selected Numbers
n9 = n9 + 1: GoSub 650 'Print Composed Squares
Sheets("Sqrs3").Cells(j101, 20).Value = "ok"
End If
500 Erase b, c, a8
Next j101
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine Priem8k")
End
2000 fl1 = 0
For j64 = m1 To m2 'a8(64)
If b(a1(j64)) = 0 Then b(a1(j64)) = a1(j64): c(64) = a1(j64) Else GoTo 640
a8(64) = a1(j64)
a8(1) = s8 / 4 - a8(64): If b(a8(1)) = 0 Then b(a8(1)) = a8(1): c(1) = a8(1) Else GoTo 10
For j63 = m1 To m2 'a8(63)
If b(a1(j63)) = 0 Then b(a1(j63)) = a1(j63): c(63) = a1(j63) Else GoTo 630
a8(63) = a1(j63)
a8(58) = a8(63) - s(3) + s(4)
If a8(58) < a1(m1) Or a8(58) > a1(m2) Then GoTo 580
If b1(a8(58)) = 0 Then GoTo 580
If b(a8(58)) = 0 Then b(a8(58)) = a8(58): c(58) = a8(58) Else GoTo 580
a8(7) = s8 / 4 - a8(63) + s(3) - s(4)
If a8(7) < a1(m1) Or a8(7) > a1(m2) Then GoTo 70
If b1(a8(7)) = 0 Then GoTo 70
If b(a8(7)) = 0 Then b(a8(7)) = a8(7): c(7) = a8(7) Else GoTo 70
a8(2) = s8 / 4 - a8(63): If b(a8(2)) = 0 Then b(a8(2)) = a8(2): c(2) = a8(2) Else GoTo 20
For j62 = m1 To m2 'a8(62)
If b(a1(j62)) = 0 Then b(a1(j62)) = a1(j62): c(62) = a1(j62) Else GoTo 620
a8(62) = a1(j62)
a8(59) = a8(62) - s(3) + s(4)
If a8(59) < a1(m1) Or a8(59) > a1(m2) Then GoTo 590
If b1(a8(59)) = 0 Then GoTo 590
If b(a8(59)) = 0 Then b(a8(59)) = a8(59): c(59) = a8(59) Else GoTo 590
a8(6) = s8 / 4 - a8(62) + s(3) - s(4)
If a8(6) < a1(m1) Or a8(6) > a1(m2) Then GoTo 60
If b1(a8(6)) = 0 Then GoTo 60
If b(a8(6)) = 0 Then b(a8(6)) = a8(6): c(6) = a8(6) Else GoTo 60
a8(3) = s8 / 4 - a8(62): If b(a8(3)) = 0 Then b(a8(3)) = a8(3): c(3) = a8(3) Else GoTo 30
For j61 = m1 To m2 'a8(61)
If b(a1(j61)) = 0 Then b(a1(j61)) = a1(j61): c(61) = a1(j61) Else GoTo 610
a8(61) = a1(j61)
a8(60) = a8(61) - s(3) + s(4)
If a8(60) < a1(m1) Or a8(60) > a1(m2) Then GoTo 600
If b1(a8(60)) = 0 Then GoTo 600
If b(a8(60)) = 0 Then b(a8(60)) = a8(60): c(60) = a8(60) Else GoTo 600
a8(57) = s8 - 2 * a8(61) - 2 * a8(62) - 2 * a8(63) - a8(64) + 3 * s(3) - 3 * s(4)
If a8(57) < a1(m1) Or a8(57) > a1(m2) Then GoTo 570
If b1(a8(57)) = 0 Then GoTo 570
If b(a8(57)) = 0 Then b(a8(57)) = a8(57): c(57) = a8(57) Else GoTo 570
a8(8) = s8 / 4 - a8(57): If b(a8(8)) = 0 Then b(a8(8)) = a8(8): c(8) = a8(8) Else GoTo 80
a8(5) = s8 / 4 - a8(61) + s(3) - s(4)
If a8(5) < a1(m1) Or a8(5) > a1(m2) Then GoTo 50
If b1(a8(5)) = 0 Then GoTo 50
If b(a8(5)) = 0 Then b(a8(5)) = a8(5): c(5) = a8(5) Else GoTo 50
a8(4) = s8 / 4 - a8(61): If b(a8(4)) = 0 Then b(a8(4)) = a8(4): c(4) = a8(4) Else GoTo 40
For j56 = m1 To m2 'a8(56)
If b(a1(j56)) = 0 Then b(a1(j56)) = a1(j56): c(56) = a1(j56) Else GoTo 560
a8(56) = a1(j56)
a8(49) = s8 - a8(56) - s(3) - s(4)
If a8(49) < a1(m1) Or a8(49) > a1(m2) Then GoTo 490
If b1(a8(49)) = 0 Then GoTo 490
If b(a8(49)) = 0 Then b(a8(49)) = a8(49): c(49) = a8(49) Else GoTo 490
a8(16) = -3 * s8 / 4 + a8(56) + s(3) + s(4)
If a8(16) < a1(m1) Or a8(16) > a1(m2) Then GoTo 160
If b1(a8(16)) = 0 Then GoTo 160
If b(a8(16)) = 0 Then b(a8(16)) = a8(16): c(16) = a8(16) Else GoTo 160
a8(9) = s8 / 4 - a8(56): If b(a8(9)) = 0 Then b(a8(9)) = a8(9): c(9) = a8(9) Else GoTo 90
For j48 = m1 To m2 'a8(48)
If b(a1(j48)) = 0 Then b(a1(j48)) = a1(j48): c(48) = a1(j48) Else GoTo 480
a8(48) = a1(j48)
a8(41) = s8 - a8(48) - s(3) - s(4)
If a8(41) < a1(m1) Or a8(41) > a1(m2) Then GoTo 410
If b1(a8(41)) = 0 Then GoTo 410
If b(a8(41)) = 0 Then b(a8(41)) = a8(41): c(41) = a8(41) Else GoTo 410
a8(40) = 2 * s8 - a8(48) - a8(56) - a8(61) - a8(62) - a8(63) - a8(64) - 3 * s(4)
If a8(40) < a1(m1) Or a8(40) > a1(m2) Then GoTo 400
If b1(a8(40)) = 0 Then GoTo 400
If b(a8(40)) = 0 Then b(a8(40)) = a8(40): c(40) = a8(40) Else GoTo 400
a8(33) = s8 - a8(40) - s(3) - s(4)
If a8(33) < a1(m1) Or a8(33) > a1(m2) Then GoTo 330
If b1(a8(33)) = 0 Then GoTo 330
If b(a8(33)) = 0 Then b(a8(33)) = a8(33): c(33) = a8(33) Else GoTo 330
a8(32) = s8 / 4 - a8(33): If b(a8(32)) = 0 Then b(a8(32)) = a8(32): c(32) = a8(32) Else GoTo 320
a8(25) = -s8 / 2 - a8(32) + s(3) + s(4)
If a8(25) < a1(m1) Or a8(25) > a1(m2) Then GoTo 250
If b1(a8(25)) = 0 Then GoTo 250
If b(a8(25)) = 0 Then b(a8(25)) = a8(25): c(25) = a8(25) Else GoTo 250
a8(24) = -3 * s8 / 4 + a8(48) + s(3) + s(4)
If a8(24) < a1(m1) Or a8(24) > a1(m2) Then GoTo 240
If b1(a8(24)) = 0 Then GoTo 240
If b(a8(24)) = 0 Then b(a8(24)) = a8(24): c(24) = a8(24) Else GoTo 240
a8(17) = s8 / 4 - a8(48): If b(a8(17)) = 0 Then b(a8(17)) = a8(17): c(17) = a8(17) Else GoTo 170
fl1 = 1: Return
b(c(17)) = 0: c(17) = 0
170 b(c(24)) = 0: c(24) = 0
240 b(c(25)) = 0: c(25) = 0
250 b(c(32)) = 0: c(32) = 0
320 b(c(33)) = 0: c(33) = 0
330 b(c(40)) = 0: c(40) = 0
400 b(c(41)) = 0: c(41) = 0
410 b(c(48)) = 0: c(48) = 0
480 Next j48
b(c(9)) = 0: c(9) = 0
90 b(c(16)) = 0: c(16) = 0
160 b(c(49)) = 0: c(49) = 0
490 b(c(56)) = 0: c(56) = 0
560 Next j56
b(c(4)) = 0: c(4) = 0
40 b(c(5)) = 0: c(5) = 0
50 b(c(8)) = 0: c(8) = 0
80 b(c(57)) = 0: c(57) = 0
570 b(c(60)) = 0: c(60) = 0
600 b(c(61)) = 0: c(61) = 0
610 Next j61
b(c(3)) = 0: c(3) = 0
30 b(c(6)) = 0: c(6) = 0
60 b(c(59)) = 0: c(59) = 0
590 b(c(62)) = 0: c(62) = 0
620 Next j62
b(c(2)) = 0: c(2) = 0
20 b(c(7)) = 0: c(7) = 0
70 b(c(58)) = 0: c(58) = 0
580 b(c(63)) = 0: c(63) = 0
630 Next j63
b(c(1)) = 0: c(1) = 0
10 b(c(64)) = 0: c(64) = 0
640 Next j64
fl1 = 0
Return
' Assign Sub Squares
750 Select Case i10
Case 1 'Top / Left
a8(10) = a(1): a8(11) = a(2): a8(12) = a(3):
a8(18) = a(4): a8(19) = a(5): a8(20) = a(6):
a8(26) = a(7): a8(27) = a(8): a8(28) = a(9):
Case 2 'Top / Right
a8(13) = a(1): a8(14) = a(2): a8(15) = a(3):
a8(21) = a(4): a8(22) = a(5): a8(23) = a(6):
a8(29) = a(7): a8(30) = a(8): a8(31) = a(9):
Case 3 'Bottom / Left
a8(34) = a(1): a8(35) = a(2): a8(36) = a(3):
a8(42) = a(4): a8(43) = a(5): a8(44) = a(6):
a8(50) = a(7): a8(51) = a(8): a8(52) = a(9):
Case 4 'Bottom / Right
a8(37) = a(1): a8(38) = a(2): a8(39) = a(3):
a8(45) = a(4): a8(46) = a(5): a8(47) = a(6):
a8(53) = a(7): a8(54) = a(8): a8(55) = a(9):
End Select
Return
' Exclude solutions with identical numbers a8()
850 fl1 = 1
For j1 = 1 To 64
a20 = a8(j1): If a20 = 0 Then GoTo 860
For j2 = (1 + j1) To 64
If a20 = a8(j2) Then fl1 = 0: Return
Next j2
860 Next j1
Return
' Print results (selected numbers)
645 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 4 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = "MC = " + CStr(s8)
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a8(i3)
Next i2
Next i1
Return
End Sub
