' Generates Semi-Latin Squares of order 8
' Compact Associated Pan Magic Squares
' Tested with Office 365 under Windows 10
Sub CompLat8e()
Dim a(64), b(8)
y = MsgBox("Locked", vbCritical, "Routine CompLat8e")
End
n2 = 0: n3 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 8: s1 = 28
' Generate squares
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64 - 1
For j63 = m1 To m2 'a(63)
a(63) = j63 - 1
For j62 = m1 To m2 'a(62)
a(62) = j62 - 1
a(61) = 0.5 * s1 - a(62) - a(63) - a(64):
If a(61) < 0 Or a(61) > 7 Then GoTo 620:
For j60 = m1 To m2 'a(60)
a(60) = j60 - 1
a(59) = 0.5 * s1 - a(60) - a(63) - a(64): If a(59) < 0 Or a(59) > 7 Then GoTo 600:
a(58) = -0.5 * s1 + a(60) + a(62) + 2 * a(63) + a(64): If a(58) < 0 Or a(58) > 7 Then GoTo 600:
a(57) = 0.5 * s1 - a(60) - a(62) - a(63): If a(57) < 0 Or a(57) > 7 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) = j56 - 1
a(55) = 0.5 * s1 - a(56) - a(63) - a(64): If a(55) < 0 Or a(55) > 7 Then GoTo 560:
a(54) = a(56) - a(62) + a(64): If a(54) < 0 Or a(54) > 7 Then GoTo 560:
a(53) = -a(56) + a(62) + a(63): If a(53) < 0 Or a(53) > 7 Then GoTo 560:
a(52) = a(56) - a(60) + a(64): If a(52) < 0 Or a(52) > 7 Then GoTo 560:
a(51) = -a(56) + a(60) + a(63): If a(51) < 0 Or a(51) > 7 Then GoTo 560:
a(50) = 0.5 * s1 + a(56) - a(60) - a(62) - 2 * a(63): If a(50) < 0 Or a(50) > 7 Then GoTo 560:
a(49) = -a(56) + a(60) + a(62) + a(63) - a(64): If a(49) < 0 Or a(49) > 7 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) = j48 - 1
a(47) = -a(48) + a(63) + a(64): If a(47) < 0 Or a(47) > 7 Then GoTo 480:
a(46) = a(48) + a(62) - a(64): If a(46) < 0 Or a(46) > 7 Then GoTo 480:
a(45) = 0.5 * s1 - a(48) - a(62) - a(63): If a(45) < 0 Or a(45) > 7 Then GoTo 480:
a(44) = a(48) + a(60) - a(64): If a(44) < 0 Or a(44) > 7 Then GoTo 480:
a(43) = 0.5 * s1 - a(48) - a(60) - a(63): If a(43) < 0 Or a(43) > 7 Then GoTo 480:
a(42) = -0.5 * s1 + a(48) + a(60) + a(62) + 2 * a(63): If a(42) < 0 Or a(42) > 7 Then GoTo 480:
a(41) = 0.5 * s1 - a(48) - a(60) - a(62) - a(63) + a(64): If a(41) < 0 Or a(41) > 7 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 480
a(40) = 0.5 * s1 - a(48) - a(56) - a(64): If a(40) < 0 Or a(40) > 7 Then GoTo 480:
a(39) = a(48) + a(56) - a(63): If a(39) < 0 Or a(39) > 7 Then GoTo 480:
a(38) = 0.5 * s1 - a(48) - a(56) - a(62): If a(38) < 0 Or a(38) > 7 Then GoTo 480:
a(37) = -0.5 * s1 + a(48) + a(56) + a(62) + a(63) + a(64): If a(37) < 0 Or a(37) > 7 Then GoTo 480:
a(36) = 0.5 * s1 - a(48) - a(56) - a(60): If a(36) < 0 Or a(36) > 7 Then GoTo 480:
a(35) = -0.5 * s1 + a(48) + a(56) + a(60) + a(63) + a(64): If a(35) < 0 Or a(35) > 7 Then GoTo 480:
a(34) = s1 - a(48) - a(56) - a(60) - a(62) - 2 * a(63) - a(64): If a(34) < 0 Or a(34) > 7 Then GoTo 480:
a(33) = -0.5 * s1 + a(48) + a(56) + a(60) + a(62) + a(63): If a(33) < 0 Or a(33) > 7 Then GoTo 480:
' Check Row 4
For i1 = 33 To 40
b(i1 - 32) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 480
' Associated Pairs
i2 = 64
For i1 = 1 To 32
a(i1) = s1 / 4 - a(i2): i2 = i2 - 1
Next i1
' n9 = n9 + 1: GoSub 645 'Print results (selected numbers)
n9 = n9 + 1: GoSub 650 'Print results (squares)
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
''End
480 Next j48
560 Next j56
600 Next j60
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 CompLat8e")
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, 66).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
