' Generates Semi Latin Composed Magic Squares (14 x 14)
' Self Orthogonal
' Tested with Office 365 under Windows 11
Sub CompLat14()
Dim a(225), b(14), a1(10), a2(4)
Dim b1(225), c(225), A0(14, 14)
y = MsgBox("Locked", vbCritical, "Routine CompLat14")
End
' Define Sub Ranges
n2 = 0: n9 = 0: k1 = 1: k2 = 1: s1 = 105
Sheets("Klad1").Select
m21 = 1: m22 = 4: s2 = 30
a2(1) = 1: a2(2) = 2: a2(3) = 13: a2(4) = 14:
m11 = 1: m12 = 6: s3 = 45
a1(1) = 5: a1(2) = 6: a1(3) = 7: a1(4) = 8: a1(5) = 9: a1(6) = 10:
' Define Corner Squares
i3 = 0
For i1 = 1 To 14
For i2 = 1 To 14
i3 = i3 + 1
a(i3) = Sheets("Input14").Cells(i1 + 1, i2 + 1)
Next i2
Next i1
' Generate Squares
t1 = Timer
' Main Diagonal (Latin)
For j14 = m11 To m12
a(14) = a1(j14)
If a(14) = a(66) Or a(14) = a(79) Then GoTo 140
For j27 = m11 To m12 '
a(27) = a1(j27)
If a(27) = a(66) Or a(27) = a(79) Then GoTo 270
If a(27) = a(14) Then GoTo 270
For j40 = m11 To m12
a(40) = a1(j40)
If a(40) = a(66) Or a(40) = a(79) Then GoTo 400
If a(40) = a(14) Or a(40) = a(27) Then GoTo 400
For j53 = m11 To m12
a(53) = a1(j53)
If a(53) = a(66) Or a(53) = a(79) Then GoTo 530
If a(53) = a(14) Or a(53) = a(27) Or a(53) = a(40) Then GoTo 530
For j144 = m21 To m22
a(144) = a2(j144)
If a(144) = a(66) Or a(144) = a(79) Then GoTo 1440
If a(144) = a(14) Or a(144) = a(27) Or a(144) = a(40) Or a(144) = a(53) Then GoTo 1440
For j157 = m21 To m22
a(157) = a2(j157)
If a(157) = a(66) Or a(157) = a(79) Then GoTo 1570
If a(157) = a(14) Or a(157) = a(27) Or a(157) = a(40) Or a(157) = a(53) Or a(157) = a(144) Then GoTo 1570
For j170 = m21 To m22
a(170) = a2(j170)
a(183) = s1 - a(170) - a(157) - a(144) - a(131) - a(118) - a(105) - a(92) - a(79) - a(66) - a(53) - a(40) - a(27) - a(14)
If a(183) <> a2(1) And a(183) <> a2(2) And a(183) <> a2(3) And a(183) <> a2(4) Then GoTo 1700
i2 = 14: For i1 = 1 To 14: b(i1) = a(i2): i2 = i2 + 13: Next i1 'Back Check Diagonal
GoSub 1800: If fl1 = 0 Then GoTo 1570
' Row 1
For j9 = m11 To m12
a(9) = a1(j9)
For j10 = m11 To m12
a(10) = a1(j10)
For j11 = m11 To m12
a(11) = a1(j11)
For j12 = m11 To m12
a(12) = a1(j12)
a(13) = s3 - a(9) - a(10) - a(11) - a(12) - a(14)
If a(13) < a1(m11) Or a(13) > a1(m12) Then GoTo 120
For i1 = 1 To 14: b(i1) = a(i1): Next i1 'Back Check Row 1
GoSub 1800: If fl1 = 0 Then GoTo 120
' Column 1
For j113 = m21 To m22
a(113) = a2(j113)
For j127 = m22 To m21 Step -1
a(127) = a2(j127)
If a(127) = a(101) Or a(127) = a(88) Then GoTo 1270 'Ensure Latin Diagonal 18 x 18
For j141 = m22 To m21 Step -1
a(141) = a2(j141)
If a(141) = a(144) Then GoTo 1410
For j155 = m21 To m22
a(155) = a2(j155)
If a(155) = a(157) Then GoTo 1550
a(169) = s3 - a(113) - a(127) - a(141) - a(155) - a(183)
If a(169) <> a2(1) And a(169) <> a2(2) And a(169) <> a2(3) And a(169) <> a2(4) Then GoTo 1550
If a(169) = a(170) Then GoTo 1550
' Row 2
For j23 = m12 To m11 Step -1
a(23) = a1(j23)
If a(23) = a(10) Then GoTo 230 'Ensure Latin Diagonal 18 x 18
For j24 = m12 To m11 Step -1
a(24) = a1(j24)
For j25 = m12 To m11 Step -1
a(25) = a1(j25)
a(39) = s2 - a(11) - a(25) - a(53)
If a(39) < a1(m11) Or a(39) > a1(m12) Then GoTo 250
For j26 = m12 To m11 Step -1
a(26) = a1(j26)
a(28) = s3 - a(23) - a(24) - a(25) - a(26) - a(27)
If a(28) < a1(m11) Or a(28) > a1(m12) Then GoTo 260
a(54) = s2 - a(12) - a(26) - a(40)
If a(54) < a1(m11) Or a(54) > a1(m12) Then GoTo 260
For i1 = 15 To 28: b(i1 - 14) = a(i1): Next i1 'Back Check Row 2
GoSub 1800: If fl1 = 0 Then GoTo 260
' Column 2
For j114 = m21 To m22
a(114) = a2(j114)
If a(114) = a(113) Then GoTo 1140
If a(114) = a(127) Or a(114) = a(101) Or a(114) = a(88) Then GoTo 1140 'Ensure Latin Diagonal 18 x 18
For j128 = m21 To m22
a(128) = a2(j128)
If a(128) = a(127) Then GoTo 1280
For j142 = m21 To m22
a(142) = a2(j142)
If a(142) = a(141) Or a(142) = a(144) Then GoTo 1420
a(143) = s2 - a(141) - a(142) - a(144)
If a(143) <> a2(1) And a(143) <> a2(2) And a(143) <> a2(3) And a(143) <> a2(4) Then GoTo 1420
If a(143) = a(141) or a(143) = a(142) or a(143) = a(144) Then GoTo 1420
For j156 = m21 To m22
a(156) = a2(j156)
If a(156) = a(155) Or a(156) = a(157) Then GoTo 1560
a(158) = s2 - a(155) - a(156) - a(157)
If a(158) <> a2(1) And a(158) <> a2(2) And a(158) <> a2(3) And a(158) <> a2(4) Then GoTo 1560
If a(158) = a(155) or a(158) = a(156) or a(158) = a(157) Then GoTo 1560
a(184) = s3 - a(114) - a(128) - a(142) - a(156) - a(170)
If a(184) <> a2(1) And a(184) <> a2(2) And a(184) <> a2(3) And a(184) <> a2(4) Then GoTo 1560
If a(184) = a(183) Then GoTo 1560
' Row 3 / 4
For j37 = m11 To m12
a(37) = a1(j37)
If a(37) = a(39) Or a(37) = a(40) Then GoTo 370
a(51) = s2 - a(9) - a(23) - a(37)
If a(51) < a1(m11) Or a(51) > a1(m12) Then GoTo 370
For j38 = m11 To m12
a(38) = a1(j38)
If a(38) = a(37) Or a(38) = a(39) Or a(38) = a(40) Then GoTo 380
a(52) = s2 - a(10) - a(24) - a(38)
If a(52) < a1(m11) Or a(52) > a1(m12) Then GoTo 380
For j41 = m11 To m12
a(41) = a1(j41)
If a(41) = a(37) Or a(41) = a(38) Or a(41) = a(39) Or a(41) = a(40) Then GoTo 410
a(55) = s2 - a(13) - a(27) - a(41)
If a(55) < a1(m11) Or a(55) > a1(m12) Then GoTo 410
a(42) = s3 - a(37) - a(38) - a(39) - a(40) - a(41)
If a(42) < a1(m11) Or a(42) > a1(m12) Then GoTo 410
For i1 = 29 To 42: b(i1 - 28) = a(i1): Next i1 'Back Check Row 3
GoSub 1800: If fl1 = 0 Then GoTo 410
a(56) = s3 - a(51) - a(52) - a(53) - a(54) - a(55)
If a(56) < a1(m11) Or a(56) > a1(m12) Then GoTo 410
For i1 = 43 To 56: b(i1 - 42) = a(i1): Next i1 'BacK Check Row 4
GoSub 1800: If fl1 = 0 Then GoTo 410
' Column 3 / 4
For j115 = m21 To m22
a(115) = a2(j115)
If a(115) = a(113) Or a(115) = a(114) Then GoTo 1150
a(116) = s2 - a(113) - a(114) - a(115)
If a(116) <> a2(1) And a(116) <> a2(2) And a(116) <> a2(3) And a(116) <> a2(4) Then GoTo 1150
For j129 = m21 To m22
a(129) = a2(j129)
If a(129) = a(127) Or a(129) = a(128) Then GoTo 1290
a(130) = s2 - a(127) - a(128) - a(129)
If a(130) <> a2(1) And a(130) <> a2(2) And a(130) <> a2(3) And a(130) <> a2(4) Then GoTo 1290
For j171 = m21 To m22
a(171) = a2(j171)
If a(171) = a(169) Or a(171) = a(170) Then GoTo 1710
a(185) = s3 - a(115) - a(129) - a(143) - a(157) - a(171)
If a(185) <> a2(1) And a(185) <> a2(2) And a(185) <> a2(3) And a(185) <> a2(4) Then GoTo 1710
If a(185) = a(183) Or a(185) = a(184) Then GoTo 1710
a(172) = s2 - a(169) - a(170) - a(171)
If a(172) <> a2(1) And a(172) <> a2(2) And a(172) <> a2(3) And a(172) <> a2(4) Then GoTo 1710
a(186) = s2 - a(183) - a(184) - a(185)
If a(186) <> a2(1) And a(186) <> a2(2) And a(186) <> a2(3) And a(186) <> a2(4) Then GoTo 1710
GoSub 3000: If fl1 = 0 Then GoTo 1710 'Check Self Orthogonal
n9 = n9 + 1: GoSub 2650: End
1710 Next j171
1290 Next j129
1150 Next j115
410 Next j41
380 Next j38
370 Next j37
1560 Next j156
1420 Next j142
1280 Next j128
1140 Next j114
260 Next j26
250 Next j25
240 Next j24
230 Next j23
1550 Next j155
1410 Next j141
1270 Next j127
1130 Next j113
120 Next j12
110 Next j11
100 Next j10
90 Next j9
1700 Next j170
1570 Next j157
1440 Next j144
530 Next j53
400 Next j40
270 Next j27
140 Next j14
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CompLat14")
End
3000 fl1 = 1: n14 = 0
' Transpose: b1() = T(a())
i3 = 0
For i1 = 1 To 14
For i2 = 1 To 14
i3 = i3 + 1
a0(i1, i2) = a(i3)
Next i2
Next i1
i3 = 0
For i1 = 1 To 14
For i2 = 1 To 14
i3 = i3 + 1
b1(i3) = a0(i2, i1)
Next i2
Next i1
' Determine Simple Magic Square c()
For i1 = 1 To 196
c(i1) = a(i1) + 14 * (b1(i1) - 1)
Next i1
' Check Identical Numbers
For j1 = 1 To 196
c2 = c(j1): If c2 = -14 Then GoTo 3010
For j2 = (1 + j1) To 196
If c2 = c(j2) Then fl1 = 0: Return
Next j2
3010 Next j1
Return
' Exclude solutions with identical numbers Latin Lines Order 14
1800 fl1 = 1
For j1 = 1 To 14
a20 = b(j1): If a20 = 0 Then GoTo 1810
For j2 = (1 + j1) To 14
If a20 = b(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 15: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 15
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 14
For i2 = 1 To 14
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Print results (squares)
2750 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 15: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 15
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 14
For i2 = 1 To 14
i3 = i3 + 1
If c(i3) <> -14 Then
Cells(k1 + i1 + 17, k2 + i2).Value = c(i3)
End If
Next i2
Next i1
Return
End Sub
