' Generates Ultra Magic (Latin Diagonal) Squares Order 17
' Public Area's defined in Module 4
' Routines P01 ... P253 contain the equations describing the correponding pattern and a call to Ctn17 (Count Patterns)
' (not available in HTML)
' Tested with Office 365 under Windows 10
Sub UltraLat17()
Dim a1(289), b(17)
Dim a2(17, 17), b2(17, 17), c2(17, 17)
Dim nTot17(253)
y = MsgBox("Blocked", vbInformation, "UltraLat17")
End
ShtNm2 = "PtrnCnt17" 'Print Quadrant Count
Sheets(ShtNm2).Select
n17 = 1
s17 = 136: k1 = 1: k2 = 1
m1 = 1: m2 = 17: n9 = 0: n10 = 0
For j289 = 11 To 11 ''m1 To m2
a1(289) = j289 - 1
Cells(1, 256).Value = j289
a1(2) = a1(289)
a1(288) = 2 * s17 / 17 - a1(289)
a1(1) = a1(288)
a1(10) = 3 * s17 / 17 - a1(288) - a1(289)
a1(280) = 3 * s17 / 17 - a1(288) - a1(289)
If a1(280) < 0 Or a1(280) > 16 Then GoTo 2890
If a1(280) = a1(288) Or a1(280) = a1(289) Then GoTo 2890
For j287 = m1 To m2
a1(287) = j287 - 1
If a1(287) = a1(280) Or a1(287) = a1(288) Or a1(287) = a1(289) Then GoTo 2870
Cells(1, 257).Value = j287
a1(3) = 2 * s17 / 17 - a1(287)
a1(17) = a1(287)
''y = MsgBox("Test", 0, "Test")
a1(273) = 2 * s17 / 17 - a1(287)
If a1(273) = a1(287) Or a1(273) = a1(280) Or a1(273) = a1(288) Or a1(273) = a1(289) Then GoTo 2870
For j286 = m1 To m2
a1(286) = j286 - 1
If a1(286) = a1(273) Or a1(286) = a1(287) Or a1(286) = a1(280) Or a1(286) = a1(288) Or a1(286) = a1(289) Then GoTo 2860
a1(4) = 2 * s17 / 17 - a1(286)
a1(16) = a1(286)
a1(274) = 2 * s17 / 17 - a1(286)
If a1(274) = a1(286) Or a1(274) = a1(273) Or a1(274) = a1(287) Or a1(274) = a1(280) Or a1(274) = a1(288) Or a1(274) = a1(289) Then GoTo 2860
For j285 = m1 To m2
a1(285) = j285 - 1
If a1(285) = a1(286) Or a1(285) = a1(273) Or a1(285) = a1(287) Or a1(285) = a1(280) Or a1(285) = a1(288) Or a1(285) = a1(289) Then GoTo 2850
If a1(285) = a1(274) Then GoTo 2850
a1(5) = 2 * s17 / 17 - a1(285)
a1(15) = a1(285)
a1(275) = 2 * s17 / 17 - a1(285)
If a1(275) = a1(286) Or a1(275) = a1(273) Or a1(275) = a1(287) Or a1(275) = a1(280) Or a1(275) = a1(288) Or a1(275) = a1(289) Then GoTo 2850
If a1(275) = a1(285) Or a1(275) = a1(274) Then GoTo 2850
For j284 = m1 To m2
a1(284) = j284 - 1
If a1(284) = a1(286) Or a1(284) = a1(273) Or a1(284) = a1(287) Or a1(284) = a1(280) Or a1(284) = a1(288) Or a1(284) = a1(289) Then GoTo 2840
If a1(284) = a1(275) Or a1(284) = a1(285) Or a1(284) = a1(274) Then GoTo 2840
a1(6) = 2 * s17 / 17 - a1(284)
a1(14) = a1(284)
a1(276) = 2 * s17 / 17 - a1(284)
If a1(276) = a1(286) Or a1(276) = a1(273) Or a1(276) = a1(287) Or a1(276) = a1(280) Or a1(276) = a1(288) Or a1(276) = a1(289) Then GoTo 2840
If a1(276) = a1(284) Or a1(276) = a1(275) Or a1(276) = a1(285) Or a1(276) = a1(274) Then GoTo 2840
For j283 = m1 To m2
a1(283) = j283 - 1
If a1(283) = a1(286) Or a1(283) = a1(273) Or a1(283) = a1(287) Or a1(283) = a1(280) Or a1(283) = a1(288) Or a1(283) = a1(289) Then GoTo 2830
If a1(283) = a1(276) Or a1(283) = a1(284) Or a1(283) = a1(275) Or a1(283) = a1(285) Or a1(283) = a1(274) Then GoTo 2830
a1(7) = 2 * s17 / 17 - a1(283)
a1(13) = a1(283)
a1(277) = 2 * s17 / 17 - a1(283)
If a1(277) = a1(286) Or a1(277) = a1(273) Or a1(277) = a1(287) Or a1(277) = a1(280) Or a1(277) = a1(288) Or a1(277) = a1(289) Then GoTo 2830
If a1(277) = a1(283) Or a1(277) = a1(276) Or a1(277) = a1(284) Or a1(277) = a1(275) Or a1(277) = a1(285) Or a1(277) = a1(274) Then GoTo 2830
For j282 = m1 To m2
a1(282) = j282 - 1
If a1(282) = a1(286) Or a1(282) = a1(273) Or a1(282) = a1(287) Or a1(282) = a1(280) Or a1(282) = a1(288) Or a1(282) = a1(289) Then GoTo 2820
If a1(282) = a1(283) Or a1(282) = a1(276) Or a1(282) = a1(284) Or a1(282) = a1(275) Or a1(282) = a1(285) Or a1(282) = a1(274) Then GoTo 2820
If a1(282) = a1(277) Then GoTo 2820
a1(8) = 2 * s17 / 17 - a1(282)
a1(12) = a1(282)
a1(278) = 2 * s17 / 17 - a1(282)
If a1(278) = a1(286) Or a1(278) = a1(273) Or a1(278) = a1(287) Or a1(278) = a1(280) Or a1(278) = a1(288) Or a1(278) = a1(289) Then GoTo 2820
If a1(278) = a1(283) Or a1(278) = a1(276) Or a1(278) = a1(284) Or a1(278) = a1(275) Or a1(278) = a1(285) Or a1(278) = a1(274) Then GoTo 2820
If a1(278) = a1(282) Or a1(278) = a1(277) Then GoTo 2820
For j281 = m1 To m2
a1(281) = j281 - 1
a1(9) = 2 * s17 / 17 - a1(281)
a1(11) = a1(281)
a1(279) = 2 * s17 / 17 - a1(281)
GoSub 900: If fl1 = 0 Then GoTo 2810 'Check Latin Row
GoSub 500 'Complete Latin Square
GoSub 300 'Complete Ultra Magic Square
GoSub 700: 'Check Magic Patterns (General)
GoSub 600: If fl1 = 0 Then GoTo 2810 'Count / Print Paterns
'' n10 = n10 + 1: GoSub 650 'Print Squares
'' n10 = n10 + 1: Cells(1, 1).Value = n10 'Counting
''End
2810 Next j281
2820 Next j282
2830 Next j283
2840 Next j284
2850 Next j285
2860 Next j286
2870
Next j287
2890 Next j289
For i1 = 1 To 98
Cells(i1 + 2, 1).Value = i1
Cells(i1 + 2, 2).Value = nTot17(i1)
Next i1
End
' Calculate and Check Ultra Magic Square
300 fl1 = 1
' Load a2()
i3 = 0
For i1 = 1 To 17
For i2 = 1 To 17
i3 = i3 + 1
a2(i1, i2) = a1(i3)
Next i2
Next i1
' Determine Transposed b2()
For i1 = 1 To 17
For i2 = 1 To 17
b2(i1, i2) = a2(i2, i1)
Next i2
Next i1
' Calculate Ultra Magic Square c2(), a()
i3 = 0
For i1 = 1 To 17
For i2 = 1 To 17
c2(i1, i2) = a2(i1, i2) + 17 * b2(i1, i2) + 1
i3 = i3 + 1: a(i3) = c2(i1, i2)
Next i2
Next i1
' Check Identical Numbers
For i1 = 1 To 289
c20 = a(i1)
For i2 = (1 + i1) To 289
If c20 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
End
' Complete square
500
a1(18) = a1(16): a1(19) = a1(17): a1(20) = a1(1): a1(21) = a1(2): a1(22) = a1(3): a1(23) = a1(4):
a1(24) = a1(5): a1(25) = a1(6): a1(26) = a1(7): a1(27) = a1(8): a1(28) = a1(9): a1(29) = a1(10):
a1(30) = a1(11): a1(31) = a1(12): a1(32) = a1(13): a1(33) = a1(14): a1(34) = a1(15):
a1(35) = a1(33): a1(36) = a1(34): a1(37) = a1(18): a1(38) = a1(19): a1(39) = a1(20): a1(40) = a1(21):
a1(41) = a1(22): a1(42) = a1(23): a1(43) = a1(24): a1(44) = a1(25): a1(45) = a1(26): a1(46) = a1(27):
a1(47) = a1(28): a1(48) = a1(29): a1(49) = a1(30): a1(50) = a1(31): a1(51) = a1(32):
a1(52) = a1(50): a1(53) = a1(51): a1(54) = a1(35): a1(55) = a1(36): a1(56) = a1(37): a1(57) = a1(38):
a1(58) = a1(39): a1(59) = a1(40): a1(60) = a1(41): a1(61) = a1(42): a1(62) = a1(43): a1(63) = a1(44):
a1(64) = a1(45): a1(65) = a1(46): a1(66) = a1(47): a1(67) = a1(48): a1(68) = a1(49):
a1(69) = a1(67): a1(70) = a1(68): a1(71) = a1(52): a1(72) = a1(53): a1(73) = a1(54): a1(74) = a1(55):
a1(75) = a1(56): a1(76) = a1(57): a1(77) = a1(58): a1(78) = a1(59): a1(79) = a1(60): a1(80) = a1(61):
a1(81) = a1(62): a1(82) = a1(63): a1(83) = a1(64): a1(84) = a1(65): a1(85) = a1(66):
a1(86) = a1(84): a1(87) = a1(85): a1(88) = a1(69): a1(89) = a1(70): a1(90) = a1(71): a1(91) = a1(72):
a1(92) = a1(73): a1(93) = a1(74): a1(94) = a1(75): a1(95) = a1(76): a1(96) = a1(77): a1(97) = a1(78):
a1(98) = a1(79): a1(99) = a1(80): a1(100) = a1(81): a1(101) = a1(82): a1(102) = a1(83):
a1(103) = a1(101): a1(104) = a1(102): a1(105) = a1(86): a1(106) = a1(87): a1(107) = a1(88): a1(108) = a1(89):
a1(109) = a1(90): a1(110) = a1(91): a1(111) = a1(92): a1(112) = a1(93): a1(113) = a1(94): a1(114) = a1(95):
a1(115) = a1(96): a1(116) = a1(97): a1(117) = a1(98): a1(118) = a1(99): a1(119) = a1(100):
a1(120) = a1(118): a1(121) = a1(119): a1(122) = a1(103): a1(123) = a1(104): a1(124) = a1(105): a1(125) = a1(106):
a1(126) = a1(107): a1(127) = a1(108): a1(128) = a1(109): a1(129) = a1(110): a1(130) = a1(111): a1(131) = a1(112):
a1(132) = a1(113): a1(133) = a1(114): a1(134) = a1(115): a1(135) = a1(116): a1(136) = a1(117):
a1(137) = a1(135): a1(138) = a1(136): a1(139) = a1(120): a1(140) = a1(121): a1(141) = a1(122): a1(142) = a1(123):
a1(143) = a1(124): a1(144) = a1(125): a1(145) = a1(126): a1(146) = a1(127): a1(147) = a1(128): a1(148) = a1(129):
a1(149) = a1(130): a1(150) = a1(131): a1(151) = a1(132): a1(152) = a1(133): a1(153) = a1(134):
a1(154) = a1(152): a1(155) = a1(153): a1(156) = a1(137): a1(157) = a1(138): a1(158) = a1(139): a1(159) = a1(140):
a1(160) = a1(141): a1(161) = a1(142): a1(162) = a1(143): a1(163) = a1(144): a1(164) = a1(145): a1(165) = a1(146):
a1(166) = a1(147): a1(167) = a1(148): a1(168) = a1(149): a1(169) = a1(150): a1(170) = a1(151):
a1(171) = a1(169): a1(172) = a1(170): a1(173) = a1(154): a1(174) = a1(155): a1(175) = a1(156): a1(176) = a1(157):
a1(177) = a1(158): a1(178) = a1(159): a1(179) = a1(160): a1(180) = a1(161): a1(181) = a1(162): a1(182) = a1(163):
a1(183) = a1(164): a1(184) = a1(165): a1(185) = a1(166): a1(186) = a1(167): a1(187) = a1(168):
a1(188) = a1(186): a1(189) = a1(187): a1(190) = a1(171): a1(191) = a1(172): a1(192) = a1(173): a1(193) = a1(174):
a1(194) = a1(175): a1(195) = a1(176): a1(196) = a1(177): a1(197) = a1(178): a1(198) = a1(179): a1(199) = a1(180):
a1(200) = a1(181): a1(201) = a1(182): a1(202) = a1(183): a1(203) = a1(184): a1(204) = a1(185):
a1(205) = a1(203): a1(206) = a1(204): a1(207) = a1(188): a1(208) = a1(189): a1(209) = a1(190): a1(210) = a1(191):
a1(211) = a1(192): a1(212) = a1(193): a1(213) = a1(194): a1(214) = a1(195): a1(215) = a1(196): a1(216) = a1(197):
a1(217) = a1(198): a1(218) = a1(199): a1(219) = a1(200): a1(220) = a1(201): a1(221) = a1(202):
a1(222) = a1(220): a1(223) = a1(221): a1(224) = a1(205): a1(225) = a1(206): a1(226) = a1(207): a1(227) = a1(208):
a1(228) = a1(209): a1(229) = a1(210): a1(230) = a1(211): a1(231) = a1(212): a1(232) = a1(213): a1(233) = a1(214):
a1(234) = a1(215): a1(235) = a1(216): a1(236) = a1(217): a1(237) = a1(218): a1(238) = a1(219):
a1(239) = a1(237): a1(240) = a1(238): a1(241) = a1(222): a1(242) = a1(223): a1(243) = a1(224): a1(244) = a1(225):
a1(245) = a1(226): a1(246) = a1(227): a1(247) = a1(228): a1(248) = a1(229): a1(249) = a1(230): a1(250) = a1(231):
a1(251) = a1(232): a1(252) = a1(233): a1(253) = a1(234): a1(254) = a1(235): a1(255) = a1(236):
a1(256) = a1(254): a1(257) = a1(255): a1(258) = a1(239): a1(259) = a1(240): a1(260) = a1(241): a1(261) = a1(242):
a1(262) = a1(243): a1(263) = a1(244): a1(264) = a1(245): a1(265) = a1(246): a1(266) = a1(247): a1(267) = a1(248):
a1(268) = a1(249): a1(269) = a1(250): a1(270) = a1(251): a1(271) = a1(252): a1(272) = a1(253):
Return
' Print Patterns
600 nQ4 = 0: fl1 = 1
For i1 = 1 To 253
If nQ(i1) = 4 Then nQ4 = nQ4 + 1
Next i1
If nQ4 = 0 Then Return 'Counting Only
nTot17(nQ4) = nTot17(nQ4) + 1
Return
If nQ4 < n17 Then fl1 = 0: Return
n9 = n9 + 1: n17 = nQ4 + 1
For i1 = 1 To 253
Cells(n9 + 1, i1) = nQ(i1)
Next i1
Cells(n9 + 1, 254).Value = nQ4
Cells(n9 + 1, 255).Value = n9
Cells(n9 + 1, 256).Value = j289
Cells(n9 + 1, 257).Value = j287
Cells(1, 258).Value = n17
Return
' Check Magic Patterns
700 fl1 = 1: Erase nP, nQ, s
P01 1: P02 2: P03 3: P04 4: P05 5: P06 6: P07 7: P08 8: P09 9: P10 10:
P11 11: P12 12: P13 13: P14 14: P15 15: P16 16: P17 17: P18 18: P19 19: P20 20:
P21 21: P22 22: P23 23: P24 24: P25 25: P26 26: P27 27: P28 28: P29 29: P30 30:
P31 31: P32 32: P33 33: P34 34: P35 35: P36 36: P37 37: P38 38: P39 39: P40 40:
P41 41: P42 42: P43 43: P44 44: P45 45: P46 46: P47 47: P48 48: P49 49: P50 50:
P51 51: P52 52: P53 53: P54 54: P55 55: P56 56: P57 57: P58 58: P59 59: P60 60:
P61 61: P62 62: P63 63: P64 64: P65 65: P66 66: P67 67: P68 68: P69 69: P70 70:
P71 71: P72 72: P73 73: P74 74: P75 75: P76 76: P77 77: P78 78: P79 79: P80 80:
P81 81: P82 82: P83 83: P84 84: P85 85: P86 86: P87 87: P88 88: P89 89: P90 90:
P91 91: P92 92: P93 93: P94 94: P95 95: P96 96: P97 97: P98 98: P99 99: P100 100:
P101 101: P102 102: P103 103: P104 104: P105 105: P106 106: P107 107: P108 108: P109 109: P110 110:
P111 111: P112 112: P113 113: P114 114: P115 115: P116 116: P117 117: P118 118: P119 119: P120 120:
P121 121: P122 122: P123 123: P124 124: P125 125: P126 126: P127 127: P128 128: P129 129: P130 130:
P131 131: P132 132: P133 133: P134 134: P135 135: P136 136: P137 137: P138 138: P139 139: P140 140:
P141 141: P142 142: P143 143: P144 144: P145 145: P146 146: P147 147: P148 148: P149 149: P150 150:
P151 151: P152 152: P153 153: P154 154: P155 155: P156 156: P157 157: P158 158: P159 159: P160 160:
P161 161: P162 162: P163 163: P164 164: P165 165: P166 166: P167 167: P168 168: P169 169: P170 170:
P171 171: P172 172: P173 173: P174 174: P175 175: P176 176: P177 177: P178 178: P179 179: P180 180:
P181 181: P182 182: P183 183: P184 184: P185 185: P186 186: P187 187: P188 188: P189 189: P190 190:
P191 191: P192 192: P193 193: P194 194: P195 195: P196 196: P197 197: P198 198: P199 199: P200 200:
P201 201: P202 202: P203 203: P204 204: P205 205: P206 206: P207 207: P208 208: P209 209: P210 210:
P211 211: P212 212: P213 213: P214 214: P215 215: P216 216: P217 217: P218 218: P219 219: P220 220:
P221 221: P222 222: P223 223: P224 224: P225 225: P226 226: P227 227: P228 228: P229 229: P230 230:
P231 231: P232 232: P233 233: P234 234: P235 235: P236 236: P237 237: P238 238: P239 239: P240 240:
P241 241: P242 242: P243 243: P244 244: P245 245: P246 246: P247 247: P248 248: P249 249: P250 250:
P251 251: P252 252: P253 253:
Return
' Exclude solutions with identical numbers in row
900 fl1 = 1
For i1 = 273 To 289
b(i1 - 272) = a1(i1)
Next i1
For j1 = 1 To 17
b20 = b(j1)
For j2 = (1 + j1) To 17
If b20 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 2 Then
n1 = 1: k1 = k1 + 18: k2 = 1
Else
If n10 > 1 Then k2 = k2 + 18
End If
Sheets("Klad1").Cells(k1, k2 + 1).Font.Color = -4165632
Sheets("Klad1").Cells(k1, k2 + 1).Value = n10
i3 = 0
For i1 = 1 To 17
For i2 = 1 To 17
i3 = i3 + 1
Sheets("Klad1").Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
