' Generates Ultra Magic (Latin Diagonal) Squares Order 11
' Tested with Office 2007 under Windows 7
Sub UltraLat11()
Dim a(121), b(11), c(121)
Dim a2(11, 11), b2(11, 11), c2(11, 11)
y = MsgBox("Blocked", vbInformation, "UltraLat11")
End
Sheets("Klad1").Select
s1 = 55: k1 = 1: k2 = 1
For j121 = 1 To 11
a(121) = j121 - 1
a(2) = a(121)
a(120) = 2 * s1 / 11 - a(121)
a(115) = 3 * s1 / 11 - a(120) - a(121)
If a(115) < 0 Or a(115) > 10 Then GoTo 1210
If a(115) = a(120) Or a(115) = a(121) Then GoTo 1210
a(7) = 3 * s1 / 11 - a(120) - a(121)
a(1) = a(120)
For j119 = 1 To 11
a(119) = j119 - 1
If a(119) = a(115) Or a(119) = a(120) Or a(119) = a(121) Then GoTo 1190
a(111) = 2 * s1 / 11 - a(119)
If a(111) = a(115) Or a(111) = a(119) Or a(111) = a(120) Or a(111) = a(121) Then GoTo 1190
a(11) = a(119)
a(3) = 2 * s1 / 11 - a(119)
For j118 = 1 To 11
a(118) = j118 - 1
If a(118) = a(111) Or a(118) = a(115) Or a(118) = a(119) Or a(118) = a(120) Or a(118) = a(121) Then GoTo 1180
a(112) = 2 * s1 / 11 - a(118)
If a(112) = a(111) Or a(112) = a(115) Or a(112) = a(118) Or a(112) = a(119) Or a(112) = a(120) Or a(112) = a(121) Then GoTo 1180
a(10) = a(118)
a(4) = 2 * s1 / 11 - a(118)
For j117 = 1 To 11
a(117) = j117 - 1
a(113) = 2 * s1 / 11 - a(117)
a(9) = a(117)
a(5) = 2 * s1 / 11 - a(117)
For j116 = 1 To 11
a(116) = j116 - 1
a(114) = 2 * s1 / 11 - a(116)
a(8) = a(116)
a(6) = 2 * s1 / 11 - a(116)
GoSub 900: If fl1 = 0 Then GoTo 1160 'Check Latin Row
GoSub 500 'Complete Latin Square
GoSub 300: If fl1 = 0 Then GoTo 1160 'Complete Ultra Magic Square
'' n9 = n9 + 1: GoSub 650 'Print Squares
n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
1160 Next j116
1170 Next j117
1180 Next j118
1190 Next j119
1210 Next j121
End
' Complete square
500
a(12) = a(10): a(13) = a(11): a(14) = a(1): a(15) = a(2): a(16) = a(3): a(17) = a(4):
a(18) = a(5): a(19) = a(6): a(20) = a(7): a(21) = a(8): a(22) = a(9):
a(23) = a(21): a(24) = a(22): a(25) = a(12): a(26) = a(13): a(27) = a(14): a(28) = a(15):
a(29) = a(16): a(30) = a(17): a(31) = a(18): a(32) = a(19): a(33) = a(20):
a(34) = a(32): a(35) = a(33): a(36) = a(23): a(37) = a(24): a(38) = a(25): a(39) = a(26):
a(40) = a(27): a(41) = a(28): a(42) = a(29): a(43) = a(30): a(44) = a(31):
a(45) = a(43): a(46) = a(44): a(47) = a(34): a(48) = a(35): a(49) = a(36): a(50) = a(37):
a(51) = a(38): a(52) = a(39): a(53) = a(40): a(54) = a(41): a(55) = a(42):
a(56) = a(54): a(57) = a(55): a(58) = a(45): a(59) = a(46): a(60) = a(47): a(61) = a(48):
a(62) = a(49): a(63) = a(50): a(64) = a(51): a(65) = a(52): a(66) = a(53):
a(67) = a(65): a(68) = a(66): a(69) = a(56): a(70) = a(57): a(71) = a(58): a(72) = a(59):
a(73) = a(60): a(74) = a(61): a(75) = a(62): a(76) = a(63): a(77) = a(64):
a(78) = a(76): a(79) = a(77): a(80) = a(67): a(81) = a(68): a(82) = a(69): a(83) = a(70):
a(84) = a(71): a(85) = a(72): a(86) = a(73): a(87) = a(74): a(88) = a(75):
a(89) = a(87): a(90) = a(88): a(91) = a(78): a(92) = a(79): a(93) = a(80): a(94) = a(81):
a(95) = a(82): a(96) = a(83): a(97) = a(84): a(98) = a(85): a(99) = a(86):
a(100) = a(98): a(101) = a(99): a(102) = a(89): a(103) = a(90): a(104) = a(91): a(105) = a(92):
a(106) = a(93): a(107) = a(94): a(108) = a(95): a(109) = a(96): a(110) = a(97):
Return
' Calculate and Check Ultra Magic Square
300 fl1 = 1
' Load a2()
i3 = 0
For i1 = 1 To 11
For i2 = 1 To 11
i3 = i3 + 1
a2(i1, i2) = a(i3)
Next i2
Next i1
' Determine Transposed b2()
For i1 = 1 To 11
For i2 = 1 To 11
b2(i1, i2) = a2(i2, i1)
Next i2
Next i1
' Calculate Ultra Magic Square c2(), c()
i3 = 0
For i1 = 1 To 11
For i2 = 1 To 11
c2(i1, i2) = a2(i1, i2) + 11 * b2(i1, i2) + 1
i3 = i3 + 1: c(i3) = c2(i1, i2)
Next i2
Next i1
' Check Identical Numbers
For i1 = 1 To 121
c20 = c(i1)
For i2 = (1 + i1) To 121
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 = 111 To 121
b(i1 - 110) = a(i1)
Next i1
For j1 = 1 To 11
b20 = b(j1)
For j2 = (1 + j1) To 11
If b20 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 12: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 12
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 11
For i2 = 1 To 11
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3) ''a(i3)
Next i2
Next i1
Return
End Sub
