' Constructs Associated Semi-Latin Squares (7 x 7)
' Diamond Inlay (4 x 4)
' Tested with Office 365 under Windows 10
Sub SemiLat7b()
Dim a(49), b(7), a1(7)
y = MsgBox("Locked", vbCritical, "Routine MgcSqr7b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 7: s1 = 21: PR7 = 2 * s1 / 7
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3: a1(5) = 4: a1(6) = 5: a1(7) = 6
' Generate Squares
Sheets("Klad1").Select
t1 = Timer
a(25) = s1 / 7:
For j28 = m1 To m2 'a(28) Diamond 4
a(28) = a1(j28)
a(22) = PR7 - a(28)
For j34 = m1 To m2 'a(34) Diamond 4
a(34) = a1(j34)
a(16) = PR7 - a(34)
For j40 = m1 To m2 'a(40) Diamond 4
a(40) = a1(j40)
a(46) = 4 * s1 / 7 - a(40) - a(34) - a(28)
If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 400
a(4) = PR7 - a(46): a(10) = PR7 - a(40)
For j20 = m1 To m2 'a(20) Diamond 4
a(20) = a1(j20)
a(26) = -a(20) + a(46) + a(40)
If a(26) < a1(m1) Or a(26) > a1(m2) Then GoTo 200
a(38) = a(20) - a(46) + a(28)
If a(38) < a1(m1) Or a(38) > a1(m2) Then GoTo 200
a(32) = 4 * s1 / 7 - a(26) - 2 * a(20) + a(46) - a(28)
If a(32) < a1(m1) Or a(32) > a1(m2) Then GoTo 200
a(12) = PR7 - a(38): a(18) = PR7 - a(32): a(24) = PR7 - a(26): a(30) = PR7 - a(20)
' Check Diamond
n7 = 2: b(1) = a(38): b(2) = a(40):
GoSub 860: If fl1 = 0 Then GoTo 200
n7 = 3: b(1) = a(30): b(2) = a(32):: b(3) = a(34):
GoSub 860: If fl1 = 0 Then GoTo 200
n7 = 5: b(1) = a(22): b(2) = a(24):: b(3) = a(25): b(4) = a(26): b(5) = a(28):
GoSub 860: If fl1 = 0 Then GoTo 200
For j27 = m1 To m2 'Hor Axes Completed
a(27) = a1(j27)
a(23) = PR7 - a(27)
' Check Hor Axes
n7 = 7: 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 j39 = m1 To m2 'Vert Axes Completed
a(39) = a1(j39)
a(11) = PR7 - a(39)
For j33 = m1 To m2
a(33) = a1(j33)
a(17) = PR7 - a(33)
For j19 = m1 To m2
a(19) = a1(j19)
a(31) = PR7 - a(19)
n7 = 5: b(1) = a(30): b(2) = a(31):: b(3) = a(32): b(4) = a(33): b(5) = a(34):
GoSub 860: If fl1 = 0 Then GoTo 190
For j49 = m1 To m2 'a(49)
a(49) = a1(j49)
a(1) = PR7 - a(49)
For j48 = m1 To m2 'a(48)
a(48) = a1(j48)
a(2) = PR7 - a(48)
For j47 = m1 To m2 'a(47)
a(47) = a1(j47)
a(3) = PR7 - a(47)
a(45) = -3 * s1 / 7 + a(47) + a(19) + a(33) + a(26) - a(20) + a(46) + a(40) - a(28)
If a(45) < a1(m1) Or a(45) > a1(m2) Then GoTo 470
a(5) = PR7 - a(45)
For j44 = m1 To m2 'a(44)
a(44) = a1(j44)
a(43) = s1 - a(44) - a(45) - a(47) - a(48) - a(49) - a(46)
If a(43) < a1(m1) Or a(43) > a1(m2) Then GoTo 440
a(7) = PR7 - a(43)
a(6) = PR7 - a(44)
' Check Rows 1 / 7
n7 = 7: b(1) = a(43): b(2) = a(44):: b(3) = a(45): b(4) = a(46): b(5) = a(47): b(6) = a(48): b(7) = a(49):
GoSub 860: If fl1 = 0 Then GoTo 440
For j42 = m1 To m2 'a(42)
a(42) = a1(j42)
a(8) = PR7 - a(42)
For j41 = m1 To m2 'a(41)
a(41) = a1(j41)
a(9) = PR7 - a(41)
a(37) = -3 * s1 / 7 + a(41) - a(44) + a(48) + a(27) + a(20) + a(34)
If a(37) < a1(m1) Or a(37) > a1(m2) Then GoTo 410
a(13) = PR7 - a(37)
a(36) = 10 * s1 / 7 - 2 * a(41) - a(42) + a(44) - a(48) - a(39) - a(27) - 2 * a(20) + a(46) - a(40) - a(34) - a(28)
If a(36) < a1(m1) Or a(36) > a1(m2) Then GoTo 410
a(14) = PR7 - a(36)
' Check Row 2 / 6
n7 = 7: b(1) = a(36): b(2) = a(37): b(3) = a(38): b(4) = a(39): b(5) = a(40): b(6) = a(41): b(7) = a(42):
GoSub 860: If fl1 = 0 Then GoTo 410
a(35) = 10 * s1 / 7 - a(41)-a(42)-a(47)-a(48)-a(49)- 0.5*a(39)-a(33)-0.5*a(27)+a(20)-a(46)-a(40)-a(34)
If a(35) < a1(m1) Or a(35) > a1(m2) Or Int(a(35)) <> a(35) Then GoTo 410
a(15) = PR7 - a(35)
a(29) = -11 * s1 / 7 + a(41)+a(42)+a(47)+a(48)+a(49)+a(19)+0.5*a(39)+0.5*a(27)+a(26)+2*a(20)+a(40)+a(28)
If a(29) < a1(m1) Or a(29) > a1(m2) Or Int(a(29)) <> a(29) Then GoTo 410
a(21) = PR7 - a(29)
' Check Row 3 / 5
n7 = 7: b(1) = a(29): b(2) = a(30): b(3) = a(31): b(4) = a(32): b(5) = a(33): b(6) = a(34): b(7) = a(35):
GoSub 860: If fl1 = 0 Then GoTo 410
' Diagonal 1
n7 = 7: 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 410
' Diagonal 2
b(1) = a(7): b(2) = a(13): b(3) = a(19): b(4) = a(25): b(5) = a(31): b(6) = a(37): b(7) = a(43):
GoSub 860: If fl1 = 0 Then GoTo 410
n9 = n9 + 1
' GoSub 2650 'Print results (squares)
GoSub 2645 'Print results (selected numbers)
410 Next j41
420 Next j42
440 Next j44
470 Next j47
480 Next j48
490 Next j49
190 Next j19
330 Next j33
390 Next j39
270 Next j27
200 Next j20
400 Next j40
340 Next j34
280 Next j28
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr7b")
End
' Check Latin Rows
860 fl1 = 1
For j1 = 1 To n7
b2 = b(j1)
For j2 = (1 + j1) To n7
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).Value = n9
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 8: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 8
End If
Cells(1, 1).Value = n9
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
