' Generates Ultra Magic (Latin Diagonal) Squares Order 17
' Tested with Office 365 under Windows 10
Sub UltraLat17()
Dim a(289), b(17), c(289)
Dim a2(17, 17), b2(17, 17), c2(17, 17)
y = MsgBox("Blocked", vbInformation, "UltraLat17")
End
Sheets("Klad1").Select
s1 = 136: k1 = 1: k2 = 1
m1 = 1: m2 = 17
For j289 = m1 To m2
a(289) = j289 - 1
a(2) = a(289)
a(288) = 2 * s1 / 17 - a(289)
a(1) = a(288)
a(10) = 3 * s1 / 17 - a(288) - a(289)
a(280) = 3 * s1 / 17 - a(288) - a(289)
If a(280) < 0 Or a(280) > 16 Then GoTo 2890
If a(280) = a(288) Or a(280) = a(289) Then GoTo 2890
For j287 = m1 To m2
a(287) = j287 - 1
If a(287) = a(280) Or a(287) = a(288) Or a(287) = a(289) Then GoTo 2870
a(3) = 2 * s1 / 17 - a(287)
a(17) = a(287)
a(273) = 2 * s1 / 17 - a(287)
If a(273) = a(287) Or a(273) = a(280) Or a(273) = a(288) Or a(273) = a(289) Then GoTo 2870
For j286 = m1 To m2
a(286) = j286 - 1
If a(286) = a(273) Or a(286) = a(287) Or a(286) = a(280) Or a(286) = a(288) Or a(286) = a(289) Then GoTo 2860
a(4) = 2 * s1 / 17 - a(286)
a(16) = a(286)
a(274) = 2 * s1 / 17 - a(286)
If a(274) = a(286) Or a(274) = a(273) Or a(274) = a(287) Or a(274) = a(280) Or a(274) = a(288) Or a(274) = a(289) Then GoTo 2860
For j285 = m1 To m2
a(285) = j285 - 1
If a(285) = a(286) Or a(285) = a(273) Or a(285) = a(287) Or a(285) = a(280) Or a(285) = a(288) Or a(285) = a(289) Then GoTo 2850
If a(285) = a(274) Then GoTo 2850
a(5) = 2 * s1 / 17 - a(285)
a(15) = a(285)
a(275) = 2 * s1 / 17 - a(285)
If a(275) = a(286) Or a(275) = a(273) Or a(275) = a(287) Or a(275) = a(280) Or a(275) = a(288) Or a(275) = a(289) Then GoTo 2850
If a(275) = a(285) Or a(275) = a(274) Then GoTo 2850
For j284 = m1 To m2
a(284) = j284 - 1
If a(284) = a(286) Or a(284) = a(273) Or a(284) = a(287) Or a(284) = a(280) Or a(284) = a(288) Or a(284) = a(289) Then GoTo 2840
If a(284) = a(275) Or a(284) = a(285) Or a(284) = a(274) Then GoTo 2840
a(6) = 2 * s1 / 17 - a(284)
a(14) = a(284)
a(276) = 2 * s1 / 17 - a(284)
If a(276) = a(286) Or a(276) = a(273) Or a(276) = a(287) Or a(276) = a(280) Or a(276) = a(288) Or a(276) = a(289) Then GoTo 2840
If a(276) = a(284) Or a(276) = a(275) Or a(276) = a(285) Or a(276) = a(274) Then GoTo 2840
For j283 = m1 To m2
a(283) = j283 - 1
If a(283) = a(286) Or a(283) = a(273) Or a(283) = a(287) Or a(283) = a(280) Or a(283) = a(288) Or a(283) = a(289) Then GoTo 2830
If a(283) = a(276) Or a(283) = a(284) Or a(283) = a(275) Or a(283) = a(285) Or a(283) = a(274) Then GoTo 2830
a(7) = 2 * s1 / 17 - a(283)
a(13) = a(283)
a(277) = 2 * s1 / 17 - a(283)
If a(277) = a(286) Or a(277) = a(273) Or a(277) = a(287) Or a(277) = a(280) Or a(277) = a(288) Or a(277) = a(289) Then GoTo 2830
If a(277) = a(283) Or a(277) = a(276) Or a(277) = a(284) Or a(277) = a(275) Or a(277) = a(285) Or a(277) = a(274) Then GoTo 2830
For j282 = m1 To m2
a(282) = j282 - 1
If a(282) = a(286) Or a(282) = a(273) Or a(282) = a(287) Or a(282) = a(280) Or a(282) = a(288) Or a(282) = a(289) Then GoTo 2820
If a(282) = a(283) Or a(282) = a(276) Or a(282) = a(284) Or a(282) = a(275) Or a(282) = a(285) Or a(282) = a(274) Then GoTo 2820
If a(282) = a(277) Then GoTo 2820
a(8) = 2 * s1 / 17 - a(282)
a(12) = a(282)
a(278) = 2 * s1 / 17 - a(282)
If a(278) = a(286) Or a(278) = a(273) Or a(278) = a(287) Or a(278) = a(280) Or a(278) = a(288) Or a(278) = a(289) Then GoTo 2820
If a(278) = a(283) Or a(278) = a(276) Or a(278) = a(284) Or a(278) = a(275) Or a(278) = a(285) Or a(278) = a(274) Then GoTo 2820
If a(278) = a(282) Or a(278) = a(277) Then GoTo 2820
For j281 = m1 To m2
a(281) = j281 - 1
a(9) = 2 * s1 / 17 - a(281)
a(11) = a(281)
a(279) = 2 * s1 / 17 - a(281)
GoSub 900: If fl1 = 0 Then GoTo 2810 'Check Latin Row
GoSub 500 'Complete Latin Square
GoSub 300: If fl1 = 0 Then GoTo 2810 'Complete Ultra Magic Square
n9 = n9 + 1: GoSub 650 'Print Squares
'' n9 = n9 + 1: Cells(1, 1).Value = n9 '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
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) = a(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(), c()
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: c(i3) = c2(i1, i2)
Next i2
Next i1
' Check Identical Numbers
For i1 = 1 To 289
c20 = c(i1)
For i2 = (1 + i1) To 289
If c20 = c(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
End
' Complete square
500
a(18) = a(16): a(19) = a(17): a(20) = a(1): a(21) = a(2): a(22) = a(3): a(23) = a(4): a(24) = a(5):
a(25) = a(6): a(26) = a(7): a(27) = a(8): a(28) = a(9): a(29) = a(10): a(30) = a(11): a(31) = a(12):
a(32) = a(13): a(33) = a(14): a(34) = a(15):
a(35) = a(33): a(36) = a(34): a(37) = a(18): a(38) = a(19): a(39) = a(20): a(40) = a(21): a(41) = a(22):
a(42) = a(23): a(43) = a(24): a(44) = a(25): a(45) = a(26): a(46) = a(27): a(47) = a(28): a(48) = a(29):
a(49) = a(30): a(50) = a(31): a(51) = a(32):
a(52) = a(50): a(53) = a(51): a(54) = a(35): a(55) = a(36): a(56) = a(37): a(57) = a(38): a(58) = a(39):
a(59) = a(40): a(60) = a(41): a(61) = a(42): a(62) = a(43): a(63) = a(44): a(64) = a(45): a(65) = a(46):
a(66) = a(47): a(67) = a(48): (68) = a(49):
a(69) = a(67): a(70) = a(68): a(71) = a(52): a(72) = a(53): a(73) = a(54): a(74) = a(55): a(75) = a(56):
a(76) = a(57): a(77) = a(58): a(78) = a(59): a(79) = a(60): a(80) = a(61): a(81) = a(62): a(82) = a(63):
a(83) = a(64): a(84) = a(65): a(85) = a(66):
a(86) = a(84): a(87) = a(85): a(88) = a(69): a(89) = a(70): a(90) = a(71): a(91) = a(72): a(92) = a(73):
a(93) = a(74): a(94) = a(75): a(95) = a(76): a(96) = a(77): a(97) = a(78): a(98) = a(79): a(99) = a(80):
a(100) = a(81): a(101) = a(82): a(102) = a(83):
a(103) = a(101): a(104) = a(102): a(105) = a(86): a(106) = a(87): a(107) = a(88): a(108) = a(89): a(109) = a(90):
a(110) = a(91): a(111) = a(92): a(112) = a(93): a(113) = a(94): a(114) = a(95): a(115) = a(96): a(116) = a(97):
a(117) = a(98): a(118) = a(99): a(119) = a(100):
a(120) = a(118): a(121) = a(119): a(122) = a(103): a(123) = a(104): a(124) = a(105): a(125) = a(106): a(126) = a(107):
a(127) = a(108): a(128) = a(109): a(129) = a(110): a(130) = a(111): a(131) = a(112): a(132) = a(113): a(133) = a(114):
a(134) = a(115): a(135) = a(116): a(136) = a(117):
a(137) = a(135): a(138) = a(136): a(139) = a(120): a(140) = a(121): a(141) = a(122): a(142) = a(123): a(143) = a(124):
a(144) = a(125): a(145) = a(126): a(146) = a(127): a(147) = a(128): a(148) = a(129): a(149) = a(130): a(150) = a(131):
a(151) = a(132): a(152) = a(133): a(153) = a(134):
a(154) = a(152): a(155) = a(153): a(156) = a(137): a(157) = a(138): a(158) = a(139): a(159) = a(140): a(160) = a(141):
a(161) = a(142): a(162) = a(143): a(163) = a(144): a(164) = a(145): a(165) = a(146): a(166) = a(147): a(167) = a(148):
a(168) = a(149): a(169) = a(150): a(170) = a(151):
a(171) = a(169): a(172) = a(170): a(173) = a(154): a(174) = a(155): a(175) = a(156): a(176) = a(157): a(177) = a(158):
a(178) = a(159): a(179) = a(160): a(180) = a(161): a(181) = a(162): a(182) = a(163): a(183) = a(164): a(184) = a(165):
a(185) = a(166): a(186) = a(167): a(187) = a(168):
a(188) = a(186): a(189) = a(187): a(190) = a(171): a(191) = a(172): a(192) = a(173): a(193) = a(174): a(194) = a(175):
a(195) = a(176): a(196) = a(177): a(197) = a(178): a(198) = a(179): a(199) = a(180): a(200) = a(181): a(201) = a(182):
a(202) = a(183): a(203) = a(184): a(204) = a(185):
a(205) = a(203): a(206) = a(204): a(207) = a(188): a(208) = a(189): a(209) = a(190): a(210) = a(191): a(211) = a(192):
a(212) = a(193): a(213) = a(194): a(214) = a(195): a(215) = a(196): a(216) = a(197): a(217) = a(198): a(218) = a(199):
a(219) = a(200): a(220) = a(201): a(221) = a(202):
a(222) = a(220): a(223) = a(221): a(224) = a(205): a(225) = a(206): a(226) = a(207): a(227) = a(208): a(228) = a(209):
a(229) = a(210): a(230) = a(211): a(231) = a(212): a(232) = a(213): a(233) = a(214): a(234) = a(215): a(235) = a(216):
a(236) = a(217): a(237) = a(218): a(238) = a(219):
a(239) = a(237): a(240) = a(238): a(241) = a(222): a(242) = a(223): a(243) = a(224): a(244) = a(225): a(245) = a(226):
a(246) = a(227): a(247) = a(228): a(248) = a(229): a(249) = a(230): a(250) = a(231): a(251) = a(232): a(252) = a(233):
a(253) = a(234): a(254) = a(235): a(255) = a(236):
a(256) = a(254): a(257) = a(255): a(258) = a(239): a(259) = a(240): a(260) = a(241): a(261) = a(242): a(262) = a(243):
a(263) = a(244): a(264) = a(245): a(265) = a(246): a(266) = a(247): a(267) = a(248): a(268) = a(249): a(269) = a(250):
a(270) = a(251): a(271) = a(252): a(272) = a(253):
Return
' Exclude solutions with identical numbers in row
900 fl1 = 1
For i1 = 273 To 289
b(i1 - 272) = a(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 n9 > 1 Then k2 = k2 + 18
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 17
For i2 = 1 To 17
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3) ''a(i3) ''
Next i2
Next i1
Return
End Sub
