' Generates Order 13 Border / Diamond Combinations with 4 x 9 Even Corner Numbers
' Suitable for Concentric Lozenge Squares of order 15
' Tested with Office 365 under Windows 10
Sub Priem13f()
Dim a1(225), a(225), a13(169), a15(225), b(225), b1(225), c(169)
y = MsgBox("Locked", vbCritical, "Routine Priem13f")
End
n5 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
m1 = 1: m2 = 112: s1 = 1469: p2 = 226
For i1 = 1 To m2
a1(i1) = 2 * i1: b1(a1(i1)) = a1(i1)
Next i1
For j100 = 2 To 2
' Read Diamond Inlay / Border 11 Combinations
Erase a
For i1 = 1 To 225
a(i1) = Sheets("BrdrLns11").Cells(j100, i1):
If a(i1) <> 0 Then b(a(i1)) = a(i1)
Next i1
' Store Center Square in a13()
Erase a13
a13(6) = a(22): a13(7) = a(23): a13(8) = a(24):
a13(15) = a(33): a13(16) = a(34): a13(17) = a(35): a13(18) = a(36): a13(19) = a(37): a13(20) = a(38):
a13(21) = a(39): a13(22) = a(40): a13(23) = a(41): a13(24) = a(42): a13(25) = a(43):
a13(28) = a(48): a13(29) = a(49): a13(30) = a(50): a13(31) = a(51): a13(32) = a(52): a13(33) = a(53):
a13(34) = a(54): a13(35) = a(55): a13(36) = a(56): a13(37) = a(57): a13(38) = a(58):
a13(41) = a(63): a13(42) = a(64): a13(43) = a(65): a13(44) = a(66): a13(45) = a(67): a13(46) = a(68):
a13(47) = a(69): a13(48) = a(70): a13(49) = a(71): a13(50) = a(72): a13(51) = a(73):
a13(54) = a(78): a13(55) = a(79): a13(56) = a(80): a13(57) = a(81): a13(58) = a(82): a13(59) = a(83):
a13(60) = a(84): a13(61) = a(85): a13(62) = a(86): a13(63) = a(87): a13(64) = a(88):
a13(66) = a(92): a13(67) = a(93): a13(68) = a(94): a13(69) = a(95): a13(70) = a(96):
a13(71) = a(97): a13(72) = a(98): a13(73) = a(99): a13(74) = a(100): a13(75) = a(101):
a13(76) = a(102): a13(77) = a(103): a13(78) = a(104):
a13(79) = a(107): a13(80) = a(108): a13(81) = a(109): a13(82) = a(110): a13(83) = a(111):
a13(84) = a(112): a13(85) = a(113): a13(86) = a(114): a13(87) = a(115): a13(88) = a(116):
a13(89) = a(117): a13(90) = a(118): a13(91) = a(119):
a13(92) = a(122): a13(93) = a(123): a13(94) = a(124): a13(95) = a(125): a13(96) = a(126):
a13(97) = a(127): a13(98) = a(128): a13(99) = a(129): a13(100) = a(130): a13(101) = a(131):
a13(102) = a(132): a13(103) = a(133): a13(104) = a(134):
a13(106) = a(138): a13(107) = a(139): a13(108) = a(140): a13(109) = a(141): a13(110) = a(142): a13(111) = a(143):
a13(112) = a(144): a13(113) = a(145): a13(114) = a(146): a13(115) = a(147): a13(116) = a(148):
a13(119) = a(153): a13(120) = a(154): a13(121) = a(155): a13(122) = a(156): a13(123) = a(157): a13(124) = a(158):
a13(125) = a(159): a13(126) = a(160): a13(127) = a(161): a13(128) = a(162): a13(129) = a(163):
a13(132) = a(168): a13(133) = a(169): a13(134) = a(170): a13(135) = a(171): a13(136) = a(172): a13(137) = a(173):
a13(138) = a(174): a13(139) = a(175): a13(140) = a(176): a13(141) = a(177): a13(142) = a(178):
a13(145) = a(183): a13(146) = a(184): a13(147) = a(185): a13(148) = a(186): a13(149) = a(187): a13(150) = a(188):
a13(151) = a(189): a13(152) = a(190): a13(153) = a(191): a13(154) = a(192): a13(155) = a(193):
a13(162) = a(202): a13(163) = a(203): a13(164) = a(204):
' Complete Border (only even numbers available)
For j169 = m2 To m1 Step -1 'a13(169)
If b(a1(j169)) = 0 Then b(a1(j169)) = a1(j169): c(169) = a1(j169) Else GoTo 1690
a13(169) = a1(j169)
a13(1) = p2 - a13(169): If b(a13(1)) = 0 Then b(a13(1)) = a13(1): c(1) = a13(1) Else GoTo 10
For j168 = j169 - 1 To m1 Step -1 'a13(168)
If b(a1(j168)) = 0 Then b(a1(j168)) = a1(j168): c(168) = a1(j168) Else GoTo 1680
a13(168) = a1(j168)
a13(12) = p2 - a13(168): If b(a13(12)) = 0 Then b(a13(12)) = a13(12): c(12) = a13(12) Else GoTo 120
For j167 = j168 - 1 To m1 Step -1 'a13(167)
If b(a1(j167)) = 0 Then b(a1(j167)) = a1(j167): c(167) = a1(j167) Else GoTo 1670
a13(167) = a1(j167)
a13(11) = p2 - a13(167): If b(a13(11)) = 0 Then b(a13(11)) = a13(11): c(11) = a13(11) Else GoTo 110
For j166 = j167 - 1 To m1 Step -1 'a13(166)
If b(a1(j166)) = 0 Then b(a1(j166)) = a1(j166): c(166) = a1(j166) Else GoTo 1660
a13(166) = a1(j166)
a13(10) = p2 - a13(166): If b(a13(10)) = 0 Then b(a13(10)) = a13(10): c(10) = a13(10) Else GoTo 100
For j165 = m1 To m2 'a13(165)
If b(a1(j165)) = 0 Then b(a1(j165)) = a1(j165): c(165) = a1(j165) Else GoTo 1650
a13(165) = a1(j165)
a13(9) = p2 - a13(165): If b(a13(9)) = 0 Then b(a13(9)) = a13(9): c(9) = a13(9) Else GoTo 90
For j157 = j165 + 1 To m2 'a13(157)
If b(a1(j157)) = 0 Then b(a1(j157)) = a1(j157): c(157) = a1(j157) Else GoTo 1570
a13(157) = a1(j157)
a13(13) = p2 - a13(157): If b(a13(13)) = 0 Then b(a13(13)) = a13(13): c(13) = a13(13) Else GoTo 130
For j161 = j157 + 1 To m2 'a13(161)
If b(a1(j161)) = 0 Then b(a1(j161)) = a1(j161): c(161) = a1(j161) Else GoTo 1610
a13(161) = a1(j161)
a13(5) = p2 - a13(161): If b(a13(5)) = 0 Then b(a13(5)) = a13(5): c(5) = a13(5) Else GoTo 50
For j160 = j161 + 1 To m2 'a13(160)
If b(a1(j160)) = 0 Then b(a1(j160)) = a1(j160): c(160) = a1(j160) Else GoTo 1600
a13(160) = a1(j160)
a13(4) = p2 - a13(160): If b(a13(4)) = 0 Then b(a13(4)) = a13(4): c(4) = a13(4) Else GoTo 40
For j159 = j160 + 1 To m2 'a13(159)
If b(a1(j159)) = 0 Then b(a1(j159)) = a1(j159): c(159) = a1(j159) Else GoTo 1590
a13(159) = a1(j159)
a13(3) = p2 - a13(159): If b(a13(3)) = 0 Then b(a13(3)) = a13(3): c(3) = a13(3) Else GoTo 30
a13(158) = s1 - a13(157)-a13(159)-a13(160)-a13(161)-a13(162)-a13(163)-a13(164)-a13(165)-a13(166)-a13(167)-a13(168)-a13(169)
If a13(158) < a1(m1) Or a13(158) > a1(m2) Then GoTo 1580
If b1(a13(158)) = 0 Then GoTo 1580
If b(a13(158)) = 0 Then b(a13(158)) = a13(158): c(158) = a13(158) Else GoTo 1580
a13(2) = p2 - a13(158): If b(a13(2)) = 0 Then b(a13(2)) = a13(2): c(2) = a13(2) Else GoTo 20
For j156 = m2 To m1 Step -1 'a13(156)
If b(a1(j156)) = 0 Then b(a1(j156)) = a1(j156): c(156) = a1(j156) Else GoTo 1560
a13(156) = a1(j156)
a13(144) = p2 - a13(156): If b(a13(144)) = 0 Then b(a13(144)) = a13(144): c(144) = a13(144) Else GoTo 1440
For j143 = j156 - 1 To m1 Step -1 'a13(143)
If b(a1(j143)) = 0 Then b(a1(j143)) = a1(j143): c(143) = a1(j143) Else GoTo 1430
a13(143) = a1(j143)
a13(131) = p2 - a13(143): If b(a13(131)) = 0 Then b(a13(131)) = a13(131): c(131) = a13(131) Else GoTo 1310
For j130 = m1 To m2 'a13(130)
If b(a1(j130)) = 0 Then b(a1(j130)) = a1(j130): c(130) = a1(j130) Else GoTo 1300
a13(130) = a1(j130)
a13(118) = p2 - a13(130): If b(a13(118)) = 0 Then b(a13(118)) = a13(118): c(118) = a13(118) Else GoTo 1180
For j117 = j130 + 1 To m2 'a13(117)
If b(a1(j117)) = 0 Then b(a1(j117)) = a1(j117): c(117) = a1(j117) Else GoTo 1170
a13(117) = a1(j117)
a13(105) = p2 - a13(117): If b(a13(105)) = 0 Then b(a13(105)) = a13(105): c(105) = a13(105) Else GoTo 1050
For j65 = j117 + 1 To m2 'a13(65)
If b(a1(j65)) = 0 Then b(a1(j65)) = a1(j65): c(65) = a1(j65) Else GoTo 650
a13(65) = a1(j65)
a13(53) = p2 - a13(65): If b(a13(53)) = 0 Then b(a13(53)) = a13(53): c(53) = a13(53) Else GoTo 530
For j52 = j165 + 1 To m2 'a13(52)
If b(a1(j52)) = 0 Then b(a1(j52)) = a1(j52): c(52) = a1(j52) Else GoTo 520
a13(52) = a1(j52)
a13(40) = p2 - a13(52): If b(a13(40)) = 0 Then b(a13(40)) = a13(40): c(40) = a13(40) Else GoTo 400
For j39 = j52 + 1 To m2 'a13(39)
If b(a1(j39)) = 0 Then b(a1(j39)) = a1(j39): c(39) = a1(j39) Else GoTo 390
a13(39) = a1(j39)
a13(27) = p2 - a13(39): If b(a13(27)) = 0 Then b(a13(27)) = a13(27): c(27) = a13(27) Else GoTo 270
a13(26) = s1 - a13(13)-a13(39)-a13(52)-a13(65)-a13(78)-a13(91)-a13(104)-a13(117)-a13(130)-a13(143)-a13(156)-a13(169)
If a13(26) < a1(m1) Or a13(26) > a1(m2) Then GoTo 260
If b1(a13(26)) = 0 Then GoTo 260
If b(a13(26)) = 0 Then b(a13(26)) = a13(26): c(26) = a13(26) Else GoTo 260
a13(14) = p2 - a13(26): If b(a13(14)) = 0 Then b(a13(14)) = a13(14): c(14) = a13(14) Else GoTo 140
' Exclude solutions with identical numbers
GoSub 1800: If fl1 = 0 Then GoTo 5
n9 = n9 + 1
GoSub 2700 'Fill Print Area a15()
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers)
Erase b, c: GoTo 1500 'Print only first square
5
b(c(14)) = 0: c(14) = 0
140 b(c(26)) = 0: c(26) = 0
260 b(c(27)) = 0: c(27) = 0
270 b(c(39)) = 0: c(39) = 0
390 Next j39
b(c(40)) = 0: c(40) = 0
400 b(c(52)) = 0: c(52) = 0
520 Next j52
b(c(53)) = 0: c(53) = 0
530 b(c(65)) = 0: c(65) = 0
650 Next j65
b(c(105)) = 0: c(105) = 0
1050 b(c(117)) = 0: c(117) = 0
1170 Next j117
b(c(118)) = 0: c(118) = 0
1180 b(c(130)) = 0: c(130) = 0
1300 Next j130
b(c(131)) = 0: c(131) = 0
1310 b(c(143)) = 0: c(143) = 0
1430 Next j143
b(c(144)) = 0: c(144) = 0
1440 b(c(156)) = 0: c(156) = 0
1560 Next j156
b(c(2)) = 0: c(2) = 0
20 b(c(158)) = 0: c(158) = 0
1580 b(c(3)) = 0: c(3) = 0
30 b(c(159)) = 0: c(159) = 0
1590 Next j159
b(c(4)) = 0: c(4) = 0
40 b(c(160)) = 0: c(160) = 0
1600 Next j160
b(c(5)) = 0: c(5) = 0
50 b(c(161)) = 0: c(161) = 0
1610 Next j161
b(c(13)) = 0: c(13) = 0
130 b(c(157)) = 0: c(157) = 0
1570 Next j157
b(c(9)) = 0: c(9) = 0
90 b(c(165)) = 0: c(165) = 0
1650 Next j165
b(c(10)) = 0: c(10) = 0
100 b(c(166)) = 0: c(166) = 0
1660 Next j166
b(c(11)) = 0: c(11) = 0
110 b(c(167)) = 0: c(167) = 0
1670 Next j167
b(c(12)) = 0: c(12) = 0
120 b(c(168)) = 0: c(168) = 0
1680 Next j168
b(c(1)) = 0: c(1) = 0
10 b(c(169)) = 0: c(169) = 0
1690 Next j169
n10 = 0: Erase b, c
1500 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine Priem13f")
End
' Fill Print Area a15()
2700 Erase a15
a15(17) = a13(1): a15(18) = a13(2): a15(19) = a13(3): a15(20) = a13(4): a15(21) = a13(5):
a15(22) = a13(6): a15(23) = a13(7): a15(24) = a13(8): a15(25) = a13(9): a15(26) = a13(10):
a15(27) = a13(11): a15(28) = a13(12): a15(29) = a13(13):
a15(32) = a13(14): a15(33) = a13(15): a15(34) = a13(16): a15(35) = a13(17): a15(36) = a13(18):
a15(37) = a13(19): a15(38) = a13(20): a15(39) = a13(21): a15(40) = a13(22): a15(41) = a13(23):
a15(42) = a13(24): a15(43) = a13(25): a15(44) = a13(26):
a15(47) = a13(27): a15(48) = a13(28): a15(49) = a13(29): a15(50) = a13(30): a15(51) = a13(31):
a15(52) = a13(32): a15(53) = a13(33): a15(54) = a13(34): a15(55) = a13(35): a15(56) = a13(36):
a15(57) = a13(37): a15(58) = a13(38): a15(59) = a13(39):
a15(62) = a13(40): a15(63) = a13(41): a15(64) = a13(42): a15(65) = a13(43): a15(66) = a13(44):
a15(67) = a13(45): a15(68) = a13(46): a15(69) = a13(47): a15(70) = a13(48): a15(71) = a13(49):
a15(72) = a13(50): a15(73) = a13(51): a15(74) = a13(52):
a15(77) = a13(53): a15(78) = a13(54): a15(79) = a13(55): a15(80) = a13(56): a15(81) = a13(57):
a15(82) = a13(58): a15(83) = a13(59): a15(84) = a13(60): a15(85) = a13(61): a15(86) = a13(62):
a15(87) = a13(63): a15(88) = a13(64): a15(89) = a13(65):
a15(92) = a13(66): a15(93) = a13(67): a15(94) = a13(68): a15(95) = a13(69): a15(96) = a13(70):
a15(97) = a13(71): a15(98) = a13(72): a15(99) = a13(73): a15(100) = a13(74): a15(101) = a13(75):
a15(102) = a13(76): a15(103) = a13(77): a15(104) = a13(78):
a15(107) = a13(79): a15(108) = a13(80): a15(109) = a13(81): a15(110) = a13(82): a15(111) = a13(83):
a15(112) = a13(84): a15(113) = a13(85): a15(114) = a13(86): a15(115) = a13(87): a15(116) = a13(88):
a15(117) = a13(89): a15(118) = a13(90): a15(119) = a13(91):
a15(122) = a13(92): a15(123) = a13(93): a15(124) = a13(94): a15(125) = a13(95): a15(126) = a13(96):
a15(127) = a13(97): a15(128) = a13(98): a15(129) = a13(99): a15(130) = a13(100): a15(131) = a13(101):
a15(132) = a13(102): a15(133) = a13(103): a15(134) = a13(104):
a15(137) = a13(105): a15(138) = a13(106): a15(139) = a13(107): a15(140) = a13(108): a15(141) = a13(109):
a15(142) = a13(110): a15(143) = a13(111): a15(144) = a13(112): a15(145) = a13(113): a15(146) = a13(114):
a15(147) = a13(115): a15(148) = a13(116): a15(149) = a13(117):
a15(152) = a13(118): a15(153) = a13(119): a15(154) = a13(120): a15(155) = a13(121): a15(156) = a13(122):
a15(157) = a13(123): a15(158) = a13(124): a15(159) = a13(125): a15(160) = a13(126): a15(161) = a13(127):
a15(162) = a13(128): a15(163) = a13(129): a15(164) = a13(130):
a15(167) = a13(131): a15(168) = a13(132): a15(169) = a13(133): a15(170) = a13(134): a15(171) = a13(135):
a15(172) = a13(136): a15(173) = a13(137): a15(174) = a13(138): a15(175) = a13(139): a15(176) = a13(140):
a15(177) = a13(141): a15(178) = a13(142): a15(179) = a13(143):
a15(182) = a13(144): a15(183) = a13(145): a15(184) = a13(146): a15(185) = a13(147): a15(186) = a13(148):
a15(187) = a13(149): a15(188) = a13(150): a15(189) = a13(151): a15(190) = a13(152): a15(191) = a13(153):
a15(192) = a13(154): a15(193) = a13(155): a15(194) = a13(156):
a15(197) = a13(157): a15(198) = a13(158): a15(199) = a13(159): a15(200) = a13(160): a15(201) = a13(161):
a15(202) = a13(162): a15(203) = a13(163): a15(204) = a13(164): a15(205) = a13(165): a15(206) = a13(166):
a15(207) = a13(167): a15(208) = a13(168): a15(209) = a13(169):
a15(8) = a(8): a15(106) = a(106): a15(120) = a(120): a15(218) = a(218):
Return
' Print results (selected numbers)
2645 For i1 = 1 To 225
Cells(n9, i1).Value = a15(i1)
Next i1
Cells(n9, 226).Value = n9
Return
' Print results (squares)
2650 n5 = n5 + 1
If n5 = 3 Then
n5 = 1: k1 = k1 + 16: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 16
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 15
For i2 = 1 To 15
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a15(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers
1800 fl1 = 1
For j1 = 1 To 169
a2 = a13(j1): If a2 = 0 Then GoTo 1810
For j2 = (1 + j1) To 169
If a2 = a13(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
End Sub
