' Constructs Associated Semi-Latin Squares (7 x 7)
' Overlapping Sub Squares (4 x 4)
' Tested with Office 2007 under Windows 7
Sub SemiLat7a()
Dim a1(7), a(49), b(7)
y = MsgBox("Locked", vbCritical, "Routine SemiLat7a")
End
Sheets("Klad1").Select
n5 = 0: n9 = 0: k1 = 1: k2 = 1
t1 = Timer
' Define Natural Numbers
s1 = 21: nvar = 7: PR7 = 2 * s1 / 7
For j1 = 1 To nvar
a1(j1) = j1 - 1
Next j1
m1 = 1: m2 = nvar
' Generate Squares
a(25) = s1 / 7
For j26 = m1 To m2 'a(26)
a(26) = a1(j26)
a(24) = PR7 - a(26)
For j27 = m1 To m2 'a(27)
a(27) = a1(j27)
a(28) = 4 * s1 / 7 - a(25) - a(26) - a(27)
If a(28) < a1(m1) Or a(28) > a1(m2) Then GoTo 270
a(23) = PR7 - a(27): a(22) = PR7 - a(28)
' Check Center Line
b(1) = a(22): b(2) = a(23): b(3) = a(24): b(4) = a(25): b(5) = a(26): b(6) = a(27): b(7) = a(28):
GoSub 860: If fl1 = 0 Then GoTo 270
For j32 = m1 To m2 'a(32)
a(32) = a1(j32)
a(18) = PR7 - a(32)
For j33 = m1 To m2 'a(33)
a(33) = a1(j33)
a(17) = PR7 - a(33)
For j34 = m1 To m2 'a(34)
a(34) = a1(j34)
a(35) = 4 * s1 / 7 - a(32) - a(33) - a(34)
If a(35) < a1(m1) Or a(35) > a1(m2) Then GoTo 340
a(16) = PR7 - a(34): a(15) = PR7 - a(35)
For j39 = m1 To m2 'a(39)
a(39) = a1(j39)
a(40) = a(39) - a(34) + a(32) - a(28) + a(25)
If a(40) < a1(m1) Or a(40) > a1(m2) Then GoTo 390
a(41) = 4 * s1 / 7 - a(39) - a(33) - a(32) + a(28) - a(25)
If a(41) < a1(m1) Or a(41) > a1(m2) Then GoTo 390
a(42) = -a(39) + a(34) + a(33)
If a(42) < a1(m1) Or a(42) > a1(m2) Then GoTo 390
a(46) = 4 * s1 / 7 - a(40) - a(34) - a(28)
If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 390
a(47) = -4 * s1 / 7 - a(39) + a(35) + 2 * a(34) + 2 * a(28) + a(27)
If a(47) < a1(m1) Or a(47) > a1(m2) Then GoTo 390
a(48) = a(39) - a(35) - 2 * a(34) + a(26) + 2 * a(25)
If a(48) < a1(m1) Or a(48) > a1(m2) Then GoTo 390
a(49) = a(39) + a(32) - a(28)
If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 390
a(11) = PR7 - a(39): a(10) = PR7 - a(40): a(9) = PR7 - a(41): a(8) = PR7 - a(42)
a(4) = PR7 - a(46): a(3) = PR7 - a(47): a(2) = PR7 - a(48): a(1) = PR7 - a(49)
For j45 = m1 To m2 'a(45)
a(45) = a1(j45)
a(5) = PR7 - a(45)
For j44 = m1 To m2 'a(44)
a(44) = a1(j44)
a(43) = 3 * s1 / 7 - a(44) - a(45)
If a(43) < a1(m1) Or a(43) > a1(m2) Then GoTo 440
a(7) = PR7 - a(43): a(6) = PR7 - a(44)
For j38 = m1 To m2 'a(38)
a(38) = a1(j38)
a(31) = 3 * s1 / 7 - a(38) - a(45)
If a(31) < a1(m1) Or a(31) > a1(m2) Then GoTo 380
a(19) = PR7 - a(31): a(12) = PR7 - a(38)
For j37 = m1 To m2 'a(37)
a(37) = a1(j37)
a(36) = 3 * s1 / 7 - a(37) - a(38)
If a(36) < a1(m1) Or a(36) > a1(m2) Then GoTo 370
a(30) = 3 * s1 / 7 - a(37) - a(44)
If a(30) < a1(m1) Or a(30) > a1(m2) Then GoTo 370
a(29) = -3 * s1 / 7 + a(37) + a(38) + a(44) + a(45)
If a(29) < a1(m1) Or a(29) > a1(m2) Then GoTo 370
a(21) = PR7 - a(29): a(20) = PR7 - a(30): a(14) = PR7 - a(36): a(13) = PR7 - a(37)
' Check Latin Rows
i1 = -6
For i0 = 1 To 7
i1 = i1 + 7
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3):
b(5) = a(i1 + 4): b(6) = a(i1 + 5): b(7) = a(i1 + 6)
GoSub 860: If fl1 = 0 Then GoTo 370
Next i0
' Check Latin Diagonal
b(1) = a(1): b(2) = a(9): b(3) = a(17): b(4) = a(25): b(5) = a(33): b(6) = a(41): b(7) = a(49):
GoSub 860: If fl1 = 0 Then GoTo 370
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers)
370 Next j37
380 Next j38
440 Next j44
450 Next j45
390 Next j39
340 Next j34
330 Next j33
320 Next j32
270 Next j27
260 Next j26
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SemiLat7a")
End
' Check Latin Rows
860 fl1 = 1
For j1 = 1 To 7
b2 = b(j1)
For j2 = (1 + j1) To 7
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 49
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 50).Value = n9
Cells(1, 51).Select
Cells(1, 51).Value = n9
Return
' Print results (squares)
2650 n5 = n5 + 1
If n5 = 5 Then
n5 = 1: k1 = k1 + 8: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 8
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 7
For i2 = 1 To 7
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
