' Generates Inlaid Magic Squares of order 10 (Part 2)
' Sub Squares with Different Magic Sums
' Tested with Office 2007 under Windows 7
Sub Priem10k()
Dim a1(1260), b1(187141), b(187141), c(100), a(25), a10(100), s(4)
y = MsgBox("Locked", vbCritical, "Routine Priem10k")
End
n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
' Generate Squares
For j101 = 142 To 154
' Read and Assign Center Squares
Pr10 = Sheets("Sqrs4").Cells(j101, 16).Value 'Pair Sum
s10 = 5 * Pr10 'MC10
For i10 = 1 To 4
i30 = Sheets("Sqrs4").Cells(j101, i10).Value
For i20 = 1 To 16
a(i20) = Sheets("Lines4").Cells(i30, i20).Value
Next i20
GoSub 750 'Assign Center Squares to a10()
Next i10
GoSub 1850 'Check Identical Integers
If fl1 = 0 Then GoTo 1200
Rcrd10 = Sheets("Sqrs4").Cells(j101, 17).Value 'Record Border Pairs
If Rcrd10 = 0 Then GoTo 1200
' Read MC5's
For i1 = 5 To 8
s(i1 - 4) = Sheets("Sqrs4").Cells(j101, i1).Value
Next i1
' Read Border Primes
' Pairs72 Pairs8 Pairs6
nVar1 = Sheets("Pairs6").Cells(Rcrd10, 5).Value ' 9 5 5
If nVar1 < 100 Then GoTo 1200
Erase b1
For i1 = 1 To nVar1
x = Sheets("Pairs6").Cells(Rcrd10, 10 + i1).Value ' 9 + i1 6 + i1 10 + i1
b1(x) = x
Next i1
pMax = Sheets("Pairs6").Cells(Rcrd10, 10 + nVar1).Value
' Remove used Primes
For i1 = 1 To 100
b1(a10(i1)) = 0
If Pr10 - a10(i1) > 0 Then
b1(Pr10 - a10(i1)) = 0
End If
Next i1
' Restore available pairs in a1()
n10 = 0
For j1 = 1 To pMax
If b1(j1) <> 0 Then
n10 = n10 + 1
a1(n10) = b1(j1)
End If
Next j1
m1 = 1: m2 = n10: n10 = 0
If a1(1) = 1 Then m1 = 2: m2 = m2 - 1
GoSub 2000 'Select Border
If fl1 = 0 Then GoTo 1200
GoSub 1850 '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("Sqrs4").Cells(j101, 20).Value = "ok"
End If
1200 Erase b, c, a10
Next j101
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine Priem10k")
End
' Assign Sub Squares
750 Select Case i10
Case 1 'Top / Left
a10(12) = a(1): a10(13) = a(2): a10(14) = a(3): a10(15) = a(4):
a10(22) = a(5): a10(23) = a(6): a10(24) = a(7): a10(25) = a(8):
a10(32) = a(9): a10(33) = a(10): a10(34) = a(11): a10(35) = a(12):
a10(42) = a(13): a10(43) = a(14): a10(44) = a(15): a10(45) = a(16):
Case 2 'Top / Right
a10(16) = a(1): a10(17) = a(2): a10(18) = a(3): a10(19) = a(4):
a10(26) = a(5): a10(27) = a(6): a10(28) = a(7): a10(29) = a(8):
a10(36) = a(9): a10(37) = a(10): a10(38) = a(11): a10(39) = a(12):
a10(46) = a(13): a10(47) = a(14): a10(48) = a(15): a10(49) = a(16):
Case 3 'Bottom / Left
a10(52) = a(1): a10(53) = a(2): a10(54) = a(3): a10(55) = a(4):
a10(62) = a(5): a10(63) = a(6): a10(64) = a(7): a10(65) = a(8):
a10(72) = a(9): a10(73) = a(10): a10(74) = a(11): a10(75) = a(12):
a10(82) = a(13): a10(83) = a(14): a10(84) = a(15): a10(85) = a(16):
Case 4 'Bottom / Right
a10(56) = a(1): a10(57) = a(2): a10(58) = a(3): a10(59) = a(4):
a10(66) = a(5): a10(67) = a(6): a10(68) = a(7): a10(69) = a(8):
a10(76) = a(9): a10(77) = a(10): a10(78) = a(11): a10(79) = a(12):
a10(86) = a(13): a10(87) = a(14): a10(88) = a(15): a10(89) = a(16):
End Select
Return
' Exclude solutions with identical numbers a10()
1850 fl1 = 1
For j1 = 1 To 100
a20 = a10(j1): If a20 = 0 Then GoTo 1860
For j2 = (1 + j1) To 100
If a20 = a10(j2) Then fl1 = 0: Return
Next j2
1860 Next j1
Return
' Print results (selected numbers)
645 For i1 = 1 To 100
Cells(n9, i1).Value = a10(i1)
Next i1
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = "MC = " + CStr(s10)
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a10(i3)
Next i2
Next i1
Return
' Select Border
2000 fl1 = 0
t11 = Timer 'Time Out
For j100 = m1 To m2 'a10(100)
If b1(a1(j100)) = 0 Then GoTo 1000
If b(a1(j100)) = 0 Then b(a1(j100)) = a1(j100): c(100) = a1(j100) Else GoTo 1000
a10(100) = a1(j100)
a10(1) = Pr10 - a10(100): If b(a10(1)) = 0 Then b(a10(1)) = a10(1): c(1) = a10(1) Else GoTo 10
For j99 = m1 To m2 'a10(99)
If b1(a1(j99)) = 0 Then GoTo 990
If b(a1(j99)) = 0 Then b(a1(j99)) = a1(j99): c(99) = a1(j99) Else GoTo 990
a10(99) = a1(j99)
a10(92) = a10(99) - s(3) + s(4)
If a10(92) < a1(m1) Or a10(92) > a1(m2) Then GoTo 920
If b1(a10(92)) = 0 Then GoTo 920
If b(a10(92)) = 0 Then b(a10(92)) = a10(92): c(92) = a10(92) Else GoTo 920
a10(9) = Pr10 - a10(92): If b(a10(9)) = 0 Then b(a10(9)) = a10(9): c(9) = a10(9) Else GoTo 90
a10(2) = Pr10 - a10(99): If b(a10(2)) = 0 Then b(a10(2)) = a10(2): c(2) = a10(2) Else GoTo 20
For j98 = m1 To m2 'a10(98)
If b1(a1(j98)) = 0 Then GoTo 980
If b(a1(j98)) = 0 Then b(a1(j98)) = a1(j98): c(98) = a1(j98) Else GoTo 980
a10(98) = a1(j98)
t12 = Timer: t13 = t12 - t11 'Time Out
If t13 > 10 Then fl1 = 0: Return 'Time Out, Try Next
a10(93) = a10(98) - s(3) + s(4)
If a10(93) < a1(m1) Or a10(93) > a1(m2) Then GoTo 930
If b1(a10(93)) = 0 Then GoTo 930
If b(a10(93)) = 0 Then b(a10(93)) = a10(93): c(93) = a10(93) Else GoTo 930
a10(8) = Pr10 - a10(93): If b(a10(8)) = 0 Then b(a10(8)) = a10(8): c(8) = a10(8) Else GoTo 80
a10(3) = Pr10 - a10(98): If b(a10(3)) = 0 Then b(a10(3)) = a10(3): c(3) = a10(3) Else GoTo 30
For j97 = m1 To m2 'a10(97)
If b1(a1(j97)) = 0 Then GoTo 970
If b(a1(j97)) = 0 Then b(a1(j97)) = a1(j97): c(97) = a1(j97) Else GoTo 970
a10(97) = a1(j97)
a10(94) = a10(97) - s(3) + s(4)
If a10(94) < a1(m1) Or a10(94) > a1(m2) Then GoTo 940
If b1(a10(94)) = 0 Then GoTo 940
If b(a10(94)) = 0 Then b(a10(94)) = a10(94): c(94) = a10(94) Else GoTo 940
a10(7) = Pr10 - a10(94): If b(a10(7)) = 0 Then b(a10(7)) = a10(7): c(7) = a10(7) Else GoTo 70
a10(4) = Pr10 - a10(97): If b(a10(4)) = 0 Then b(a10(4)) = a10(4): c(4) = a10(4) Else GoTo 40
For j96 = m1 To m2 'a10(96)
If b1(a1(j96)) = 0 Then GoTo 960
If b(a1(j96)) = 0 Then b(a1(j96)) = a1(j96): c(96) = a1(j96) Else GoTo 960
a10(96) = a1(j96)
a10(95) = a10(96) - s(3) + s(4)
If a10(95) < a1(m1) Or a10(95) > a1(m2) Then GoTo 950
If b1(a10(95)) = 0 Then GoTo 950
If b(a10(95)) = 0 Then b(a10(95)) = a10(95): c(95) = a10(95) Else GoTo 950
a10(91) = s10 - 2 * a10(96) - 2 * a10(97) - 2 * a10(98) - 2 * a10(99) - a10(100) + 4 * s(3) - 4 * s(4)
If a10(91) < a1(m1) Or a10(91) > a1(m2) Then GoTo 910
If b1(a10(91)) = 0 Then GoTo 910
If b(a10(91)) = 0 Then b(a10(91)) = a10(91): c(91) = a10(91) Else GoTo 910
a10(10) = Pr10 - a10(91): If b(a10(10)) = 0 Then b(a10(10)) = a10(10): c(10) = a10(10) Else GoTo 100
a10(6) = Pr10 - a10(95): If b(a10(6)) = 0 Then b(a10(6)) = a10(6): c(6) = a10(6) Else GoTo 60
a10(5) = Pr10 - a10(96): If b(a10(5)) = 0 Then b(a10(5)) = a10(5): c(5) = a10(5) Else GoTo 50
For j90 = m1 To m2 'a10(90)
If b1(a1(j90)) = 0 Then GoTo 900
If b(a1(j90)) = 0 Then b(a1(j90)) = a1(j90): c(90) = a1(j90) Else GoTo 900
a10(90) = a1(j90)
a10(81) = s10 - a10(90) - s(3) - s(4)
If a10(81) < a1(m1) Or a10(81) > a1(m2) Then GoTo 810
If b1(a10(81)) = 0 Then GoTo 810
If b(a10(81)) = 0 Then b(a10(81)) = a10(81): c(81) = a10(81) Else GoTo 810
a10(20) = Pr10 - a10(81): If b(a10(20)) = 0 Then b(a10(20)) = a10(20): c(20) = a10(20) Else GoTo 200
a10(11) = Pr10 - a10(90): If b(a10(11)) = 0 Then b(a10(11)) = a10(11): c(11) = a10(11) Else GoTo 110
For j80 = m1 To m2 'a10(80)
If b1(a1(j80)) = 0 Then GoTo 800
If b(a1(j80)) = 0 Then b(a1(j80)) = a1(j80): c(80) = a1(j80) Else GoTo 800
a10(80) = a1(j80)
a10(71) = s10 - a10(80) - s(3) - s(4)
If a10(71) < a1(m1) Or a10(71) > a1(m2) Then GoTo 710
If b1(a10(71)) = 0 Then GoTo 710
If b(a10(71)) = 0 Then b(a10(71)) = a10(71): c(71) = a10(71) Else GoTo 710
a10(30) = Pr10 - a10(71): If b(a10(30)) = 0 Then b(a10(30)) = a10(30): c(30) = a10(30) Else GoTo 300
a10(21) = Pr10 - a10(80): If b(a10(21)) = 0 Then b(a10(21)) = a10(21): c(21) = a10(21) Else GoTo 210
For j70 = m1 To m2 'a10(70)
If b1(a1(j70)) = 0 Then GoTo 700
If b(a1(j70)) = 0 Then b(a1(j70)) = a1(j70): c(70) = a1(j70) Else GoTo 700
a10(70) = a1(j70)
a10(61) = s10 - a10(70) - s(3) - s(4)
If a10(61) < a1(m1) Or a10(61) > a1(m2) Then GoTo 610
If b1(a10(61)) = 0 Then GoTo 610
If b(a10(61)) = 0 Then b(a10(61)) = a10(61): c(61) = a10(61) Else GoTo 610
a10(60) = 5*s10/2-a10(70)-a10(80)-a10(90)-a10(96)-a10(97)-a10(98)-a10(99)-a10(100)-4*s(4)
If a10(60) < a1(m1) Or a10(60) > a1(m2) Then GoTo 600
If b1(a10(60)) = 0 Then GoTo 600
If b(a10(60)) = 0 Then b(a10(60)) = a10(60): c(60) = a10(60) Else GoTo 600
a10(51) = s10 - a10(60) - s(3) - s(4)
If a10(51) < a1(m1) Or a10(51) > a1(m2) Then GoTo 510
If b1(a10(51)) = 0 Then GoTo 510
If b(a10(51)) = 0 Then b(a10(51)) = a10(51): c(51) = a10(51) Else GoTo 510
a10(50) = Pr10 - a10(51): If b(a10(50)) = 0 Then b(a10(50)) = a10(50): c(50) = a10(50) Else GoTo 500
a10(41) = Pr10 - a10(60): If b(a10(41)) = 0 Then b(a10(41)) = a10(41): c(41) = a10(41) Else GoTo 410
a10(40) = Pr10 - a10(61): If b(a10(40)) = 0 Then b(a10(40)) = a10(40): c(40) = a10(40) Else GoTo 400
a10(31) = Pr10 - a10(70): If b(a10(31)) = 0 Then b(a10(31)) = a10(31): c(31) = a10(31) Else GoTo 310
fl1 = 1: Return
b(c(31)) = 0: c(31) = 0
310 b(c(40)) = 0: c(40) = 0
400 b(c(41)) = 0: c(41) = 0
410 b(c(50)) = 0: c(50) = 0
500 b(c(51)) = 0: c(51) = 0
510 b(c(60)) = 0: c(60) = 0
600 b(c(61)) = 0: c(61) = 0
610 b(c(70)) = 0: c(70) = 0
700 Next j70
b(c(21)) = 0: c(21) = 0
210 b(c(30)) = 0: c(30) = 0
300 b(c(71)) = 0: c(71) = 0
710 b(c(80)) = 0: c(80) = 0
800 Next j80
b(c(11)) = 0: c(11) = 0
110 b(c(20)) = 0: c(20) = 0
200 b(c(81)) = 0: c(81) = 0
810 b(c(90)) = 0: c(90) = 0
900 Next j90
b(c(5)) = 0: c(5) = 0
50 b(c(6)) = 0: c(6) = 0
60 b(c(10)) = 0: c(10) = 0
100 b(c(91)) = 0: c(91) = 0
910 b(c(95)) = 0: c(95) = 0
950 b(c(96)) = 0: c(96) = 0
960 Next j96
b(c(4)) = 0: c(4) = 0
40 b(c(7)) = 0: c(7) = 0
70 b(c(94)) = 0: c(94) = 0
940 b(c(97)) = 0: c(97) = 0
970 Next j97
b(c(3)) = 0: c(3) = 0
30 b(c(8)) = 0: c(8) = 0
80 b(c(93)) = 0: c(93) = 0
930 b(c(98)) = 0: c(98) = 0
980 Next j98
b(c(2)) = 0: c(2) = 0
20 b(c(9)) = 0: c(9) = 0
90 b(c(92)) = 0: c(92) = 0
920 b(c(99)) = 0: c(99) = 0
990 Next j99
b(c(1)) = 0: c(1) = 0
10 b(c(100)) = 0: c(100) = 0
1000 Next j100
fl1 = 0
Return
End Sub
