' Generates Semi-Latin Squares of order 6
' Square of the Sun
' Tested with Office 2007 under Windows 7
Sub SunLat6()
Dim a1(81), a(36), b1(81), b(81), c(36)
y = MsgBox("Locked", vbCritical, "Routine SunLat6")
End
n2 = 0: n3 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 6: s1 = 15: p6 = s1 / 3
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3: a1(5) = 4: a1(6) = 5:
Sheets("Klad1").Select
t1 = Timer
' Generate Squares
' Row 1
For j36 = m1 To m2 'a(36)
a(36) = a1(j36)
a(1) = p6 - a(36)
For j35 = m1 To m2 'a(35)
a(35) = a1(j35)
a(5) = p6 - a(35)
For j34 = m1 To m2 'a(34)
a(34) = a1(j34)
a(33) = p6 - a(34):
For j32 = m1 To m2 'a(32)
a(32) = a1(j32)
a(2) = p6 - a(32):
a(31) = s1 - a(32) - a(33) - a(34) - a(35) - a(36)
If a(31) < a1(m1) Or a(31) > a1(m2) Then GoTo 320
a(6) = p6 - a(31):
' Check Row 1
b(1) = a(31): b(2) = a(32): b(3) = a(33): b(4) = a(34): b(5) = a(35): b(6) = a(36):
GoSub 860: If fl1 = 0 Then GoTo 320
' Diagonal 1
For j29 = m1 To m2 'a(29)
a(29) = a1(j29)
a(8) = p6 - a(29):
For j22 = m1 To m2 'a(22)
a(22) = a1(j22)
a(15) = p6 - a(22):
' Check Diagonal 1
b(1) = a(1): b(2) = a(8): b(3) = a(15): b(4) = a(22): b(5) = a(29): b(6) = a(36):
GoSub 860: If fl1 = 0 Then GoTo 220
' Col 2/5
For j23 = m1 To m2 'a(23)
a(23) = a1(j23)
a(20) = p6 - a(23):
For j17 = m1 To m2 'a(17)
a(17) = a1(j17)
a(14) = p6 - a(17):
a(11) = s1 - a(5) - a(17) - a(23) - a(29) - a(35)
If a(11) < a1(m1) Or a(11) > a1(m2) Then GoTo 170
a(26) = p6 - a(11):
' Diagonal 2
For j21 = m1 To m2 'a(21)
a(21) = a1(j21)
a(16) = p6 - a(21):
' Check Diagonal 2
b(1) = a(6): b(2) = a(11): b(3) = a(16): b(4) = a(21): b(5) = a(26): b(6) = a(31):
GoSub 860: If fl1 = 0 Then GoTo 210
' Row 6
a(4) = p6 + a(21) - a(22) - a(34)
If a(4) < a1(m1) Or a(4) > a1(m2) Then GoTo 210
a(3) = p6 - a(4):
' Check Row 6
b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(4): b(5) = a(5): b(6) = a(6):
GoSub 860: If fl1 = 0 Then GoTo 210
' Col 3
For j28 = m1 To m2 'a(28)
a(28) = a1(j28)
a(10) = p6 - a(28):
' Col 4
a(27) = 10 * s1 / 6 - a(28) - a(17) - a(23) - 2 * a(29) - a(5) - a(35) - a(1) - a(36)
If a(27) < a1(m1) Or a(27) > a1(m2) Then GoTo 280
a(9) = p6 - a(27):
' Row 3/4
For j24 = m1 To m2 'a(24)
a(24) = a1(j24)
a(19) = 8 * s1 / 6 - a(24) - a(21) - a(22) - 2 * a(1) - 2 * a(36)
If a(19) < a1(m1) Or a(19) > a1(m2) Then GoTo 240
a(18) = p6 - a(24):
a(13) = p6 - a(19):
' Check Row 3
b(1) = a(19): b(2) = a(20): b(3) = a(21): b(4) = a(22): b(5) = a(23): b(6) = a(24):
GoSub 860: If fl1 = 0 Then GoTo 240
' Check Row 4
b(1) = a(13): b(2) = a(14): b(3) = a(15): b(4) = a(16): b(5) = a(17): b(6) = a(18):
GoSub 860: If fl1 = 0 Then GoTo 240
' Remainder
For j30 = m1 To m2 'a(30)
a(30) = a1(j30)
a(25) = p6 - a(30):
a(12) = p6 - a(30) - a(32) - a(35) + 2 * a(1)
If a(12) < a1(m1) Or a(12) > a1(m2) Then GoTo 300
a(7) = p6 - a(12):
' Check Row 2
b(1) = a(25): b(2) = a(26): b(3) = a(27): b(4) = a(28): b(5) = a(29): b(6) = a(30):
GoSub 860: If fl1 = 0 Then GoTo 300
' Check Row 5
b(1) = a(7): b(2) = a(8): b(3) = a(9): b(4) = a(10): b(5) = a(11): b(6) = a(12):
GoSub 860: If fl1 = 0 Then GoTo 300
n9 = n9 + 1: GoSub 2650 'Print results (squares)
' n9 = n9 + 1: GoSub 2645 'Print results (selected numbers)
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
300 Next j30
240 Next j24
280 Next j28
210 Next j21
170 Next j17
230 Next j23
220 Next j22
290 Next j29
320 Next j32
340 Next j34
350 Next j35
360 Next j36
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SunLat6")
End
' Check Latin Rows and Diagonals
860 fl1 = 1
For i1 = 1 To 6
b22 = b(i1)
For i2 = (1 + i1) To 6
If b22 = b(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 36
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 37).Value = n9
Cells(1, 38).Value = n9
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 7: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 7
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 6
For i2 = 1 To 6
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
