' Generates Prime Number Borderd Magic Squares of order 14
' Composed Border, Center Square order 6
' Tested with Office 365 under Windows 10
Sub Priem14d()
Dim a1(1142), a(196), a14(196), b1(43300), b(43300), c(196)
Dim a2(36), b2(43300), c2(16), a3(196)
y = MsgBox("Locked", vbCritical, "Routine Priem14d")
End
Sheets("Klad1").Select
n5 = 0: n9 = 0: k1 = 1: k2 = 1
ShtNm1 = "Pairs8"
ShtNm2 = "ConcLns6"
t1 = Timer
For j100 = 2 To 15
GoSub 1500: If fl1 = 0 Then GoTo 1000 'Define Variables
GoSub 2000 'Determine 4 Corner Squares
If n10 < 4 Then n10 = 0: n3 = 0: Erase b, c: GoTo 1000
GoSub 3000 'Determine 4 Border Rectagles
If n10 < 8 Then n10 = 0: n3 = 0: Erase b, c: GoTo 1000
GoSub 800 'Double Check Identical Integers a14()
If fl1 = 1 Then
n9 = n9 + 1: GoSub 650 'Print Composed Squares a14()
End If
1000 Erase b1, b, c
Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine Priem14d")
End
' Determine 4 Corner Squares
2000 Erase b2, c2
For jj16 = m1 To m2 'a2(16)
If b1(a1(jj16)) = 0 Then GoTo 2165
If b2(a1(jj16)) = 0 Then b2(a1(jj16)) = a1(jj16): c2(16) = a1(jj16) Else GoTo 2165
a2(16) = a1(jj16)
a2(1) = 0.5 * s4 - a2(16): If b2(a2(1)) = 0 Then b2(a2(1)) = a2(1): c2(1) = a2(1) Else GoTo 2010
For jj15 = m1 To m2 'a2(15)
If b1(a1(jj15)) = 0 Then GoTo 2150
If b2(a1(jj15)) = 0 Then b2(a1(jj15)) = a1(jj15): c2(15) = a1(jj15) Else GoTo 2150
a2(15) = a1(jj15)
a2(2) = 0.5 * s4 - a2(15): If b2(a2(2)) = 0 Then b2(a2(2)) = a2(2): c2(2) = a2(2) Else GoTo 2020
For jj14 = m1 To m2 'a2(14)
If b1(a1(jj14)) = 0 Then GoTo 2140
If b2(a1(jj14)) = 0 Then b2(a1(jj14)) = a1(jj14): c2(14) = a1(jj14) Else GoTo 2140
a2(14) = a1(jj14)
a2(13) = s4 - a2(14) - a2(15) - a2(16)
If a2(13) < a1(m1) Or a2(13) > a1(m2) Then GoTo 2130
If b1(a2(13)) = 0 Then GoTo 2130
If b2(a2(13)) = 0 Then b2(a2(13)) = a2(13): c2(13) = a2(13) Else GoTo 2130
a2(4) = 0.5 * s4 - a2(13): If b2(a2(4)) = 0 Then b2(a2(4)) = a2(4): c2(4) = a2(4) Else GoTo 2040
a2(3) = 0.5 * s4 - a2(14): If b2(a2(3)) = 0 Then b2(a2(3)) = a2(3): c2(3) = a2(3) Else GoTo 2030
For jj12 = m1 To m2 'a2(12)
If b1(a1(jj12)) = 0 Then GoTo 2125
If b2(a1(jj12)) = 0 Then b2(a1(jj12)) = a1(jj12): c2(12) = a1(jj12) Else GoTo 2125
a2(12) = a1(jj12)
a2(11) = s4 - a2(12) - a2(15) - a2(16)
If a2(11) < a1(m1) Or a2(11) > a1(m2) Then GoTo 2115
If b1(a2(11)) = 0 Then GoTo 2115
If b2(a2(11)) = 0 Then b2(a2(11)) = a2(11): c2(11) = a2(11) Else GoTo 2115
a2(10) = s4 - a2(12) - a2(14) - a2(16)
If a2(10) < a1(m1) Or a2(10) > a1(m2) Then GoTo 2100
If b1(a2(10)) = 0 Then GoTo 2100
If b2(a2(10)) = 0 Then b2(a2(10)) = a2(10): c2(10) = a2(10) Else GoTo 2100
a2(9) = s4 - a2(10) - a2(11) - a2(12)
If a2(9) < a1(m1) Or a2(9) > a1(m2) Then GoTo 2090
If b1(a2(9)) = 0 Then GoTo 2090
If b2(a2(9)) = 0 Then b2(a2(9)) = a2(9): c2(9) = a2(9) Else GoTo 2090
a2(8) = 0.5 * s4 - a2(9): If b2(a2(8)) = 0 Then b2(a2(8)) = a2(8): c2(8) = a2(8) Else GoTo 2080
a2(7) = 0.5 * s4 - a2(10): If b2(a2(7)) = 0 Then b2(a2(7)) = a2(7): c2(7) = a2(7) Else GoTo 2075
a2(6) = 0.5 * s4 - a2(11): If b2(a2(6)) = 0 Then b2(a2(6)) = a2(6): c2(6) = a2(6) Else GoTo 2060
a2(5) = 0.5 * s4 - a2(12): If b2(a2(5)) = 0 Then b2(a2(5)) = a2(5): c2(5) = a2(5) Else GoTo 2050
n10 = n10 + 1
If n10 < 4 Then
GoSub 750 'Transform and Assign Corner Squares
n32 = 16: GoSub 910 'Remove used integers a2() from available integers b1()
Erase b2, c2: GoTo 2165
Else
GoSub 750 'Transform and Assign Corner Squares
n32 = 16: GoSub 910 'Remove used integers a2() from available integers b1()
End If
If n10 = 4 Then Erase b2, c2: Return 'Only four squares required
b2(c2(5)) = 0: c2(5) = 0
2050 b2(c2(6)) = 0: c2(6) = 0
2060 b2(c2(7)) = 0: c2(7) = 0
2075 b2(c2(8)) = 0: c2(8) = 0
2080 b2(c2(9)) = 0: c2(9) = 0
2090 b2(c2(10)) = 0: c2(10) = 0
2100 b2(c2(11)) = 0: c2(11) = 0
2115 b2(c2(12)) = 0: c2(12) = 0
2125 Next jj12
b2(c2(3)) = 0: c2(3) = 0
2030 b2(c2(4)) = 0: c2(4) = 0
2040 b2(c2(13)) = 0: c2(13) = 0
2130 b2(c2(14)) = 0: c2(14) = 0
2140 Next jj14
b2(c2(2)) = 0: c2(2) = 0
2020 b2(c2(15)) = 0: c2(15) = 0
2150 Next jj15
b2(c2(1)) = 0: c2(1) = 0
2010 b2(c2(16)) = 0: c2(16) = 0
2165 Next jj16
Return
' Determine Border Sections 4 x 6
3000 Erase b2, c2
For jjj24 = m1 To m2 'a2(24)
If b1(a1(jjj24)) = 0 Then GoTo 240
If b2(a1(jjj24)) = 0 Then b2(a1(jjj24)) = a1(jjj24): c(24) = a1(jjj24) Else GoTo 240
a2(24) = a1(jjj24)
a2(1) = Pr4 - a2(24): If b2(a2(1)) = 0 Then b2(a2(1)) = a2(1): c(1) = a2(1) Else GoTo 10
For jjj23 = m1 To m2 'a2(23)
If b1(a1(jjj23)) = 0 Then GoTo 230
If b2(a1(jjj23)) = 0 Then b2(a1(jjj23)) = a1(jjj23): c(23) = a1(jjj23) Else GoTo 230
a2(23) = a1(jjj23)
a2(2) = Pr4 - a2(23): If b2(a2(2)) = 0 Then b2(a2(2)) = a2(2): c(2) = a2(2) Else GoTo 20
For jjj22 = m1 To m2 'a2(22)
If b1(a1(jjj22)) = 0 Then GoTo 220
If b2(a1(jjj22)) = 0 Then b2(a1(jjj22)) = a1(jjj22): c(22) = a1(jjj22) Else GoTo 220
a2(22) = a1(jjj22)
a2(3) = Pr4 - a2(22): If b2(a2(3)) = 0 Then b2(a2(3)) = a2(3): c(3) = a2(3) Else GoTo 30
For jjj21 = m1 To m2 'a2(21)
If b1(a1(jjj21)) = 0 Then GoTo 210
If b2(a1(jjj21)) = 0 Then b2(a1(jjj21)) = a1(jjj21): c(21) = a1(jjj21) Else GoTo 210
a2(21) = a1(jjj21)
a2(4) = Pr4 - a2(21): If b2(a2(4)) = 0 Then b2(a2(4)) = a2(4): c(4) = a2(4) Else GoTo 40
For jjj20 = m1 To m2 'a2(20)
If b1(a1(jjj20)) = 0 Then GoTo 200
If b2(a1(jjj20)) = 0 Then b2(a1(jjj20)) = a1(jjj20): c(20) = a1(jjj20) Else GoTo 200
a2(20) = a1(jjj20)
a2(19) = s6 - a2(20) - a2(21) - a2(22) - a2(23) - a2(24)
If a2(19) < a1(m1) Or a2(19) > a1(m2) Then GoTo 190
If b1(a2(19)) = 0 Then GoTo 190
If b2(a2(19)) = 0 Then b2(a2(19)) = a2(19): c(19) = a2(19) Else GoTo 190
a2(6) = Pr4 - a2(19): If b2(a2(6)) = 0 Then b2(a2(6)) = a2(6): c(6) = a2(6) Else GoTo 60
a2(5) = Pr4 - a2(20): If b2(a2(5)) = 0 Then b2(a2(5)) = a2(5): c(5) = a2(5) Else GoTo 50
For jjj18 = m1 To m2 'a2(18)
If b1(a1(jjj18)) = 0 Then GoTo 180
If b2(a1(jjj18)) = 0 Then b2(a1(jjj18)) = a1(jjj18): c(18) = a1(jjj18) Else GoTo 180
a2(18) = a1(jjj18)
a2(7) = Pr4 - a2(18): If b2(a2(7)) = 0 Then b2(a2(7)) = a2(7): c(7) = a2(7) Else GoTo 70
For jjj17 = m1 To m2 'a2(17)
If b1(a1(jjj17)) = 0 Then GoTo 170
If b2(a1(jjj17)) = 0 Then b2(a1(jjj17)) = a1(jjj17): c(17) = a1(jjj17) Else GoTo 170
a2(17) = a1(jjj17)
a2(16) = s6 - a2(17) - a2(18) - a2(22) - a2(23) - a2(24)
If a2(16) < a1(m1) Or a2(16) > a1(m2) Then GoTo 160
If b1(a2(16)) = 0 Then GoTo 160
If b2(a2(16)) = 0 Then b2(a2(16)) = a2(16): c(16) = a2(16) Else GoTo 160
a2(15) = s6 - a2(17) - a2(18) - a2(21) - a2(23) - a2(24)
If a2(15) < a1(m1) Or a2(15) > a1(m2) Then GoTo 150
If b1(a2(15)) = 0 Then GoTo 150
If b2(a2(15)) = 0 Then b2(a2(15)) = a2(15): c(15) = a2(15) Else GoTo 150
a2(14) = a2(17) - a2(20) + a2(23)
If a2(14) < a1(m1) Or a2(14) > a1(m2) Then GoTo 140
If b1(a2(14)) = 0 Then GoTo 140
If b2(a2(14)) = 0 Then b2(a2(14)) = a2(14): c(14) = a2(14) Else GoTo 140
a2(13) = a2(18) - a2(19) + a2(24)
If a2(13) < a1(m1) Or a2(13) > a1(m2) Then GoTo 130
If b1(a2(13)) = 0 Then GoTo 130
If b2(a2(13)) = 0 Then b2(a2(13)) = a2(13): c(13) = a2(13) Else GoTo 130
a2(12) = Pr4 - a2(13): If b2(a2(12)) = 0 Then b2(a2(12)) = a2(12): c(12) = a2(12) Else GoTo 120
a2(11) = Pr4 - a2(14): If b2(a2(11)) = 0 Then b2(a2(11)) = a2(11): c(11) = a2(11) Else GoTo 110
a2(10) = Pr4 - a2(15): If b2(a2(10)) = 0 Then b2(a2(10)) = a2(10): c(10) = a2(10) Else GoTo 100
a2(9) = Pr4 - a2(16): If b2(a2(9)) = 0 Then b2(a2(9)) = a2(9): c(9) = a2(9) Else GoTo 90
a2(8) = Pr4 - a2(17): If b2(a2(8)) = 0 Then b2(a2(8)) = a2(8): c(8) = a2(8) Else GoTo 80
n10 = n10 + 1
If n10 < 8 Then
GoSub 750 'Transform and Assign Border Squares
n32 = 24: GoSub 910 'Remove used integers a2() from available integers b1()
Erase b2, c2: GoTo 240
Else
GoSub 750 'Transform and Assign Border Squares
n32 = 24: GoSub 910 'Remove used integers a2() from available integers b1()
End If
If n10 = 8 Then Erase b2, c2: Return 'Only four rectangles required
b2(c(8)) = 0: c(8) = 0
80 b2(c(9)) = 0: c(9) = 0
90 b2(c(10)) = 0: c(10) = 0
100 b2(c(11)) = 0: c(11) = 0
110 b2(c(12)) = 0: c(12) = 0
120 b2(c(13)) = 0: c(13) = 0
130 b2(c(14)) = 0: c(14) = 0
140 b2(c(15)) = 0: c(15) = 0
150 b2(c(16)) = 0: c(16) = 0
160 b2(c(17)) = 0: c(17) = 0
170 Next jjj17
b2(c(7)) = 0: c(7) = 0
70 b2(c(18)) = 0: c(18) = 0
180 Next jjj18
b2(c(5)) = 0: c(5) = 0
50 b2(c(6)) = 0: c(6) = 0
60 b2(c(19)) = 0: c(19) = 0
190 b2(c(20)) = 0: c(20) = 0
200 Next jjj20
b2(c(4)) = 0: c(4) = 0
40 b2(c(21)) = 0: c(21) = 0
210 Next jjj21
b2(c(3)) = 0: c(3) = 0
30 b2(c(22)) = 0: c(22) = 0
220 Next jjj22
b2(c(2)) = 0: c(2) = 0
20 b2(c(23)) = 0: c(23) = 0
230 Next jjj23
b2(c(1)) = 0: c(1) = 0
10 b2(c(24)) = 0: c(24) = 0
240 Next jjj24
Return
' Transform and Assign Corner Squares and Border Rectangles
750 Select Case n10
Case 1: 'Left Top
a14(1) = a2(1): a14(2) = a2(2): a14(3) = a2(3): a14(4) = a2(4):
a14(15) = a2(5): a14(16) = a2(6): a14(17) = a2(7): a14(18) = a2(8):
a14(29) = a2(9): a14(30) = a2(10): a14(31) = a2(11): a14(32) = a2(12):
a14(43) = a2(13): a14(44) = a2(14): a14(45) = a2(15): a14(46) = a2(16):
Case 2: 'Right Top
a14(11) = a2(1): a14(12) = a2(2): a14(13) = a2(3): a14(14) = a2(4):
a14(25) = a2(5): a14(26) = a2(6): a14(27) = a2(7): a14(28) = a2(8):
a14(39) = a2(9): a14(40) = a2(10): a14(41) = a2(11): a14(42) = a2(12):
a14(53) = a2(13): a14(54) = a2(14): a14(55) = a2(15): a14(56) = a2(16):
Case 3: 'Right Bottom
a14(151) = a2(1): a14(152) = a2(2): a14(153) = a2(3): a14(154) = a2(4):
a14(165) = a2(5): a14(166) = a2(6): a14(167) = a2(7): a14(168) = a2(8):
a14(179) = a2(9): a14(180) = a2(10): a14(181) = a2(11): a14(182) = a2(12):
a14(193) = a2(13): a14(194) = a2(14): a14(195) = a2(15): a14(196) = a2(16):
Case 4: 'Left Bottom
a14(141) = a2(1): a14(142) = a2(2): a14(143) = a2(3): a14(144) = a2(4):
a14(155) = a2(5): a14(156) = a2(6): a14(157) = a2(7): a14(158) = a2(8):
a14(169) = a2(9): a14(170) = a2(10): a14(171) = a2(11): a14(172) = a2(12):
a14(183) = a2(13): a14(184) = a2(14): a14(185) = a2(15): a14(186) = a2(16):
Case 5: 'Mid Top
a14(5) = a2(1): a14(6) = a2(2): a14(7) = a2(3): a14(8) = a2(4): a14(9) = a2(5): a14(10) = a2(6):
a14(19) = a2(7): a14(20) = a2(8): a14(21) = a2(9): a14(22) = a2(10): a14(23) = a2(11): a14(24) = a2(12):
a14(33) = a2(13): a14(34) = a2(14): a14(35) = a2(15): a14(36) = a2(16): a14(37) = a2(17): a14(38) = a2(18):
a14(47) = a2(19): a14(48) = a2(20): a14(49) = a2(21): a14(50) = a2(22): a14(51) = a2(23): a14(52) = a2(24):
Case 6: 'Mid Right
a14(67) = a2(1): a14(68) = a2(7): a14(69) = a2(13): a14(70) = a2(19):
a14(81) = a2(2): a14(82) = a2(8): a14(83) = a2(14): a14(84) = a2(20):
a14(95) = a2(3): a14(96) = a2(9): a14(97) = a2(15): a14(98) = a2(21):
a14(109) = a2(4): a14(110) = a2(10): a14(111) = a2(16): a14(112) = a2(22):
a14(123) = a2(5): a14(124) = a2(11): a14(125) = a2(17): a14(126) = a2(23):
a14(137) = a2(6): a14(138) = a2(12): a14(139) = a2(18): a14(140) = a2(24):
Case 7: 'Mid Bottom
a14(145) = a2(1): a14(146) = a2(2): a14(147) = a2(3): a14(148) = a2(4): a14(149) = a2(5): a14(150) = a2(6):
a14(159) = a2(7): a14(160) = a2(8): a14(161) = a2(9): a14(162) = a2(10): a14(163) = a2(11): a14(164) = a2(12):
a14(173) = a2(13): a14(174) = a2(14): a14(175) = a2(15): a14(176) = a2(16): a14(177) = a2(17): a14(178) = a2(18):
a14(187) = a2(19): a14(188) = a2(20): a14(189) = a2(21): a14(190) = a2(22): a14(191) = a2(23): a14(192) = a2(24):
Case 8: 'Mid Left
a14(57) = a2(1): a14(58) = a2(7): a14(59) = a2(13): a14(60) = a2(19):
a14(71) = a2(2): a14(72) = a2(8): a14(73) = a2(14): a14(74) = a2(20):
a14(85) = a2(3): a14(86) = a2(9): a14(87) = a2(15): a14(88) = a2(21):
a14(99) = a2(4): a14(100) = a2(10): a14(101) = a2(16): a14(102) = a2(22):
a14(113) = a2(5): a14(114) = a2(11): a14(115) = a2(17): a14(116) = a2(23):
a14(127) = a2(6): a14(128) = a2(12): a14(129) = a2(18): a14(130) = a2(24):
End Select
Return
' Define Variables
1500 fl1 = 1
' Start Reading Data ShtNm2
Rcrd1a = Sheets(ShtNm2).Cells(j100, 39).Value
MC6 = Sheets(ShtNm2).Cells(j100, 37).Value
' Read Prime Numbers From Sheet ShtNm1
Pr4 = Sheets(ShtNm1).Cells(Rcrd1a, 1).Value 'PairSum
s4 = 2 * Pr4 'MC4
s6 = 3 * Pr4 'MC6
s10 = 5 * Pr4 'MC10
s14 = 7 * Pr4 'MC14
nVar = Sheets(ShtNm1).Cells(Rcrd1a, 5).Value
If nVar < 196 Then fl1 = 0: Return
If MC6 <> s6 Then
y = MsgBox("Conflict in Data", vbCritical, "Read " + ShtNm2)
End
End If
Erase b1
For j1 = 1 To nVar
x = Sheets(ShtNm1).Cells(Rcrd1a, 6 + j1).Value
b1(x) = x
Next j1
pMax = Sheets(ShtNm1).Cells(Rcrd1a, 6 + nVar).Value
' Read Concentric Square 6 x 6
Erase a
For i1 = 1 To 36
a(i1) = Sheets(ShtNm2).Cells(j100, i1).Value
Next i1
n32 = 36: GoSub 900 'Remove used primes from available primes
Erase a14
a14(61) = a(1): a14(62) = a(2): a14(63) = a(3): a14(64) = a(4): a14(65) = a(5): a14(66) = a(6):
a14(75) = a(7): a14(76) = a(8): a14(77) = a(9): a14(78) = a(10): a14(79) = a(11): a14(80) = a(12):
a14(89) = a(13): a14(90) = a(14): a14(91) = a(15): a14(92) = a(16): a14(93) = a(17): a14(94) = a(18):
a14(103) = a(19): a14(104) = a(20): a14(105) = a(21): a14(106) = a(22): a14(107) = a(23): a14(108) = a(24):
a14(117) = a(25): a14(118) = a(26): a14(119) = a(27): a14(120) = a(28): a14(121) = a(29): a14(122) = a(30):
a14(131) = a(31): a14(132) = a(32): a14(133) = a(33): a14(134) = a(34): a14(135) = a(35): a14(136) = a(36):
Erase a
' 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
Return
' Remove used numbers a() from available numbers b1()
900 For i1 = 1 To n32
b1(a(i1)) = 0
Next i1
Return
' Remove used numbers a2() from available numbers b1()
910 For i1 = 1 To n32
b1(a2(i1)) = 0
Next i1
Return
' Double Check Identical Numbers a14()
800 fl1 = 1
For i1 = 1 To 196
a20 = a14(i1): If a20 = 0 Then GoTo 810
For i2 = (1 + i1) To 196
If a20 = a14(i2) Then fl1 = 0: Return
Next i2
810 Next i1
Return
' Print results (squares)
650 n5 = n5 + 1
If n5 = 3 Then
n5 = 1: k1 = k1 + 15: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 15
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(s14)
i3 = 0
For i1 = 1 To 14
For i2 = 1 To 14
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a14(i3)
Next i2
Next i1
Return
End Sub
