' Generates Ultra Magic (Latin Diagonal) Squares Order 13
' Tested with Office 365 under Windows 10
Sub UltraLat13()
Dim a(169), b(13), c(169)
Dim a2(13, 13), b2(13, 13), c2(13, 13)
y = MsgBox("Blocked", vbInformation, "UltraLat13")
End
Sheets("Klad1").Select
s1 = 78: k1 = 1: k2 = 1
m1 = 1: m2 = 13
For j169 = m1 To m2
a(169) = j169 - 1
a(2) = a(169)
a(168) = 2 * s1 / 13 - a(169)
a(1) = a(168)
a(8) = 3 * s1 / 13 - a(168) - a(169)
a(162) = 3 * s1 / 13 - a(168) - a(169)
If a(162) < 0 Or a(162) > 12 Then GoTo 1690
If a(162) = a(168) Or a(162) = a(169) Then GoTo 1690
For j167 = m1 To m2
a(167) = j167 - 1
If a(167) = a(162) Or a(167) = a(168) Or a(167) = a(169) Then GoTo 1670
a(3) = 2 * s1 / 13 - a(167)
a(13) = a(167)
a(157) = 2 * s1 / 13 - a(167)
If a(157) = a(162) Or a(157) = a(167) Or a(157) = a(168) Or a(157) = a(169) Then GoTo 1670
For j166 = m1 To m2
a(166) = j166 - 1
If a(166) = a(157) Or a(166) = a(162) Or a(166) = a(167) Or a(166) = a(168) Or a(166) = a(169) Then GoTo 1660
a(4) = 2 * s1 / 13 - a(166)
a(12) = a(166)
a(158) = 2 * s1 / 13 - a(166)
If a(158) = a(157) Or a(158) = a(162) Or a(158) = a(166) Or a(158) = a(167) Or a(158) = a(168) Or a(158) = a(169) Then GoTo 1660
For j165 = m1 To m2
a(165) = j165 - 1
If a(165) = a(157) Or a(165) = a(162) Or a(165) = a(166) Or a(165) = a(167) Or a(165) = a(168) Or a(165) = a(169) Then GoTo 1650
If a(165) = a(158) Then GoTo 1650
a(5) = 2 * s1 / 13 - a(165)
a(11) = a(165)
a(159) = 2 * s1 / 13 - a(165)
If a(159) = a(157) Or a(159) = a(162) Or a(159) = a(166) Or a(159) = a(167) Or a(159) = a(168) Or a(159) = a(169) Then GoTo 1650
If a(159) = a(158) Or a(159) = a(165) Then GoTo 1650
For j164 = m1 To m2
a(164) = j164 - 1
If a(164) = a(157) Or a(164) = a(162) Or a(164) = a(166) Or a(164) = a(167) Or a(164) = a(168) Or a(164) = a(169) Then GoTo 1640
If a(164) = a(158) Or a(164) = a(159) Or a(164) = a(165) Then GoTo 1640
a(6) = 2 * s1 / 13 - a(164)
a(10) = a(164)
a(160) = 2 * s1 / 13 - a(164)
If a(160) = a(157) Or a(160) = a(162) Or a(160) = a(166) Or a(160) = a(167) Or a(160) = a(168) Or a(160) = a(169) Then GoTo 1640
If a(160) = a(158) Or a(160) = a(159) Or a(160) = a(164) Or a(160) = a(165) Then GoTo 1640
For j163 = m1 To m2
a(163) = j163 - 1
a(7) = 2 * s1 / 13 - a(163)
a(9) = a(163)
a(161) = 2 * s1 / 13 - a(163)
GoSub 900: If fl1 = 0 Then GoTo 1630 'Check Latin Row
GoSub 500 'Complete Latin Square
GoSub 300: If fl1 = 0 Then GoTo 1630 'Complete Ultra Magic Square
'' n9 = n9 + 1: GoSub 650 'Print Squares
n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
1630 Next j163
1640 Next j164
1650 Next j165
1660 Next j166
1670 Next j167
1690 Next j169
End
' Complete square
500
a(14) = a(12): a(15) = a(13): a(16) = a(1): a(17) = a(2): a(18) = a(3): a(19) = a(4): a(20) = a(5):
a(21) = a(6): a(22) = a(7): a(23) = a(8): a(24) = a(9): a(25) = a(10): a(26) = a(11):
a(27) = a(25): a(28) = a(26): a(29) = a(14): a(30) = a(15): a(31) = a(16): a(32) = a(17): a(33) = a(18):
a(34) = a(19): a(35) = a(20): a(36) = a(21): a(37) = a(22): a(38) = a(23): a(39) = a(24):
a(40) = a(38): a(41) = a(39): a(42) = a(27): a(43) = a(28): a(44) = a(29): a(45) = a(30): a(46) = a(31):
a(47) = a(32): a(48) = a(33): a(49) = a(34): a(50) = a(35): a(51) = a(36): a(52) = a(37):
a(53) = a(51): a(54) = a(52): a(55) = a(40): a(56) = a(41): a(57) = a(42): a(58) = a(43): a(59) = a(44):
a(60) = a(45): a(61) = a(46): a(62) = a(47): a(63) = a(48): a(64) = a(49): a(65) = a(50):
a(66) = a(64): a(67) = a(65): a(68) = a(53): a(69) = a(54): a(70) = a(55): a(71) = a(56): a(72) = a(57):
a(73) = a(58): a(74) = a(59): a(75) = a(60): a(76) = a(61): a(77) = a(62): a(78) = a(63):
a(79) = a(77): a(80) = a(78): a(81) = a(66): a(82) = a(67): a(83) = a(68): a(84) = a(69): a(85) = a(70):
a(86) = a(71): a(87) = a(72): a(88) = a(73): a(89) = a(74): a(90) = a(75): a(91) = a(76):
a(92) = a(90): a(93) = a(91): a(94) = a(79): a(95) = a(80): a(96) = a(81): a(97) = a(82): a(98) = a(83):
a(99) = a(84): a(100) = a(85): a(101) = a(86): a(102) = a(87): a(103) = a(88): a(104) = a(89):
a(105) = a(103): a(106) = a(104): a(107) = a(92): a(108) = a(93): a(109) = a(94): a(110) = a(95): a(111) = a(96):
a(112) = a(97): a(113) = a(98): a(114) = a(99): a(115) = a(100): a(116) = a(101): a(117) = a(102):
a(118) = a(116): a(119) = a(117): a(120) = a(105): a(121) = a(106): a(122) = a(107): a(123) = a(108): a(124) = a(109):
a(125) = a(110): a(126) = a(111): a(127) = a(112): a(128) = a(113): a(129) = a(114): a(130) = a(115):
a(131) = a(129): a(132) = a(130): a(133) = a(118): a(134) = a(119): a(135) = a(120): a(136) = a(121): a(137) = a(122):
a(138) = a(123): a(139) = a(124): a(140) = a(125): a(141) = a(126): a(142) = a(127): a(143) = a(128):
a(144) = a(142): a(145) = a(143): a(146) = a(131): a(147) = a(132): a(148) = a(133): a(149) = a(134): a(150) = a(135):
a(151) = a(136): a(152) = a(137): a(153) = a(138): a(154) = a(139): a(155) = a(140): a(156) = a(141):
Return
' Calculate and Check Ultra Magic Square
300 fl1 = 1
' Load a2()
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
a2(i1, i2) = a(i3)
Next i2
Next i1
' Determine Transposed b2()
For i1 = 1 To 13
For i2 = 1 To 13
b2(i1, i2) = a2(i2, i1)
Next i2
Next i1
' Calculate Ultra Magic Square c2(), c()
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
c2(i1, i2) = a2(i1, i2) + 13 * b2(i1, i2) + 1
i3 = i3 + 1: c(i3) = c2(i1, i2)
Next i2
Next i1
' Check Identical Numbers
For i1 = 1 To 169
c20 = c(i1)
For i2 = (1 + i1) To 169
If c20 = c(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Exclude solutions with identical numbers in row
900 fl1 = 1
For i1 = 157 To 169
b(i1 - 156) = a(i1)
Next i1
For j1 = 1 To 13
b20 = b(j1)
For j2 = (1 + j1) To 13
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 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
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 13
For i2 = 1 To 13
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3) ''a(i3)
Next i2
Next i1
Return
End Sub
