' Constructs Associated Semi-Latin Squares (13 x 13)
' Diamond Inlays Order 6 and 7 (Part 2, Border)
' Tested with Office 365 under Windows 11
Sub SemiLat13b()
Dim a(169), a1(13), b(13)
Dim a2(169), b2(169), c(169)
Dim a0(13, 13)
y = MsgBox("Locked", vbCritical, "Routine SemiLat13b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
For i1 = 1 To 13
a1(i1) = i1 - 1
Next i1
m1 = 1: m2 = 13: s1 = 78: p13 = 2 * s1 / 13: s4 = 2 * p13
Sheets("Klad1").Select
t1 = Timer
For j150 = 5079 To 47 Step -1
Cells(1, 1).Value = j150
t11 = Timer 'Time Out
' Raed Semi Latin Diamonds
For i1 = 1 To 169
a(i1) = Sheets("SemiLat67").Cells(j150, i1).Value
Next i1
' Complete Associated Border
For j164 = m1 To m2
a(164) = a1(j164)
a(6) = p13 - a(164):
a(162) = s1 - a(6) - a(19) - a(32) - a(45) - a(58) - a(71) - a(84) - a(97) - a(110) - a(123) - a(136) - a(149)
If a(162) < a1(m1) Or a(162) > a1(m2) Then GoTo 1640:
a(8) = p13 - a(162):
n10 = 3: b(1) = a(162): b(2) = a(163): b(3) = a(164)
GoSub 1800: If fl1 = 0 Then GoTo 1640
For j165 = m1 To m2
a(165) = a1(j165)
a(5) = p13 - a(165):
a(161) = 5 * s1 / 13 - a(162) - a(163) - a(164) - a(165)
If a(161) < a1(m1) Or a(161) > a1(m2) Then GoTo 1650:
a(9) = p13 - a(161):
n10 = 5: b(1) = a(161): b(2) = a(162): b(3) = a(163): b(4) = a(164): b(5) = a(165)
GoSub 1800: If fl1 = 0 Then GoTo 1650
For j152 = m1 To m2
a(152) = a1(j152)
a(18) = p13 - a(152):
a(148) = s1 - a(5) - a(18) - a(31) - a(44) - a(57) - a(70) - a(83) - a(96) - a(109) - a(122) - a(135) - a(161)
If a(148) < a1(m1) Or a(148) > a1(m2) Then GoTo 1520:
a(22) = p13 - a(148):
n10 = 5: b(1) = a(148): b(2) = a(149): b(3) = a(150): b(4) = a(151): b(5) = a(152)
GoSub 1800: If fl1 = 0 Then GoTo 1520
For j104 = m1 To m2
a(104) = a1(j104)
a(66) = p13 - a(104):
a(78) = s1 - a(66) - a(67) - a(68) - a(69) - a(70) - a(71) - a(72) - a(73) - a(74) - a(75) - a(76) - a(77)
If a(78) < a1(m1) Or a(78) > a1(m2) Then GoTo 1040:
a(92) = p13 - a(78):
n10 = 13: i2 = 92: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 1040
For j65 = m1 To m2
a(65) = a1(j65)
a(105) = p13 - a(65):
a(117) = 5 * s1 / 13 - a(65) - a(78) - a(91) - a(104)
If a(117) < a1(m1) Or a(117) > a1(m2) Then GoTo 650:
a(53) = p13 - a(117):
For j64 = m1 To m2
a(64) = a1(j64)
a(106) = p13 - a(64):
a(116) = s1 - a(105) - a(106) - a(107) - a(108) - a(109) - a(110) - a(111) - a(112) - a(113) - a(114) - a(115) - a(117)
If a(116) < a1(m1) Or a(116) > a1(m2) Then GoTo 640:
a(54) = p13 - a(116):
n10 = 13: i2 = 105: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 640
' Intermediate Check Self Orthogonal (1)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
Stp15 = 1: GoSub 1500: If fl1 = 0 Then GoTo 640
For j169 = m2 To m1 Step -1
a(169) = a1(j169)
a(1) = p13 - a(169):
n10 = 9: b(1) = a(43): b(2) = a(57): b(3) = a(71): b(4) = a(85): b(5) = a(99): b(6) = a(113): b(7) = a(127):
b(8) = a(1): b(9) = a(169)
GoSub 1800: If fl1 = 0 Then GoTo 1690
For j168 = m2 To m1 Step -1
a(168) = a1(j168)
a(2) = p13 - a(168):
For j167 = m2 To m1 Step -1
a(167) = a1(j167)
a(3) = p13 - a(167):
a(166) = s4 - a(167) - a(168) - a(169)
If a(166) < a1(m1) Or a(166) > a1(m2) Then GoTo 1670:
a(4) = p13 - a(166):
n10 = 9: i2 = 161: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 1670
For j157 = m1 To m2
a(157) = a1(j157)
a(13) = p13 - a(157):
n10 = 9: b(1) = a(121): b(2) = a(109): b(3) = a(97): b(4) = a(85): b(5) = a(73): b(6) = a(61): b(7) = a(49):
b(8) = a(13): b(9) = a(157)
GoSub 1800: If fl1 = 0 Then GoTo 1570
For j158 = m1 To m2
a(158) = a1(j158)
a(12) = p13 - a(158):
For j159 = m1 To m2
a(159) = a1(j159)
a(11) = p13 - a(159):
a(160) = s4 - a(159) - a(158) - a(157)
If a(160) < a1(m1) Or a(160) > a1(m2) Then GoTo 1590:
a(10) = p13 - a(160):
n10 = 13: i2 = 157: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 1590
For j156 = m1 To m2
a(156) = a1(j156)
a(14) = p13 - a(156):
n10 = 6: b(1) = a(148): b(2) = a(149): b(3) = a(150): b(4) = a(151): b(5) = a(152): b(6) = a(156):
GoSub 1800: If fl1 = 0 Then GoTo 1560
For j143 = m1 To m2
a(143) = a1(j143)
a(27) = p13 - a(143):
n10 = 6: b(1) = a(135): b(2) = a(136): b(3) = a(137): b(4) = a(138): b(5) = a(139): b(6) = a(143):
GoSub 1800: If fl1 = 0 Then GoTo 1430
a(130) = s4 - a(143) - a(156) - a(169)
If a(130) < a1(m1) Or a(130) > a1(m2) Then GoTo 1430:
a(40) = p13 - a(130):
n10 = 8: b(1) = a(121): b(2) = a(122): b(3) = a(123): b(4) = a(124): b(5) = a(125): b(6) = a(126):
b(7) = a(127): b(8) = a(130):
GoSub 1800: If fl1 = 0 Then GoTo 1430
For j144 = m1 To m2
a(144) = a1(j144)
a(26) = p13 - a(144):
n10 = 7: b(1) = a(148): b(2) = a(149): b(3) = a(150): b(4) = a(151): b(5) = a(152): b(6) = a(156): b(7) = a(144):
GoSub 1800: If fl1 = 0 Then GoTo 1440
For j131 = m1 To m2
a(131) = a1(j131)
a(39) = p13 - a(131):
n10 = 7: b(1) = a(135): b(2) = a(136): b(3) = a(137): b(4) = a(138): b(5) = a(139): b(6) = a(143):: b(7) = a(131):
GoSub 1800: If fl1 = 0 Then GoTo 1310
a(118) = s1 - a(1) - a(14) - a(27) - a(40) - a(53) - a(66) - a(79) - a(92) - a(105) - a(131) - a(144) - a(157)
If a(118) < a1(m1) Or a(118) > a1(m2) Then GoTo 1310:
a(52) = p13 - a(118):
n10 = 9: b(1) = a(121): b(2) = a(122): b(3) = a(123): b(4) = a(124): b(5) = a(125): b(6) = a(126):
b(7) = a(127): b(8) = a(130):: b(9) = a(118):
GoSub 1800: If fl1 = 0 Then GoTo 1310
' Intermediate Check Self Orthogonal (2)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
Stp15 = 2: GoSub 1500: If fl1 = 0 Then GoTo 1310
For j153 = m1 To m2
a(153) = a1(j153)
a(17) = p13 - a(153):
n10 = 8: b(1) = a(148): b(2) = a(149): b(3) = a(150): b(4) = a(151): b(5) = a(152): b(6) = a(153):
b(7) = a(156): b(8) = a(144)
GoSub 1800: If fl1 = 0 Then GoTo 1530
For j140 = m1 To m2
a(140) = a1(j140)
a(30) = p13 - a(140):
n10 = 8: b(1) = a(135): b(2) = a(136): b(3) = a(137): b(4) = a(138): b(5) = a(139): b(6) = a(140):
b(7) = a(143): b(8) = a(131):
GoSub 1800: If fl1 = 0 Then GoTo 1400
For j36 = m1 To m2
a(36) = a1(j36)
a(134) = p13 - a(36):
n10 = 9: b(1) = a(30): b(2) = a(31): b(3) = a(32): b(4) = a(33): b(5) = a(34): b(6) = a(35): b(7) = a(36):
b(8) = a(27): b(9) = a(39):
GoSub 1800: If fl1 = 0 Then GoTo 360
a(23) = s1 - a(10) - a(36) - a(49) - a(62) - a(75) - a(88) - a(101) - a(114) - a(127) - a(140) - a(153) - a(166)
If a(23) < a1(m1) Or a(23) > a1(m2) Then GoTo 360:
a(147) = p13 - a(23):
n10 = 9: b(1) = a(17): b(2) = a(18): b(3) = a(19): b(4) = a(20): b(5) = a(21): b(6) = a(22): b(7) = a(23):
b(8) = a(14): b(9) = a(26):
GoSub 1800: If fl1 = 0 Then GoTo 360
For j129 = m1 To m2
a(129) = a1(j129)
a(41) = p13 - a(129):
For j128 = m1 To m2
a(128) = a1(j128)
a(42) = p13 - a(128):
For j120 = m1 To m2
a(120) = a1(j120)
a(50) = p13 - a(120):
a(119) = s1 - a(118) - a(120) - a(121) - a(122) - a(123) - a(124) - a(125) - a(126) - a(127) - a(128) - a(129) - a(130)
If a(119) < a1(m1) Or a(119) > a1(m2) Then GoTo 1200:
a(51) = p13 - a(119)
n10 = 13: i2 = 118: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 1200
' Intermediate Check Self Orthogonal (3)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
Stp15 = 3: GoSub 1500: If fl1 = 0 Then GoTo 1200
' Complete Square
For j155 = m1 To m2
a(155) = a1(j155)
a(15) = p13 - a(155):
n10 = 11: b(1) = a(43): b(2) = a(57): b(3) = a(71): b(4) = a(85): b(5) = a(99): b(6) = a(113): b(7) = a(127):
b(8) = a(1): b(9) = a(169): b(10) = a(15): b(11) = a(155)
GoSub 1800: If fl1 = 0 Then GoTo 1550
For j154 = m1 To m2
a(154) = a1(j154)
a(16) = p13 - a(154):
For j146 = m1 To m2
a(146) = a1(j146)
a(24) = p13 - a(146):
a(145) = s1 - a(146) - a(154) - a(155) - a(144) - a(147) - a(148) - a(149) - a(150) - a(151) - a(152) - a(153) - a(156)
If a(145) < a1(m1) Or a(145) > a1(m2) Then GoTo 1460:
a(25) = p13 - a(145)
n10 = 11: b(1) = a(121): b(2) = a(109): b(3) = a(97): b(4) = a(85): b(5) = a(73): b(6) = a(61): b(7) = a(49):
b(8) = a(13): b(9) = a(157): b(10) = a(25): b(11) = a(145)
GoSub 1800: If fl1 = 0 Then GoTo 1460
n10 = 13: i2 = 144: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 1460
For j142 = m1 To m2
a(142) = a1(j142)
a(28) = p13 - a(142):
a(132) = s1 - a(2) - a(15) - a(28) - a(41) - a(54) - a(67) - a(80) - a(93) - a(106) - a(119) - a(145) - a(158)
If a(132) < a1(m1) Or a(132) > a1(m2) Then GoTo 1420:
a(38) = p13 - a(132)
n10 = 11: b(1) = a(134): b(2) = a(135): b(3) = a(136): b(4) = a(137): b(5) = a(138): b(6) = a(139):: b(7) = a(140):
b(8) = a(131): b(9) = a(132): b(10) = a(142): b(11) = a(143):
GoSub 1800: If fl1 = 0 Then GoTo 1420
' Intermediate Check Self Orthogonal (4)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
Stp15 = 4: GoSub 1500: If fl1 = 0 Then GoTo 1420
' Deducted (Matrix reduction)
a(141) = (84 - a(89) + a(94) - a(102) + a(107) - a(115) + a(120) - a(128) - a(131) - a(132) - a(134) - a(135) +
- a(136) - a(137) - a(138) - a(139) - a(140) - a(142) - a(143) + a(146) - a(154) + a(159) - a(167)) / 2
If a(141) < a1(m1) Or a(141) > a1(m2) Or CInt(a(141)) <> a(141) Then GoTo 1420:
a(29) = p13 - a(141)
a(133) = s1 - a(140) - a(131) - a(132) - a(134) - a(135) - a(136) - a(137) - a(138) - a(139) - a(141) - a(142) - a(143)
If a(133) < a1(m1) Or a(133) > a1(m2) Then GoTo 1420
a(37) = p13 - a(133)
n10 = 13: i2 = 131: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 1420
' Final Check Self Orthogonal (5)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
Stp15 = 5: GoSub 1500: If fl1 = 0 Then GoTo 1420
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers
' Cells(1, 1).Value = n9 'Counting
Erase a, b: GoTo 2500 'Print only first Square
1420 Next j142
1460 Next j146
1540 Next j154
1550 Next j155
1200 Next j120
1280 Next j128
1290 Next j129
360 Next j36
1400 Next j140
1530 Next j153
1310 Next j131
1440 Next j144
1430 Next j143
1560 Next j156
1590 Next j159
1580 Next j158
1570 Next j157
1670 Next j167
1680 Next j168
1690 Next j169
640 Next j64
650 Next j65
1040 Next j104
1520 Next j152
1650 Next j165
1640 Next j164
2500 Next j150
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SemiLat13b")
End
1500 fl1 = 1
Select Case Stp15
Case 1
a2(1) = 0: a2(2) = 0: a2(3) = 0: a2(4) = 0: a2(10) = 0: a2(11) = 0: a2(12) = 0: a2(13) = 0:
a2(14) = 0: a2(15) = 0: a2(16) = 0: a2(17) = 0: a2(23) = 0: a2(24) = 0: a2(25) = 0: a2(26) = 0:
a2(27) = 0: a2(28) = 0: a2(29) = 0: a2(30) = 0: a2(36) = 0: a2(37) = 0: a2(38) = 0: a2(39) = 0:
a2(40) = 0: a2(41) = 0: a2(42) = 0: a2(50) = 0: a2(51) = 0: a2(52) = 0:
a2(118) = 0: a2(119) = 0: a2(120) = 0: a2(128) = 0: a2(129) = 0: a2(130) = 0:
a2(131) = 0: a2(132) = 0: a2(133) = 0: a2(134) = 0: a2(140) = 0: a2(141) = 0: a2(142) = 0: a2(143) = 0:
a2(144) = 0: a2(145) = 0: a2(146) = 0: a2(147) = 0: a2(153) = 0: a2(154) = 0: a2(155) = 0: a2(156) = 0:
a2(157) = 0: a2(158) = 0: a2(159) = 0: a2(160) = 0: a2(166) = 0: a2(167) = 0: a2(168) = 0: a2(169) = 0:
Case 2
a2(15) = 0: a2(16) = 0: a2(17) = 0: a2(23) = 0: a2(24) = 0: a2(25) = 0:
a2(28) = 0: a2(29) = 0: a2(30) = 0: a2(36) = 0: a2(37) = 0: a2(38) = 0:
a2(41) = 0: a2(42) = 0: a2(50) = 0: a2(51) = 0:
a2(119) = 0: a2(120) = 0: a2(128) = 0: a2(129) = 0:
a2(132) = 0: a2(133) = 0: a2(134) = 0: a2(140) = 0: a2(141) = 0: a2(142) = 0:
a2(145) = 0: a2(146) = 0: a2(147) = 0: a2(153) = 0: a2(154) = 0: a2(155) = 0:
Case 3
a2(15) = 0: a2(16) = 0: a2(24) = 0: a2(25) = 0:
a2(28) = 0: a2(29) = 0: a2(37) = 0: a2(38) = 0:
a2(132) = 0: a2(133) = 0: a2(141) = 0: a2(142) = 0:
a2(145) = 0: a2(146) = 0: a2(154) = 0: a2(155) = 0:
Case 4
a2(29) = 0: a2(37) = 0:
a2(133) = 0: a2(141) = 0:
Case 5 'Do Nothing
End Select
' Transpose a2()
i3 = 0: Erase a0
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
a0(i1, i2) = a2(i3)
Next i2
Next i1
i3 = 0:
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
b2(i3) = a0(i2, i1)
Next i2
Next i1
' Calculate c()
Erase c
For i1 = 1 To 169
c(i1) = 13 * a2(i1) + b2(i1) + 1
Next i1
fl1 = 1: n20 = 0
For j1 = 1 To 169
a20 = c(j1): If a20 = 1 Then GoTo 1510 '*** Testing Purposes ***
For j2 = (1 + j1) To 169
If a20 = c(j2) Then fl1 = 0: Return
Next j2
1510 Next j1
Return
' Exclude solutions with identical numbers Latin Lines Order 13
1800 fl1 = 1
For j1 = 1 To n10
a20 = b(j1):
For j2 = (1 + j1) To n10
If a20 = b(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 169
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 170).Value = n9
Cells(1, 171).Value = n9
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 4 Then
n2 = 1: k1 = k1 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
Cells(k1, k2 + 2).Value = CStr(j150)
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3) ''c(i3)
Next i2
Next i1
Return
End Sub
