' Constructs Associated Semi-Latin Squares (13 x 13)
' Diamond Inlays Order 6 and 7 (Part 1)
' Tested with Office 365 under Windows 11
Sub SemiLat13a2()
Dim a(169), a1(13), b(13)
Dim a2(169), b2(169), c(169)
Dim a0(13, 13)
y = MsgBox("Locked", vbCritical, "Routine SemiLat13a2")
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
Sheets("Klad1").Select
t1 = Timer
a(85) = 6
' Start Conditions
m74 = 1: m124 = 1: m138 = 1: m101 = 1: m75 = 1: m107 = 1: m113 = 1
m62 = 1: m112 = 1: m126 = 1: m77 = 1: m127 = 1: m31 = 1: m89 = 6 'Second Batch
m100 = 1: m114 = 1: m103 = 1: m55 = 1
m88 = 1: m102 = 1: m79 = 1
m76 = 1: m90 = 1
' 7 x 7 Diamond Inlay
' 3 x 3 Associated Square
For j89 = m89 To m2 'a(89)
a(89) = a1(j89)
a(81) = p13 - a(89):
For j113 = m113 To m2 'a(113)
a(113) = a1(j113)
a(137) = 3 * s1 / 13 - a(113) - a(89)
If a(137) < a1(m1) Or a(137) > a1(m2) Then GoTo 1130
a(61) = 4 * s1 / 13 - a(113) - 2 * a(89)
If a(61) < a1(m1) Or a(61) > a1(m2) Then GoTo 1130
a(109) = p13 - a(61): a(33) = p13 - a(137): a(57) = p13 - a(113):
' 4 x 4 Associated Square
For j79 = m79 To m2 'a(79)
a(79) = a1(j79)
a(91) = p13 - a(79):
For j55 = m55 To m2 'a(55)
a(55) = a1(j55)
a(115) = p13 - a(55):
For j31 = m31 To m2 'a(31)
a(31) = a1(j31)
a(7) = 4 * s1 / 13 - a(31) - a(55) - a(79)
If a(7) < a1(m1) Or a(7) > a1(m2) Then GoTo 310
a(163) = p13 - a(7): a(139) = p13 - a(31):
For j107 = m107 To m2 'a(107)
a(107) = a1(j107)
a(83) = 4 * s1 / 13 - a(107) - a(55) - a(79)
If a(83) < a1(m1) Or a(83) > a1(m2) Then GoTo 1070
a(59) = 4 * s1 / 13 - a(107) - a(31) - a(79)
If a(59) < a1(m1) Or a(59) > a1(m2) Then GoTo 1070
a(35) = 4 * s1 / 13 - a(59) - a(83) - a(107)
If a(35) < a1(m1) Or a(35) > a1(m2) Then GoTo 1070
a(135) = p13 - a(35): a(111) = p13 - a(59): a(87) = p13 - a(83): a(63) = p13 - a(107):
n10 = 7: b(1) = a(79): b(2) = a(81): b(3) = a(83): b(4) = a(85): b(5) = a(87): b(6) = a(89): b(7) = a(91)
GoSub 1800: If fl1 = 0 Then GoTo 1070
n10 = 5: b(1) = a(107): b(2) = a(109): b(3) = a(111): b(4) = a(113): b(5) = a(115)
GoSub 1800: If fl1 = 0 Then GoTo 1070
n10 = 3: b(1) = a(135): b(2) = a(137): b(3) = a(139)
GoSub 1800: If fl1 = 0 Then GoTo 1070
' Rectangle 3 x 4
For j103 = m103 To m2 'a(103)
a(103) = a1(j103)
a(67) = p13 - a(103):
For j127 = m127 To m2 'a(127)
a(127) = a1(j127)
a(151) = 3 * s1 / 13 - a(127) - a(103)
If a(151) < a1(m1) Or a(151) > a1(m2) Then GoTo 1270
a(19) = p13 - a(151): a(43) = p13 - a(127):
For j75 = m75 To m2 'a(75)
a(75) = a1(j75)
a(99) = 6 * s1 / 13 - 2 * a(75) - a(127) - 2 * a(103)
If a(99) < a1(m1) Or a(99) > a1(m2) Then GoTo 750
a(123) = -3 * s1 / 13 + a(75) + a(127) + 2 * a(103)
If a(123) < a1(m1) Or a(123) > a1(m2) Then GoTo 750
a(47) = p13 - a(123): a(71) = p13 - a(99): a(95) = p13 - a(75):
' Rectangle 4 x 3
For j77 = m77 To m2 'a(77)
a(77) = a1(j77)
a(125) = (-6 * s1 / 13 - a(77) + 3 * a(75) + 3 * a(127) + 5 * a(103) - a(79)) / 3
If a(125) < a1(m1) Or a(125) > a1(m2) Or CInt(a(125)) <> a(125) Then GoTo 770
a(45) = p13 - a(125): a(93) = p13 - a(77):
For j101 = m101 To m2 'a(101)
a(101) = a1(j101)
a(149) = 4 * s1 / 13 - a(125) - a(101) - a(77)
If a(149) < a1(m1) Or a(149) > a1(m2) Then GoTo 1010
a(49) = s1 / 13 + a(149) - a(77)
If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 1010
a(73) = 6 * s1 / 13 - a(49) - 2 * a(101) - 2 * a(77)
If a(73) < a1(m1) Or a(73) > a1(m2) Then GoTo 1010
a(97) = p13 - a(73): a(121) = p13 - a(49): a(21) = p13 - a(149): a(69) = p13 - a(101):
' Check Diamond 7 x 7
n10 = 2: b(1) = a(149): b(2) = a(151)
GoSub 1800: If fl1 = 0 Then GoTo 1010
n10 = 3: b(1) = a(135): b(2) = a(137): b(3) = a(139)
GoSub 1800: If fl1 = 0 Then GoTo 1010
n10 = 4: b(1) = a(121): b(2) = a(123): b(3) = a(125): b(4) = a(127)
GoSub 1800: If fl1 = 0 Then GoTo 1010
n10 = 5: b(1) = a(107): b(2) = a(109): b(3) = a(111): b(4) = a(113): b(5) = a(115)
GoSub 1800: If fl1 = 0 Then GoTo 1010
n10 = 6: b(1) = a(93): b(2) = a(95): b(3) = a(97): b(4) = a(99): b(5) = a(101): b(6) = a(103)
GoSub 1800: If fl1 = 0 Then GoTo 1010
n10 = 7: b(1) = a(79): b(2) = a(81): b(3) = a(83): b(4) = a(85): b(5) = a(87): b(6) = a(89): b(7) = a(91)
GoSub 1800: If fl1 = 0 Then GoTo 1010
' Check Diagonals
n10 = 7: 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)
GoSub 1800: If fl1 = 0 Then GoTo 1010
n10 = 7: 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)
GoSub 1800: If fl1 = 0 Then GoTo 1010
' Intermediate Check Self Orthogonal (1)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
GoSub 1500: If fl1 = 0 Then GoTo 1010
' Diamond 6 x 6
For j90 = m90 To m2 'a(90) Diamond 6 x 6
a(90) = a1(j90)
a(80) = p13 - a(90)
n10 = 9: b(1) = a(79): b(2) = a(81): b(3) = a(83): b(4) = a(85): b(5) = a(87): b(6) = a(89): b(7) = a(91):
b(8) = a(90): b(9) = a(80)
GoSub 1800: If fl1 = 0 Then GoTo 900
For j102 = m102 To m2 'a(102)
a(102) = a1(j102)
a(68) = p13 - a(102)
n10 = 7: b(1) = a(93): b(2) = a(95): b(3) = a(97): b(4) = a(99): b(5) = a(101): b(6) = a(102): b(7) = a(103)
GoSub 1800: If fl1 = 0 Then GoTo 1020
For j114 = m114 To m2 'a(114)
a(114) = a1(j114)
a(56) = p13 - a(114)
n10 = 6: b(1) = a(107): b(2) = a(109): b(3) = a(111): b(4) = a(113): b(5) = a(115): b(6) = a(114)
GoSub 1800: If fl1 = 0 Then GoTo 1140
For j126 = m126 To m2 'a(126)
a(126) = a1(j126)
a(44) = p13 - a(126)
n10 = 5: b(1) = a(121): b(2) = a(123): b(3) = a(125): b(4) = a(127): b(5) = a(126)
GoSub 1800: If fl1 = 0 Then GoTo 1260
For j138 = m138 To m2 'a(138)
a(138) = a1(j138)
a(32) = p13 - a(138)
n10 = 4: b(1) = a(135): b(2) = a(137): b(3) = a(139): b(4) = a(138)
GoSub 1800: If fl1 = 0 Then GoTo 1380
a(150) = 6 * s1 / 13 - a(138) - a(126) - a(114) - a(102) - a(90)
If a(150) < a1(m1) Or a(150) > a1(m2) Then GoTo 1380
a(20) = p13 - a(150)
n10 = 3: b(1) = a(149): b(2) = a(151): b(3) = a(150)
GoSub 1800: If fl1 = 0 Then GoTo 1380
For j76 = m76 To m2 'a(76)
a(76) = a1(j76)
a(94) = p13 - a(76)
n10 = 8: b(1) = a(93): b(2) = a(95): b(3) = a(97): b(4) = a(99): b(5) = a(101): b(6) = a(102):
b(7) = a(103): b(8) = a(94)
GoSub 1800: If fl1 = 0 Then GoTo 760
For j88 = m88 To m2 'a(88)
a(88) = a1(j88)
a(82) = p13 - a(88)
n10 = 11: b(1) = a(79): b(2) = a(81): b(3) = a(83): b(4) = a(85): b(5) = a(87): b(6) = a(89): b(7) = a(91):
b(8) = a(90): b(9) = a(80): b(10) = a(82): b(11) = a(88)
GoSub 1800: If fl1 = 0 Then GoTo 880
For j100 = m100 To m2 'a(100)
a(100) = a1(j100)
a(70) = p13 - a(100)
n10 = 9: b(1) = a(93): b(2) = a(95): b(3) = a(97): b(4) = a(99): b(5) = a(101): b(6) = a(102):
b(7) = a(103): b(8) = a(94): b(9) = a(90)
GoSub 1800: If fl1 = 0 Then GoTo 1000
For j112 = m112 To m2 'a(112)
a(112) = a1(j112)
a(58) = p13 - a(112)
n10 = 7: b(1) = a(107): b(2) = a(109): b(3) = a(111): b(4) = a(113): b(5) = a(115): b(6) = a(114): b(7) = a(112)
GoSub 1800: If fl1 = 0 Then GoTo 1120
For j124 = m124 To m2 'a(124)
a(124) = a1(j124)
a(46) = p13 - a(124)
n10 = 6: b(1) = a(121): b(2) = a(123): b(3) = a(125): b(4) = a(127): b(5) = a(126): b(6) = a(124)
GoSub 1800: If fl1 = 0 Then GoTo 1240
a(136) = 6 * s1 / 13 - a(124) - a(112) - a(100) - a(88) - a(76)
If a(136) < a1(m1) Or a(136) > a1(m2) Then GoTo 1240
a(34) = p13 - a(136)
n10 = 5: b(1) = a(135): b(2) = a(137): b(3) = a(139): b(4) = a(138): b(5) = a(136)
GoSub 1800: If fl1 = 0 Then GoTo 1240
For j62 = m62 To m2 'a(62)
a(62) = a1(j62)
a(108) = p13 - a(62)
n10 = 8: b(1) = a(107): b(2) = a(109): b(3) = a(111): b(4) = a(113): b(5) = a(115): b(6) = a(114):
b(7) = a(112): b(8) = a(108)
GoSub 1800: If fl1 = 0 Then GoTo 620
For j74 = m74 To m2 'a(74)
a(74) = a1(j74)
a(96) = p13 - a(74)
a(122) = a(62) - a(136) + a(76) - a(150) + a(90)
If a(122) < a1(m1) Or a(122) > a1(m2) Then GoTo 740
a(48) = p13 - a(122)
a(110) = a(74) - a(124) + a(88) - a(138) + a(102)
If a(110) < a1(m1) Or a(110) > a1(m2) Then GoTo 740
a(60) = p13 - a(110)
a(98) = 9 * s1 / 13 - a(74) - a(62) - a(112) - a(88) - a(76) - a(126) - a(102) - a(90)
If a(98) < a1(m1) Or a(98) > a1(m2) Then GoTo 740
a(72) = p13 - a(98)
a(86) = 9 * s1 / 13 - a(74) - a(62) - a(100) - a(88) - a(76) - a(114) - a(102) - a(90)
If a(86) < a1(m1) Or a(86) > a1(m2) Then GoTo 740
a(84) = p13 - a(86)
n10 = 13: i2 = 79: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 740
n10 = 11: i2 = 93: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 740
n10 = 9: i2 = 107: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 740
n10 = 7: i2 = 121: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 740
n10 = 5: i2 = 135: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 740
n10 = 3: i2 = 149: For i1 = 1 To n10: b(i1) = a(i2 + i1 - 1): Next i1
GoSub 1800: If fl1 = 0 Then GoTo 740
' Final Check Self Orthogonal (2)
Erase a2
For i1 = 1 To 169: a2(i1) = a(i1): Next i1
GoSub 1500: If fl1 = 0 Then GoTo 5
n9 = n9 + 1:
'' GoSub 2650 'Print results (squares)
GoSub 2645 'Print results (selected numbers
5
740 Next j74
m74 = 1
620 Next j62
m62 = 1
1240 Next j124
m124 = 1
1120 Next j112
m112 = 1
1000 Next j100
m100 = 1
880 Next j88
m88 = 1
760 Next j76
m76 = 1
1380 Next j138
m138 = 1
1260 Next j126
m126 = 1
1140 Next j114
m114 = 1
1020 Next j102
m102 = 1
900 Next j90
m90 = 1
1010 Next j101
m101 = 1
770 Next j77
m77 = 1
750 Next j75
m75 = 1
1270 Next j127
m127 = 1
1030 Next j103
m103 = 1
1070 Next j107
m107 = 1
310 Next j31
m31 = 1
550 Next j55
m55 = 1
790 Next j79
m79 = 1
1130 Next j113
m113 = 1
890 Next j89
m89 = 1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SemiLat13a2")
End
1500 fl1 = 1
' 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 = 5 Then
n2 = 1: k1 = k1 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
End If
Cells(1, 1).Value = n9
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
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
