' Generates Associated Semi-Latin Squares Order 9
' Pan Magic Sub Squares Order 5, Simple Magic Sub Squares Order 4
' Tested with Office 2007 under Windows 7
Sub CompLat9b()
Dim a(81), a1(9), b(81)
y = MsgBox("Locked", vbCritical, "Routine CompLat9b")
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
' Pan Magic 5 x 5 (1)
For j77 = m1 To m2 'a(77)
a(77) = a1(j77)
For j76 = m1 To m2 'a(76)
a(76) = a1(j76)
If a(76) = a(77) Then GoTo 760
For j75 = m1 To m2 'a(75)
a(75) = a1(j75)
If a(75) = a(76) Or a(75) = a(77) Then GoTo 750
For j74 = m1 To m2 'a(74)
a(74) = a1(j74)
If a(74) = a(75) Or a(74) = a(76) Or a(74) = a(77) Then GoTo 740
a(73) = 5 * s1 / 9 - a(74) - a(75) - a(76) - a(77)
If a(73) < a1(m1) Or a(73) > a1(m2) Then GoTo 740
a(68) = -s1 / 9 + a(74) + a(75)
If a(68) < a1(m1) Or a(68) > a1(m2) Then GoTo 740
For j67 = m1 To m2 'a(67)
a(67) = a1(j67)
a(56) = -s1 / 9 + a(67) + a(75)
If a(56) < a1(m1) Or a(56) > a1(m2) Then GoTo 670
a(47) = 6 * s1 / 9 - a(67) - a(74) - a(75) - a(76) - a(77)
If a(47) < a1(m1) Or a(47) > a1(m2) Then GoTo 670
a(40) = 5 * s1 / 9 - a(67) - a(75) - a(76) - a(77)
If a(40) < a1(m1) Or a(40) > a1(m2) Then GoTo 670
For j66 = m1 To m2 'a(66)
a(66) = a1(j66)
a(58) = 6 * s1 / 9 - a(66) - a(67) - a(74) - a(75) - a(76)
If a(58) < a1(m1) Or a(58) > a1(m2) Then GoTo 660
a(55) = -5 * s1 / 9 + a(66) + a(67) + a(74) + a(75) + a(76) + a(77)
If a(55) < a1(m1) Or a(55) > a1(m2) Then GoTo 660
a(49) = -6 * s1 / 9 + a(66) + a(67) + a(74) + 2 * a(75) + a(76) + a(77)
If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 660
a(46) = 5 * s1 / 9 - a(66) - a(67) - a(75) - a(76)
If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 660
a(39) = 5 * s1 / 9 - a(66) - a(74) - a(75) - a(76)
If a(39) < a1(m1) Or a(39) > a1(m2) Then GoTo 660
For j65 = m1 To m2 'a(65)
a(65) = a1(j65)
a(64) = 6 * s1 / 9 - a(65) - a(66) - a(67) - a(74) - a(75)
If a(64) < a1(m1) Or a(64) > a1(m2) Then GoTo 650
a(59) = a(65) + a(66) - a(77)
If a(59) < a1(m1) Or a(59) > a1(m2) Then GoTo 650
a(57) = 5 * s1 / 9 - a(65) - a(66) - a(67) - a(75)
If a(57) < a1(m1) Or a(57) > a1(m2) Then GoTo 650
a(50) = 5 * s1 / 9 - a(65) - a(66) - a(74) - a(75)
If a(50) < a1(m1) Or a(50) > a1(m2) Then GoTo 650
a(48) = -5 * s1 / 9 + a(65) + a(66) + a(67) + a(74) + a(75) + a(76)
If a(48) < a1(m1) Or a(48) > a1(m2) Then GoTo 650
a(38) = -a(65) + a(76) + a(77)
If a(38) < a1(m1) Or a(38) > a1(m2) Then GoTo 650
a(37) = -6 * s1 / 9 + a(65) + a(66) + a(67) + a(74) + 2 * a(75) + a(76)
If a(37) < a1(m1) Or a(37) > a1(m2) Then GoTo 650
'Check Rows, Columns, Diagonals 5 x 5 (Back Check)
GoSub 900: If fl1 = 0 Then GoTo 650
' Pan Magic 5 x 5 (2)
a(42) = p9 - a(40): a(34) = p9 - a(48): a(24) = p9 - a(58): a(14) = p9 - a(68)
a(43) = p9 - a(39): a(33) = p9 - a(49): a(23) = p9 - a(59): a(9) = p9 - a(73)
a(44) = p9 - a(38): a(32) = p9 - a(50): a(18) = p9 - a(64): a(8) = p9 - a(74)
a(45) = p9 - a(37): a(27) = p9 - a(55): a(17) = p9 - a(65): a(7) = p9 - a(75)
a(36) = p9 - a(46): a(26) = p9 - a(56): a(16) = p9 - a(66): a(6) = p9 - a(76)
a(35) = p9 - a(47): a(25) = p9 - a(57): a(15) = p9 - a(67): a(5) = p9 - a(77)
'Check Row 5
For i1 = 1 To 9: b(i1) = a(i1 + 36): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 650
'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 650
' Simple Magic 4 x 4 (1)
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(2) = p9 - a(80)
For j79 = m1 To m2 'a(79)
a(79) = a1(j79)
If a(79) = a(80) Or a(79) = a(81) Then GoTo 790
a(3) = p9 - a(79)
a(78) = 4 * s1 / 9 - a(79) - a(80) - a(81)
If a(78) <= a1(m1) Or a(78) > a1(m2) Then GoTo 790
If a(78) = a(79) Or a(78) = a(80) Or a(78) = a(81) Then GoTo 790
a(4) = p9 - a(78)
'Check Row 1
For i1 = 1 To 9: b(i1) = a(i1 + 72): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 790
For j72 = m1 To m2 'a(72)
a(72) = a1(j72)
If a(72) = a(81) Then GoTo 720
a(10) = p9 - a(72)
For j71 = m1 To m2 'a(71)
a(71) = a1(j71)
If a(71) = a(72) Then GoTo 710
If a(71) = a(80) Then GoTo 710
a(11) = p9 - a(71)
For j70 = m1 To m2 'a(70)
a(70) = a1(j70)
If a(70) = a(71) Or a(70) = a(72) Then GoTo 700
If a(70) = a(79) Then GoTo 700
a(12) = p9 - a(70)
a(69) = 4 * s1 / 9 - a(70) - a(71) - a(72)
If a(69) <= a1(m1) Or a(69) > a1(m2) Then GoTo 700
If a(69) = a(70) Or a(69) = a(71) Or a(69) = a(72) Then GoTo 700
If a(69) = a(78) Then GoTo 700
a(13) = p9 - a(69)
'Check Row 2
For i1 = 1 To 9: b(i1) = a(i1 + 63): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 700
For j63 = m1 To m2 'a(63)
a(63) = a1(j63)
a(19) = p9 - a(63)
a(62) = a(63) - a(70) + a(72) - a(78) + a(81)
If a(62) < a1(m1) Or a(62) > a1(m2) Then GoTo 630
a(20) = p9 - a(62)
a(61) = 4 * s1 / 9 - a(63) - a(71) - a(72) + a(78) - a(81)
If a(61) < a1(m1) Or a(61) > a1(m2) Then GoTo 630
a(21) = p9 - a(61)
a(60) = -a(63) + a(70) + a(71)
If a(60) < a1(m1) Or a(60) > a1(m2) Then GoTo 630
a(22) = p9 - a(60)
'Check Row 3
For i1 = 1 To 9: b(i1) = a(i1 + 54): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 630
a(54) = 4 * s1 / 9 - a(62) - a(70) - a(78)
If a(54) < a1(m1) Or a(54) > a1(m2) Then GoTo 630
a(28) = p9 - a(54)
a(53) = -4 * s1 / 9 - a(63) + a(69) + 2 * a(70) + 2 * a(78) + a(79)
If a(53) < a1(m1) Or a(53) > a1(m2) Then GoTo 630
a(29) = p9 - a(53)
a(52) = a(63) - a(69) - 2 * a(70) + a(80) + 2 * a(81)
If a(52) < a1(m1) Or a(52) > a1(m2) Then GoTo 630
a(30) = p9 - a(52)
a(51) = a(63) + a(72) - a(78)
If a(51) < a1(m1) Or a(51) > a1(m2) Then GoTo 630
a(31) = p9 - a(51)
'Check Row 4
For i1 = 1 To 9: b(i1) = a(i1 + 45): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 630
'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 630
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers)
' Cells(1, 1).Value = n9
630 Next j63
700 Next j70
710 Next j71
720 Next j72
790 Next j79
800 Next j80
810 Next j81
650 Next j65
660 Next j66
670 Next j67
740 Next j74
750 Next j75
760 Next j76
770 Next j77
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CompLat9b")
End
' Exclude solutions with identical numbers in rows, columns, diagonals Latin Sub Squares (5 x 5)
900 fl1 = 1
' Rows
i1 = 28
For i0 = 1 To 5
i1 = i1 + 9
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3): b(5) = a(i1 + 4)
GoSub 860: If fl1 = 0 Then Return
Next i0
' Columns
i1 = 36
For i0 = 1 To 5
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 9): b(3) = a(i1 + 18): b(4) = a(i1 + 27): b(5) = a(i1 + 36):
GoSub 860: If fl1 = 0 Then Return
Next i0
' (Pan) Diagonals
b(1) = a(37): b(2) = a(47): b(3) = a(57): b(4) = a(67): b(5) = a(77): GoSub 860: If fl1 = 0 Then Return
b(1) = a(38): b(2) = a(48): b(3) = a(58): b(4) = a(68): b(5) = a(73): GoSub 860: If fl1 = 0 Then Return
b(1) = a(39): b(2) = a(49): b(3) = a(59): b(4) = a(64): b(5) = a(74): GoSub 860: If fl1 = 0 Then Return
b(1) = a(40): b(2) = a(50): b(3) = a(55): b(4) = a(65): b(5) = a(75): GoSub 860: If fl1 = 0 Then Return
b(1) = a(41): b(2) = a(46): b(3) = a(56): b(4) = a(66): b(5) = a(76): GoSub 860: If fl1 = 0 Then Return
b(1) = a(41): b(2) = a(49): b(3) = a(57): b(4) = a(65): b(5) = a(73): GoSub 860: If fl1 = 0 Then Return
b(1) = a(37): b(2) = a(50): b(3) = a(58): b(4) = a(66): b(5) = a(74): GoSub 860: If fl1 = 0 Then Return
b(1) = a(38): b(2) = a(46): b(3) = a(59): b(4) = a(67): b(5) = a(75): GoSub 860: If fl1 = 0 Then Return
b(1) = a(39): b(2) = a(47): b(3) = a(55): b(4) = a(68): b(5) = a(76): GoSub 860: If fl1 = 0 Then Return
b(1) = a(40): b(2) = a(48): b(3) = a(56): b(4) = a(64): b(5) = a(77): GoSub 860: If fl1 = 0 Then Return
Return
860 fl1 = 1
For j1 = 1 To 5
b2 = b(j1)
For j2 = (1 + j1) To 5
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
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
Cells(n9, 82).Value = n9
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 = 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
