' Generates Semi-Latin Squares of order 8
' Franklin Magic Squares
' Tested with Office 365 under Windows 10
Sub CompLat8d()
Dim a(64), b(64), c(64)
y = MsgBox("Locked", vbCritical, "Routine CompLat8d")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 8: s1 = 28
' Generate data
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 'a(61)
For j60 = m1 To m2 'a(60)
a(60) = j60 - 1
For j59 = m1 To m2 'a(59)
a(59) = j59 - 1
a(58) = -a(60) + a(62) + a(64)
If a(58) < 0 Or a(58) > 7 Then GoTo 590 'a(58)
a(57) = 0.5 * s1 - a(59) - a(62) - a(64)
If a(57) < 0 Or a(57) > 7 Then GoTo 590 'a(57)
' Check Row 1
For i1 = 57 To 64
b(i1 - 56) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 590
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) = 0.5 * s1 - a(56) - a(59) - a(64): If a(51) < 0 Or a(51) > 7 Then GoTo 560
a(50) = a(56) + a(60) - a(62): If a(50) < 0 Or a(50) > 7 Then GoTo 560
a(49) = -a(56) + a(59) + a(62): 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) = -a(48) + a(59) + a(64): If a(43) < 0 Or a(43) > 7 Then GoTo 480
a(42) = a(48) - a(60) + a(62): If a(42) < 0 Or a(42) > 7 Then GoTo 480
a(41) = 0.5 * s1 - a(48) - a(59) - a(62): 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) = a(48) + a(56) - a(59): If a(35) < 0 Or a(35) > 7 Then GoTo 480
a(34) = 0.5 * s1 - a(48) - a(56) + a(60) - a(62) - a(64): If a(34) < 0 Or a(34) > 7 Then GoTo 480
a(33) = -0.5 * s1 + a(48) + a(56) + a(59) + a(62) + a(64): 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
For j32 = m1 To m2 'a(32)
a(32) = j32 - 1
a(31) = -a(32) + a(63) + a(64): If a(31) < 0 Or a(31) > 7 Then GoTo 320
a(30) = a(32) + a(62) - a(64): If a(30) < 0 Or a(30) > 7 Then GoTo 320
a(29) = 0.5 * s1 - a(32) - a(62) - a(63): If a(29) < 0 Or a(29) > 7 Then GoTo 320
a(28) = a(32) + a(60) - a(64): If a(28) < 0 Or a(28) > 7 Then GoTo 320
a(27) = -a(32) + a(59) + a(64): If a(27) < 0 Or a(27) > 7 Then GoTo 320
a(26) = a(32) - a(60) + a(62): If a(26) < 0 Or a(26) > 7 Then GoTo 320
a(25) = 0.5 * s1 - a(32) - a(59) - a(62): If a(25) < 0 Or a(25) > 7 Then GoTo 320
' Check Row 5
For i1 = 25 To 32
b(i1 - 24) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 320
a(16) = -a(32) + a(48) + a(64): If a(16) < 0 Or a(16) > 7 Then GoTo 320
a(15) = a(32) - a(48) + a(63): If a(15) < 0 Or a(15) > 7 Then GoTo 320
a(14) = -a(32) + a(48) + a(62): If a(14) < 0 Or a(14) > 7 Then GoTo 320
a(13) = 0.5 * s1 + a(32) - a(48) - a(62) - a(63) - a(64): If a(13) < 0 Or a(13) > 7 Then GoTo 320
a(12) = -a(32) + a(48) + a(60): If a(12) < 0 Or a(12) > 7 Then GoTo 320
a(11) = a(32) - a(48) + a(59): If a(11) < 0 Or a(11) > 7 Then GoTo 320
a(10) = -a(32) + a(48) - a(60) + a(62) + a(64): If a(10) < 0 Or a(10) > 7 Then GoTo 320
a(9) = 0.5 * s1 + a(32) - a(48) - a(59) - a(62) - a(64): If a(9) < 0 Or a(9) > 7 Then GoTo 320
' Check Row 7
For i1 = 9 To 16
b(i1 - 8) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 320
For j24 = m1 To m2 'a(24)
a(24) = j24 - 1
a(23) = 0.5 * s1 - a(24) - a(63) - a(64): If a(23) < 0 Or a(23) > 7 Then GoTo 240
a(22) = a(24) - a(62) + a(64): If a(22) < 0 Or a(22) > 7 Then GoTo 240
a(21) = -a(24) + a(62) + a(63): If a(21) < 0 Or a(21) > 7 Then GoTo 240
a(20) = a(24) - a(60) + a(64): If a(20) < 0 Or a(20) > 7 Then GoTo 240
a(19) = 0.5 * s1 - a(24) - a(59) - a(64): If a(19) < 0 Or a(19) > 7 Then GoTo 240
a(18) = a(24) + a(60) - a(62): If a(18) < 0 Or a(18) > 7 Then GoTo 240
a(17) = -a(24) + a(59) + a(62): If a(17) < 0 Or a(17) > 7 Then GoTo 240
' Check Row 7
For i1 = 17 To 24
b(i1 - 16) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 240
a(8) = 0.5 * s1 - a(24) - a(48) - a(64): If a(8) < 0 Or a(8) > 7 Then GoTo 240
a(7) = a(24) + a(48) - a(63): If a(7) < 0 Or a(7) > 7 Then GoTo 240
a(6) = 0.5 * s1 - a(24) - a(48) - a(62): If a(6) < 0 Or a(6) > 7 Then GoTo 240
a(5) = -0.5 * s1 + a(24) + a(48) + a(62) + a(63) + a(64): If a(5) < 0 Or a(5) > 7 Then GoTo 240
a(4) = 0.5 * s1 - a(24) - a(48) - a(60): If a(4) < 0 Or a(4) > 7 Then GoTo 240
a(3) = a(24) + a(48) - a(59): If a(3) < 0 Or a(3) > 7 Then GoTo 240
a(2) = 0.5 * s1 - a(24) - a(48) + a(60) - a(62) - a(64): If a(2) < 0 Or a(2) > 7 Then GoTo 240
a(1) = -0.5 * s1 + a(24) + a(48) + a(59) + a(62) + a(64): If a(1) < 0 Or a(1) > 7 Then GoTo 240
' Check Row 7
For i1 = 1 To 8
b(i1 - 0) = a(i1)
Next i1
GoSub 1800: If fl1 = 0 Then GoTo 240
'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 240
'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 240
n9 = n9 + 1
GoSub 650 'Print results (squares)
' GoSub 645 'Print results (selected numbers)
' Cells(1, 1).Value = n9
240 Next j24
320 Next j32
480 Next j48
560 Next j56
590 Next j59
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 CompLat8d")
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
