' Generates Symmetric (Semi) Latin (Diagonal) Squares of order 5
' Tested with Office 2007 under Windows 7
Sub SemiLat5a()
Dim a(25), a1(5), b(5), n52(10)
y = MsgBox("Locked", vbExclamation, "Routine SemiLat5a")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 5: s1 = 10: Pr5 = 2 * s1 / 5
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3: a1(5) = 4
Sheets("Klad1").Select
t1 = Timer
a(13) = 2
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)
For j19 = m1 To m2 'a(19)
a(19) = a1(j19)
If a(19) = a(20) 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
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
a(16) = s1 - a(17) - a(18) - a(19) - a(20)
For j15 = m1 To m2 'a(15)
a(15) = a1(j15)
For j14 = m1 To m2 'a(14)
a(14) = a1(j14)
If a(14) = a(15) Then GoTo 140
a(11) = Pr5 - a(15): a(12) = Pr5 - a(14):
b(1) = a(11): b(2) = a(12): b(3) = a(13): b(4) = a(14): b(5) = a(15):
GoSub 300: If fl1 = 0 Then GoTo 140
a(1) = Pr5 - a(25): a(2) = Pr5 - a(24): a(3) = Pr5 - a(23): a(4) = Pr5 - a(22): a(5) = Pr5 - a(21):
a(6) = Pr5 - a(20): a(7) = Pr5 - a(19): a(8) = Pr5 - a(18): a(9) = Pr5 - a(17): a(10) = Pr5 - a(16):
' Check Columns
b(1) = a(5): b(2) = a(10): b(3) = a(15): b(4) = a(20): b(5) = a(25):
GoSub 500: If fl1 = 0 Then GoTo 140
b(1) = a(4): b(2) = a(9): b(3) = a(14): b(4) = a(19): b(5) = a(24):
GoSub 500: If fl1 = 0 Then GoTo 140
b(1) = a(3): b(2) = a(8): b(3) = a(13): b(4) = a(18): b(5) = a(23):
GoSub 500: If fl1 = 0 Then GoTo 140
b(1) = a(2): b(2) = a(7): b(3) = a(12): b(4) = a(17): b(5) = a(22):
GoSub 500: If fl1 = 0 Then GoTo 140
b(1) = a(1): b(2) = a(6): b(3) = a(11): b(4) = a(16): b(5) = a(21):
GoSub 500: If fl1 = 0 Then GoTo 140
' Check Latin Diagonals (Option)
' GoSub 400: If fl1 = 0 Then GoTo 140 'Latin Main Diagonals
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)
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 SemiLat5a")
End
' Check Diagonals
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 Columns
500 fl1 = 1
' Check Magic Constant
If b(1) + b(2) + b(3) + b(4) + b(5) <> s1 Then fl1 = 0: Return
Return
' Limitation for Prime Number Magic Squares (Balanced Series)
' Count 1, 2, 3, 4, 5
Erase n52
For i1 = 1 To 5
n52(b(i1) + 1) = n52(b(i1) + 1) + 1
Next i1
' Check Valid Combinations
fl1 = 0
If n52(1) = 2 And n52(3) = 1 And n52(5) = 2 Then fl1 = 1: Return
If n52(1) = 1 And n52(2) = 1 And n52(3) = 1 And n52(4) = 1 And n52(5) = 1 Then fl1 = 1: Return
If n52(2) = 2 And n52(3) = 1 And n52(4) = 2 Then fl1 = 1: Return
If n52(1) = 1 And n52(3) = 3 And n52(5) = 1 Then fl1 = 1: Return
If n52(2) = 1 And n52(3) = 3 And n52(4) = 1 Then fl1 = 1: Return
If n52(3) = 5 Then fl1 = 1: Return
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
