' Generates Latin (Diagonal) Squares of order 5
' Tested with Office 2007 under Windows 7
Sub LatSqr5()
Dim a(25), a1(5), b(5), s10(12)
y = MsgBox("Locked", vbExclamation, "Routine LatSqr5")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 5: s1 = 10
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3: a1(5) = 4
Sheets("Klad1").Select
t1 = Timer
For j25 = m1 To m2 'a(25)
a(25) = a1(j25)
For j24 = m1 To m2 'a(24)
a(24) = a1(j24)
If a(24) = a(25) Then GoTo 240
For j23 = m1 To m2 'a(23)
a(23) = a1(j23)
If a(23) = a(24) Or a(23) = a(25) Then GoTo 230
For j22 = m1 To m2 'a(22)
a(22) = a1(j22)
If a(22) = a(23) Or a(22) = a(24) Or a(22) = a(25) Then GoTo 220
a(21) = s1 - a(22) - a(23) - a(24) - a(25)
For j20 = m1 To m2 'a(20)
a(20) = a1(j20)
If a(20) = a(25) Then GoTo 200
For j19 = m1 To m2 'a(19)
a(19) = a1(j19)
If a(19) = a(20) Then GoTo 190
If a(19) = a(24) Then GoTo 190
For j18 = m1 To m2 'a(18)
a(18) = a1(j18)
If a(18) = a(19) Or a(18) = a(20) Then GoTo 180
If a(18) = a(23) Then GoTo 180
For j17 = m1 To m2 'a(17)
a(17) = a1(j17)
If a(17) = a(18) Or a(17) = a(19) Or a(17) = a(20) Then GoTo 170
If a(17) = a(22) Then GoTo 170
a(16) = s1 - a(17) - a(18) - a(19) - a(20)
If a(16) = a(21) Then GoTo 170
For j15 = m1 To m2 'a(15)
a(15) = a1(j15)
If a(15) = a(20) Or a(15) = a(25) Then GoTo 150
For j14 = m1 To m2 'a(14)
a(14) = a1(j14)
If a(14) = a(15) Then GoTo 140
If a(14) = a(19) Or a(14) = a(24) Then GoTo 140
For j13 = m1 To m2 'a(13)
a(13) = a1(j13)
If a(13) = a(14) Or a(13) = a(15) Then GoTo 130
If a(13) = a(18) Or a(13) = a(23) Then GoTo 130
For j12 = m1 To m2 'a(12)
a(12) = a1(j12)
If a(12) = a(13) Or a(12) = a(14) Or a(12) = a(15) Then GoTo 120
If a(12) = a(17) Or a(12) = a(22) Then GoTo 120
a(11) = s1 - a(12) - a(13) - a(14) - a(15)
If a(11) = a(16) Or a(11) = a(21) Then GoTo 120
For j10 = m1 To m2 'a(10)
a(10) = a1(j10)
If a(10) = a(15) Or a(10) = a(20) Or a(10) = a(25) Then GoTo 100
For j9 = m1 To m2 'a(9)
a(9) = a1(j9)
If a(9) = a(10) Then GoTo 90
If a(9) = a(14) Or a(9) = a(19) Or a(9) = a(24) Then GoTo 90
For j8 = m1 To m2 'a(8)
a(8) = a1(j8)
If a(8) = a(9) Or a(8) = a(10) Then GoTo 80
If a(8) = a(13) Or a(8) = a(18) Or a(8) = a(23) Then GoTo 80
For j7 = m1 To m2 'a(7)
a(7) = a1(j7)
If a(7) = a(8) Or a(7) = a(9) Or a(7) = a(10) Then GoTo 70
If a(7) = a(12) Or a(7) = a(17) Or a(7) = a(22) Then GoTo 70
a(6) = s1 - a(7) - a(8) - a(9) - a(10)
If a(6) = a(11) Or a(6) = a(16) Or a(6) = a(21) Then GoTo 70
a(5) = s1 - a(10) - a(15) - a(20) - a(25)
a(4) = s1 - a(9) - a(14) - a(19) - a(24)
a(3) = s1 - a(8) - a(13) - a(18) - a(23)
a(2) = s1 - a(7) - a(12) - a(17) - a(22)
a(1) = s1 - a(6) - a(11) - a(16) - a(21)
' Check Latin Diagonals (Option)
' GoSub 400: If fl1 = 0 Then GoTo 70 'Latin Main Diagonals
' GoSub 500: If fl1 = 0 Then GoTo 70 'Main Diagonals Sum to 10
GoSub 600: If fl1 = 0 Then GoTo 70 'Associated
n9 = n9 + 1: Cells(1, 27) = n9 'Counting
' n9 = n9 + 1: GoSub 640 'Print results (selected numbers)
' n9 = n9 + 1: GoSub 650 'Print results (squares)
70 Next j7
80 Next j8
90 Next j9
100 Next j10
120 Next j12
130 Next j13
140 Next j14
150 Next j15
170 Next j17
180 Next j18
190 Next j19
200 Next j20
220 Next j22
230 Next j23
240 Next j24
250 Next j25
t2 = Timer
t10 = Str(t2 - t1) + " sec, " + Str(n9) + " Solutions"
y = MsgBox(t10, vbInformation, "Routine LatSqr5")
End
' Check Diagonals (Option 1)
400 fl1 = 1
b(1) = a(1): b(2) = a(7): b(3) = a(13): b(4) = a(19): b(5) = a(25):
GoSub 300: If fl1 = 0 Then Return
b(1) = a(5): b(2) = a(9): b(3) = a(13): b(4) = a(17): b(5) = a(21):
GoSub 300: If fl1 = 0 Then Return
Return
300 fl1 = 1
For i1 = 1 To 5
b2 = b(i1)
For i2 = (1 + i1) To 5
If b2 = b(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Check Diagonals (Option 2)
500 fl1 = 1
b(1) = a(1) + a(7) + a(13) + a(19) + a(25):
b(2) = a(5) + a(9) + a(13) + a(17) + a(21):
If b(1) <> s1 Or b(2) <> s1 Then fl1 = 0
Return
' Check Associated (Option 3)
600 fl1 = 1
s10(1) = a(1) + a(25): s10(2) = a(2) + a(24): s10(3) = a(3) + a(23): s10(4) = a(4) + a(22): s10(5) = a(5) + a(21):
s10(6) = a(6) + a(20): s10(7) = a(7) + a(19): s10(8) = a(8) + a(18): s10(9) = a(9) + a(17): s10(10) = a(10) + a(16):
s10(11) = a(11) + a(15): s10(12) = a(12) + a(14):
For i1 = 1 To 12
If s10(i1) <> 4 Then fl1 = 0: Return
Next i1
Return
' Print results (selected numbers)
640 ''Cells(n9, 26).Select
For i1 = 1 To 25
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 26).Value = n9
Cells(1, 27).Value = n9
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 6: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 6
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 5
For i2 = 1 To 5
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
