' Generates (Semi) Latin Associated Compact Pan Magic Squares Order 9
' Tested with Office 2007 under Windows 7
Sub CompLat9c()
Dim a(81), a1(9), b(9)
y = MsgBox("Locked", vbCritical, "Routine CompLat9c")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 9: s1 = 36: p9 = 8
For i1 = 1 To 9
a1(i1) = i1 - 1
Next i1
' Generate data
Sheets("Klad1").Select
t1 = Timer
a(41) = 4
For j81 = m1 To m2 'a(81)
a(81) = a1(j81)
a(1) = p9 - a(81):
For j80 = m1 To m2 'a(80)
a(80) = a1(j80)
If a(80) = a(81) Then GoTo 800
a(79) = s1 / 3 - a(80) - a(81): If a(79) < a1(m1) Or a(79) > a1(m2) Then GoTo 800
a(3) = p9 - a(79): a(2) = p9 - a(80):
For j78 = m1 To m2 'a(78)
a(78) = a1(j78)
If a(78) = a(79) Or a(78) = a(80) Or a(78) = a(81) Then GoTo 780
a(4) = p9 - a(78):
For j77 = m1 To m2 'a(77)
a(77) = a1(j77)
If a(77) = a(78) Or a(77) = a(79) Or a(77) = a(80) Or a(77) = a(81) Then GoTo 770
a(76) = s1 / 3 - a(77) - a(78): If a(76) < a1(m1) Or a(76) > a1(m2) Then GoTo 770
If a(76) = a(77) Or a(76) = a(78) Or a(76) = a(79) Or a(76) = a(80) Or a(76) = a(81) Then GoTo 770
a(6) = p9 - a(76): a(5) = p9 - a(77):
For j75 = m1 To m2 'a(75)
a(75) = a1(j75)
If a(75) = a(77) Or a(75) = a(78) Or a(75) = a(79) Or a(75) = a(80) Or a(75) = a(81) Then GoTo 750
If a(75) = a(76) Then GoTo 750
a(7) = p9 - a(75):
For j74 = m1 To m2 'a(74)
a(74) = a1(j74)
If a(74) = a(77) Or a(74) = a(78) Or a(74) = a(79) Or a(74) = a(80) Or a(74) = a(81) Then GoTo 740
If a(74) = a(75) Or a(74) = a(76) Then GoTo 740
a(73) = s1 / 3 - a(74) - a(75): If a(73) < a1(m1) Or a(73) > a1(m2) Then GoTo 740
a(44) = s1 / 9 + a(74) - a(80): If a(44) < a1(m1) Or a(44) > a1(m2) Then GoTo 740
If a(44) = a(41) Then GoTo 740
a(38) = p9 - a(44): a(9) = p9 - a(73): a(8) = p9 - a(74):
For j72 = m1 To m2 'a(72)
a(72) = a1(j72)
a(69) = a(72) + a(74) + a(75) - a(77) - 2 * a(78) + a(81):
If a(69) < a1(m1) Or a(69) > a1(m2) Then GoTo 720
If a(69) = a(72) Then GoTo 720
a(66) = a(72) + a(74) - a(80): If a(66) < a1(m1) Or a(66) > a1(m2) Then GoTo 720
If a(66) = a(69) Or a(66) = a(72) Then GoTo 720
a(63) = s1 / 3 - a(72) - a(81): If a(63) < a1(m1) Or a(63) > a1(m2) Then GoTo 720
a(60) = s1 / 3 - a(72) - a(74) - a(75) + a(77) + a(78) - a(81):
If a(60) < a1(m1) Or a(60) > a1(m2) Then GoTo 720
If a(60) = a(63) Then GoTo 720
a(57) = s1 / 3 - a(72) - a(74) - a(75) + a(80): If a(57) < a1(m1) Or a(57) > a1(m2) Then GoTo 720
If a(57) = a(60) Or a(57) = a(63) Then GoTo 720
a(52) = s1 / 9 - a(72) + a(77) + a(78) - 1 * a(81): If a(52) < a1(m1) Or a(52) > a1(m2) Then GoTo 720
a(49) = s1 / 9 - a(72) + a(80): If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 720
If a(49) = a(52) Then GoTo 720
a(46) = s1 / 9 - a(72) - a(74) - a(75) + a(77) + a(78) + a(80):
If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 720
If a(46) = a(49) Or a(46) = a(52) Then GoTo 720
a(36) = p9 - a(46): a(33) = p9 - a(49): a(30) = p9 - a(52): a(25) = p9 - a(57):
a(22) = p9 - a(60): a(19) = p9 - a(63): a(16) = p9 - a(66): a(13) = p9 - a(69):
a(10) = p9 - a(72):
For j71 = m1 To m2 'a(71)
a(71) = a1(j71)
If a(71) = a(72) Or a(71) = a(69) Or a(71) = a(66) Then GoTo 710
a(70) = s1 / 3 - a(71) - a(72): If a(70) < a1(m1) Or a(70) > a1(m2) Then GoTo 710
If a(70) = a(71) Or a(70) = a(72) Or a(70) = a(69) Or a(70) = a(66) Then GoTo 710
a(68) = a(71) - a(74) + a(80): If a(68) < a1(m1) Or a(68) > a1(m2) Then GoTo 710
If a(68) = a(70) Or a(68) = a(71) Or a(68) = a(72) Or a(68) = a(69) Or a(68) = a(66) Then GoTo 710
a(67) = s1 / 3 - a(71) - a(72) - a(75) + a(77) + 2 * a(78) - a(80) - a(81):
If a(67) < a1(m1) Or a(67) > a1(m2) Then GoTo 710
If a(67) = a(70) Or a(67) = a(71) Or a(67) = a(72) Or a(67) = a(69) Or a(67) = a(66) Then GoTo 710
If a(67) = a(68) Then GoTo 710
a(65) = a(71) - 2 * a(74) + 2 * a(80): If a(65) < a1(m1) Or a(65) > a1(m2) Then GoTo 710
If a(65) = a(70) Or a(65) = a(71) Or a(65) = a(72) Or a(65) = a(69) Or a(65) = a(66) Then GoTo 710
If a(65) = a(67) Or a(65) = a(68) Then GoTo 710
a(64) = s1 / 3 - a(71) - a(72) + a(74) - a(80): If a(64) < a1(m1) Or a(64) > a1(m2) Then GoTo 710
a(62) = s1 / 3 - a(71) - a(80): If a(62) < a1(m1) Or a(62) > a1(m2) Then GoTo 710
If a(62) = a(63) Or a(62) = a(60) Or a(62) = a(57) Then GoTo 710
a(61) = -s1 / 3 + a(71) + a(72) + a(80) + a(81): If a(61) < a1(m1) Or a(61) > a1(m2) Then GoTo 710
If a(61) = a(62) Or a(61) = a(63) Or a(61) = a(60) Or a(61) = a(57) Then GoTo 710
a(59) = s1 / 3 - a(71) + a(74) - a(77) - a(80): If a(59) < a1(m1) Or a(59) > a1(m2) Then GoTo 710
If a(59) = a(61) Or a(59) = a(62) Or a(59) = a(63) Or a(59) = a(60) Or a(59) = a(57) Then GoTo 710
a(58) = -s1 / 3 + a(71) + a(72) + a(75) - a(78) + a(80) + a(81):
If a(58) < a1(m1) Or a(58) > a1(m2) Then GoTo 710
If a(58) = a(61) Or a(58) = a(62) Or a(58) = a(63) Or a(58) = a(60) Or a(58) = a(57) Then GoTo 710
If a(58) = a(59) Then GoTo 710
a(56) = s1 / 3 - a(71) + a(74) - 2 * a(80): If a(56) < a1(m1) Or a(56) > a1(m2) Then GoTo 710
If a(56) = a(61) Or a(56) = a(62) Or a(56) = a(63) Or a(56) = a(60) Or a(56) = a(57) Then GoTo 710
If a(56) = a(58) Or a(56) = a(59) Then GoTo 710
a(55) = -s1 / 3 + a(71) + a(72) + a(75) + a(80): If a(55) < a1(m1) Or a(55) > a1(m2) Then GoTo 710
a(54) = -2 * s1 / 9 + a(71) + a(72) - a(78) + a(80) + a(81):
If a(54) < a1(m1) Or a(54) > a1(m2) Then GoTo 710
If a(54) = a(46) Or a(54) = a(49) Or a(54) = a(52) Then GoTo 710
a(53) = 4 * s1 / 9 - a(71) - a(77) - a(80): If a(53) < a1(m1) Or a(53) > a1(m2) Then GoTo 710
If a(53) = a(54) Or a(53) = a(46) Or a(53) = a(49) Or a(53) = a(52) Then GoTo 710
a(51) = -2 * s1 / 9 + a(71) + a(72) + a(80): If a(51) < a1(m1) Or a(51) > a1(m2) Then GoTo 710
If a(51) = a(53) Or a(51) = a(54) Or a(51) = a(46) Or a(51) = a(49) Or a(51) = a(52) Then GoTo 710
a(50) = 4 * s1 / 9 - a(71) - 2 * a(80): If a(50) < a1(m1) Or a(50) > a1(m2) Then GoTo 710
If a(50) = a(53) Or a(50) = a(54) Or a(50) = a(46) Or a(50) = a(49) Or a(50) = a(52) Then GoTo 710
If a(50) = a(51) Then GoTo 710
a(48) = -2 * s1 / 9 + a(71) + a(72) + a(75) - a(78) + a(80):
If a(48) < a1(m1) Or a(48) > a1(m2) Then GoTo 710
If a(48) = a(53) Or a(48) = a(54) Or a(48) = a(46) Or a(48) = a(49) Or a(48) = a(52) Then GoTo 710
If a(48) = a(50) Or a(48) = a(51) Then GoTo 710
a(47) = 4 * s1 / 9 - a(71) + a(74) - a(77) - 2 * a(80):
If a(47) < a1(m1) Or a(47) > a1(m2) Then GoTo 710
If a(47) = a(53) Or a(47) = a(54) Or a(47) = a(46) Or a(47) = a(49) Or a(47) = a(52) Then GoTo 710
If a(47) = a(48) Or a(47) = a(50) Or a(47) = a(51) Then GoTo 710
a(45) = 4 * s1 / 9 - a(71) - 2 * a(72) - a(74) - a(75) + a(77) + 2 * a(78) - a(81):
If a(45) < a1(m1) Or a(45) > a1(m2) Then GoTo 710
If a(45) = a(38) Or a(45) = a(41) Or a(45) = a(44) Then GoTo 710
a(43) = -2 * s1 / 9 + a(71) + 2 * a(72) + a(75) - a(77) - 2 * a(78) + a(80) + a(81):
If a(43) < a1(m1) Or a(43) > a1(m2) Then GoTo 710
If a(43) = a(45) Or a(43) = a(38) Or a(43) = a(41) Or a(43) = a(44) Then GoTo 710
a(42) = 4 * s1 / 9 - a(71) - 2 * a(72): If a(42) < a1(m1) Or a(42) > a1(m2) Then GoTo 710
If a(42) = a(43) Or a(42) = a(45) Or a(42) = a(38) Or a(42) = a(41) Or a(42) = a(44) Then GoTo 710
a(40) = p9 - a(42): a(39) = p9 - a(43): a(37) = p9 - a(45): a(35) = p9 - a(47):
a(34) = p9 - a(48): a(32) = p9 - a(50): a(31) = p9 - a(51): a(29) = p9 - a(53):
a(28) = p9 - a(54): a(27) = p9 - a(55): a(26) = p9 - a(56): a(24) = p9 - a(58):
a(23) = p9 - a(59): a(21) = p9 - a(61): a(20) = p9 - a(62): a(18) = p9 - a(64):
a(17) = p9 - a(65): a(15) = p9 - a(67): a(14) = p9 - a(68): a(12) = p9 - a(70):
a(11) = p9 - a(71):
'Check Diagonal Tright - Bleft
i2 = 1
For i1 = 1 To 9:
i2 = i2 + 8
b(i1) = a(i2):
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 710
'Check Diagonal Tleft - Bright
i2 = -9
For i1 = 1 To 9:
i2 = i2 + 10
b(i1) = a(i2):
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 710
GoSub 1500: If fl1 = 0 Then GoTo 710 'Check Sub squares 3 x 3
' GoSub 1600: If fl1 = 0 Then GoTo 710 'Check Columns (Option)
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers
' Cells(1, 1).Value = n9 'Counting
''End
710 Next j71
720 Next j72
740 Next j74
750 Next j75
770 Next j77
780 Next j78
800 Next j80
810 Next j81
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CompLat9c")
End
' Check Sub squares 3 x 3
1500 fl1 = 1
b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(10): b(5) = a(11): b(6) = a(12):
b(7) = a(19): b(8) = a(20): b(9) = a(21): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(5): b(3) = a(6): b(4) = a(13): b(5) = a(14): b(6) = a(15):
b(7) = a(22): b(8) = a(23): b(9) = a(24): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(7): b(2) = a(8): b(3) = a(9): b(4) = a(16): b(5) = a(17): b(6) = a(18):
b(7) = a(25): b(8) = a(26): b(9) = a(27): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(28): b(2) = a(29): b(3) = a(30): b(4) = a(37): b(5) = a(38): b(6) = a(39):
b(7) = a(46): b(8) = a(47): b(9) = a(48): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(31): b(2) = a(32): b(3) = a(33): b(4) = a(40): b(5) = a(41): b(6) = a(42):
b(7) = a(49): b(8) = a(50): b(9) = a(51): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(34): b(2) = a(35): b(3) = a(36): b(4) = a(43): b(5) = a(44): b(6) = a(45):
b(7) = a(52): b(8) = a(53): b(9) = a(54): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(55): b(2) = a(56): b(3) = a(57): b(4) = a(64): b(5) = a(65): b(6) = a(66):
b(7) = a(73): b(8) = a(74): b(9) = a(75): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(58): b(2) = a(59): b(3) = a(60): b(4) = a(67): b(5) = a(68): b(6) = a(69):
b(7) = a(76): b(8) = a(77): b(9) = a(78): GoSub 1800: If fl1 = 0 Then Return
b(1) = a(61): b(2) = a(62): b(3) = a(63): b(4) = a(70): b(5) = a(71): b(6) = a(72):
b(7) = a(79): b(8) = a(80): b(9) = a(81): GoSub 1800: If fl1 = 0 Then Return
Return
' Check Columns (Option)
1600 fl1 = 1
For i2 = 1 To 9
For i1 = 1 To 9:
b(i1) = a(i2): i2 = i2 + 9
Next i1
GoSub 1800: If fl1 = 0 Then Return
Next i2
Return
' Exclude solutions with identical numbers Latin Lines Order 9
1800 fl1 = 1
For j1 = 1 To 9
a2 = b(j1):
For j2 = (1 + j1) To 9
If a2 = b(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
