' Generates Semi-Latin Squares of order 8
' Most Perfect Pan Magic Squares
' Tested with Office 365 under Windows 10
Sub CompLat8c()
Dim a1(8), a(64), b(8)
y = MsgBox("Locked", vbCritical, "Routine CompLat8c")
End
n2 = 0: n3 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 8: s1 = 28
For i1 = m1 To m2
a1(i1) = i1 - 1
Next i1
' Generate squares
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = a1(j64)
For j63 = m1 To m2 'a(63)
a(63) = a1(j63)
For j62 = m1 To m2 'a(62)
a(62) = a1(j62)
For j61 = m1 To m2 'a(61)
a(61) = a1(j61)
For j60 = m1 To m2 'a(60)
a(60) = a1(j60)
a(59) = s1 / 2 - a(60) - a(63) - a(64): If a(59) < a1(m1) Or a(59) > a1(m2) Then GoTo 600
a(58) = a(60) - a(62) + a(64): If a(58) < a1(m1) Or a(58) > a1(m2) Then GoTo 600
a(57) = s1 / 2 - a(60) - a(61) - a(64): If a(57) < a1(m1) Or a(57) > a1(m2) Then GoTo 600
' Check Row 1
For i1 = 57 To 64
b(i1 - 56) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 600
For j56 = m1 To m2 'a(56)
a(56) = a1(j56)
a(55) = s1 / 2 - a(56) - a(63) - a(64): If a(55) < a1(m1) Or a(55) > a1(m2) Then GoTo 560
a(54) = a(56) - a(62) + a(64): If a(54) < a1(m1) Or a(54) > a1(m2) Then GoTo 560
a(53) = s1 / 2 - a(56) - a(61) - a(64): If a(53) < a1(m1) Or a(53) > a1(m2) Then GoTo 560
a(52) = a(56) - a(60) + a(64): If a(52) < a1(m1) Or a(52) > a1(m2) Then GoTo 560
a(51) = -a(56) + a(60) + a(63): If a(51) < a1(m1) Or a(51) > a1(m2) Then GoTo 560
a(50) = a(56) - a(60) + a(62): If a(50) < a1(m1) Or a(50) > a1(m2) Then GoTo 560
a(49) = -a(56) + a(60) + a(61): If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 560
' Check Row 2
For i1 = 49 To 56
b(i1 - 48) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 560
For j48 = m1 To m2 'a(48)
a(48) = a1(j48)
a(47) = -a(48) + a(63) + a(64): If a(47) < a1(m1) Or a(47) > a1(m2) Then GoTo 480
a(46) = a(48) + a(62) - a(64): If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 480
a(45) = -a(48) + a(61) + a(64): If a(45) < a1(m1) Or a(45) > a1(m2) Then GoTo 480
a(44) = a(48) + a(60) - a(64): If a(44) < a1(m1) Or a(44) > a1(m2) Then GoTo 480
a(43) = s1 / 2 - a(48) - a(60) - a(63): If a(43) < a1(m1) Or a(43) > a1(m2) Then GoTo 480
a(42) = a(48) + a(60) - a(62): If a(42) < a1(m1) Or a(42) > a1(m2) Then GoTo 480
a(41) = s1 / 2 - a(48) - a(60) - a(61): If a(41) < a1(m1) Or a(41) > a1(m2) Then GoTo 480
' Check Row 3
For i1 = 41 To 48
b(i1 - 40) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 400
For j40 = m1 To m2 'a(40)
a(40) = a1(j40)
a(39) = s1 / 2 - a(40) - a(63) - a(64): If a(39) < a1(m1) Or a(39) > a1(m2) Then GoTo 400
a(38) = a(40) - a(62) + a(64): If a(38) < a1(m1) Or a(38) > a1(m2) Then GoTo 400
a(37) = s1 / 2 - a(40) - a(61) - a(64): If a(37) < a1(m1) Or a(37) > a1(m2) Then GoTo 400
a(36) = a(40) - a(60) + a(64): If a(36) < a1(m1) Or a(36) > a1(m2) Then GoTo 400
a(35) = -a(40) + a(60) + a(63): If a(35) < a1(m1) Or a(35) > a1(m2) Then GoTo 400
a(34) = a(40) - a(60) + a(62): If a(34) < a1(m1) Or a(34) > a1(m2) Then GoTo 400
a(33) = -a(40) + a(60) + a(61): If a(33) < a1(m1) Or a(33) > a1(m2) Then GoTo 400
' Check Row 4
For i1 = 33 To 40
b(i1 - 32) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 600
a(28) = s1 / 4 - a(64): a(27) = s1 / 4 - a(63): a(26) = s1 / 4 - a(62): a(25) = s1 / 4 - a(61):
a(32) = s1 / 4 - a(60): a(31) = s1 / 4 - a(59): a(30) = s1 / 4 - a(58): a(29) = s1 / 4 - a(57):
a(24) = s1 / 4 - a(52): a(23) = s1 / 4 - a(51): a(22) = s1 / 4 - a(50): a(21) = s1 / 4 - a(49):
a(20) = s1 / 4 - a(56): a(19) = s1 / 4 - a(55): a(18) = s1 / 4 - a(54): a(17) = s1 / 4 - a(53):
a(16) = s1 / 4 - a(44): a(15) = s1 / 4 - a(43): a(14) = s1 / 4 - a(42): a(13) = s1 / 4 - a(41):
a(12) = s1 / 4 - a(48): a(11) = s1 / 4 - a(47): a(10) = s1 / 4 - a(46): a(9) = s1 / 4 - a(45):
a(8) = s1 / 4 - a(36): a(7) = s1 / 4 - a(35): a(6) = s1 / 4 - a(34): a(5) = s1 / 4 - a(33):
a(4) = s1 / 4 - a(40): a(3) = s1 / 4 - a(39): a(2) = s1 / 4 - a(38): a(1) = s1 / 4 - a(37):
'Check Diagonal 1
i2 = 1
For i1 = 1 To 8:
b(i1) = a(i2): i2 = i2 + 9
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 400
'Check Diagonal 2
i2 = 8
For i1 = 1 To 8:
b(i1) = a(i2): i2 = i2 + 7
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 400
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
' n9 = n9 + 1: GoSub 645 'Print results (selected numbers)
n9 = n9 + 1: GoSub 650 'Print results (squares)
400 Next j40
480 Next j48
560 Next j56
600 Next j60
610 Next j61
620 Next j62
630 Next j63
640 Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CompLat8c")
End
' Exclude solutions with identical numbers Latin Lines Order 8
1800 fl1 = 1
For j1 = 1 To 8
a2 = b(j1):
For j2 = (1 + j1) To 8
If a2 = b(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
' Print results (selected numbers)
645 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 65).Value = n9
Cells(1, 67).Value = n9
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
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 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
