' Generates Semi Latin Composed Magic Squares (18 x 18)
' Self Orthogonal
' Tested with Office 365 under Windows 11
Sub CompLat18()
Dim a(324), b(18), a1(6), a2(4)
Dim b1(324), c(324), a0(18, 18)
y = MsgBox("Locked", vbCritical, "Routine CompLat18")
End
' Define Sub Ranges
n2 = 0: n9 = 0: k1 = 1: k2 = 1: s1 = 171
Sheets("Klad1").Select
m21 = 1: m22 = 4: s2 = 38
a2(1) = 1: a2(2) = 2: a2(3) = 17: a2(4) = 18:
m11 = 1: m12 = 6: s3 = 57
a1(1) = 7: a1(2) = 8: a1(3) = 9: a1(4) = 10: a1(5) = 11: a1(6) = 12:
' Define Corner Squares
i3 = 0
For i1 = 1 To 18
For i2 = 1 To 18
i3 = i3 + 1
a(i3) = Sheets("Constr18").Cells(i1 + 1, i2 + 1)
Next i2
Next i1
' Generate Squares
t1 = Timer
' Main Diagonal (Latin)
For j18 = m11 To m12
a(18) = a1(j18)
For j35 = m11 To m12 '
a(35) = a1(j35)
If a(35) = a(18) Then GoTo 350
For j52 = m11 To m12
a(52) = a1(j52)
If a(52) = a(18) Or a(52) = a(35) Then GoTo 520
For j69 = m11 To m12
a(69) = a1(j69)
If a(69) = a(18) Or a(69) = a(35) Or a(69) = a(52) Then GoTo 690
For j256 = m21 To m22
a(256) = a2(j256)
If a(256) <> a2(1) And a(256) <> a2(2) And a(256) <> a2(3) And a(256) <> a2(4) Then GoTo 2560
For j273 = m21 To m22
a(273) = a2(j273)
If a(273) <> a2(1) And a(273) <> a2(2) And a(273) <> a2(3) And a(273) <> a2(4) Then GoTo 2730
For j290 = m21 To m22
a(290) = a2(j290)
If a(290) <> a2(1) And a(290) <> a2(2) And a(290) <> a2(3) And a(290) <> a2(4) Then GoTo 2900
s10 = a(239) + a(222) + a(205) + a(188) + a(171) + a(154) + a(137) + a(120) + a(103) + a(86)
a(307) = s1 - a(290) - a(273) - a(256) - a(69) - a(52) - a(35) - a(18) - s10
If a(307) <> a2(1) And a(307) <> a2(2) And a(307) <> a2(3) And a(307) <> a2(4) Then GoTo 2900
i2 = 18: For i1 = 1 To 18: b(i1) = a(i2): i2 = i2 + 17: Next i1 'Back Check Diagonal
GoSub 1800: If fl1 = 0 Then GoTo 2900
GoSub 3000: If fl1 = 0 Then GoTo 2900 'Check Self Orthogonal
' Row 1
For j13 = m11 To m12
a(13) = a1(j13)
For j14 = m11 To m12
a(14) = a1(j14)
For j15 = m11 To m12
a(15) = a1(j15)
For j16 = m11 To m12
a(16) = a1(j16)
a(17) = s3 - a(13) - a(14) - a(15) - a(16) - a(18)
If a(17) < a1(m11) Or a(17) > a1(m12) Then GoTo 160
For i1 = 1 To 18: b(i1) = a(i1): Next i1 'Back Check Row 1
GoSub 1800: If fl1 = 0 Then GoTo 160
' Column 1
For j217 = m21 To m22
a(217) = a2(j217)
For j235 = m22 To m21 Step -1
a(235) = a2(j235)
For j253 = m22 To m21 Step -1
a(253) = a2(j253)
If a(253) = a(256) Then GoTo 2530
For j271 = m21 To m22
a(271) = a2(j271)
If a(271) = a(273) Then GoTo 2710
a(289) = s3 - a(217) - a(235) - a(253) - a(271) - a(307)
If a(289) <> a2(1) And a(289) <> a2(2) And a(289) <> a2(3) And a(289) <> a2(4) Then GoTo 2710
If a(289) = a(290) Then GoTo 2710
' Row 2
For j31 = m12 To m11 Step -1
a(31) = a1(j31)
For j32 = m12 To m11 Step -1
a(32) = a1(j32)
For j33 = m12 To m11 Step -1
a(33) = a1(j33)
a(51) = s2 - a(15) - a(33) - a(69)
If a(51) < a1(m11) Or a(51) > a1(m12) Then GoTo 330
For j34 = m12 To m11 Step -1
a(34) = a1(j34)
a(36) = s3 - a(31) - a(32) - a(33) - a(34) - a(35)
If a(36) < a1(m11) Or a(36) > a1(m12) Then GoTo 340
a(70) = s2 - a(16) - a(34) - a(52)
If a(70) < a1(m11) Or a(70) > a1(m12) Then GoTo 340
For i1 = 19 To 36: b(i1 - 18) = a(i1): Next i1 'Back Check Row 2
GoSub 1800: If fl1 = 0 Then GoTo 340
' Column 2
For j218 = m21 To m22
a(218) = a2(j218)
If a(218) = a(217) Then GoTo 2180
For j236 = m21 To m22
a(236) = a2(j236)
If a(236) = a(235) Then GoTo 2360
For j254 = m21 To m22
a(254) = a2(j254)
If a(254) = a(253) Or a(254) = a(256) Then GoTo 2540
a(255) = s2 - a(253) - a(254) - a(256)
If a(255) <> a2(1) And a(255) <> a2(2) And a(255) <> a2(3) And a(255) <> a2(4) Then GoTo 2540
If a(255) = a(253) Or a(255) = a(254) Or a(255) = a(256) Then GoTo 2540
For j272 = m21 To m22
a(272) = a2(j272)
If a(272) = a(271) Or a(272) = a(273) Then GoTo 2720
a(274) = s2 - a(271) - a(272) - a(273)
If a(274) <> a2(1) And a(274) <> a2(2) And a(274) <> a2(3) And a(274) <> a2(4) Then GoTo 2720
If a(274) = a(271) Or a(274) = a(272) Or a(274) = a(273) Then GoTo 2720
a(308) = s3 - a(218) - a(236) - a(254) - a(272) - a(290)
If a(308) <> a2(1) And a(308) <> a2(2) And a(308) <> a2(3) And a(308) <> a2(4) Then GoTo 2720
If a(308) = a(307) Then GoTo 2720
' Row 3 / 4
For j49 = m11 To m12
a(49) = a1(j49)
If a(49) = a(51) Or a(49) = a(52) Then GoTo 490
a(67) = s2 - a(13) - a(31) - a(49)
If a(67) < a1(m11) Or a(67) > a1(m12) Then GoTo 490
For j50 = m11 To m12
a(50) = a1(j50)
If a(50) = a(49) Or a(50) = a(51) Or a(50) = a(52) Then GoTo 500
a(68) = s2 - a(14) - a(32) - a(50)
If a(68) < a1(m11) Or a(68) > a1(m12) Then GoTo 500
For j53 = m11 To m12
a(53) = a1(j53)
If a(53) = a(49) Or a(53) = a(50) Or a(53) = a(51) Or a(53) = a(52) Then GoTo 530
a(71) = s2 - a(17) - a(35) - a(53)
If a(71) < a1(m11) Or a(71) > a1(m12) Then GoTo 530
a(54) = s3 - a(49) - a(50) - a(51) - a(52) - a(53)
If a(54) < a1(m11) Or a(54) > a1(m12) Then GoTo 530
For i1 = 37 To 54: b(i1 - 36) = a(i1): Next i1 'Back Check Row 3
GoSub 1800: If fl1 = 0 Then GoTo 530
a(72) = s3 - a(67) - a(68) - a(69) - a(70) - a(71)
If a(72) < a1(m11) Or a(72) > a1(m12) Then GoTo 530
For i1 = 55 To 72: b(i1 - 54) = a(i1): Next i1 'BacK Check Row 4
GoSub 1800: If fl1 = 0 Then GoTo 530
' Column 3 / 4
For j219 = m21 To m22
a(219) = a2(j219)
If a(219) = a(217) Or a(219) = a(218) Then GoTo 2190
a(220) = s2 - a(217) - a(218) - a(219)
If a(220) <> a2(1) And a(220) <> a2(2) And a(220) <> a2(3) And a(220) <> a2(4) Then GoTo 2190
For j237 = m21 To m22
a(237) = a2(j237)
If a(237) = a(235) Or a(237) = a(236) Then GoTo 2370
a(238) = s2 - a(235) - a(236) - a(237)
If a(238) <> a2(1) And a(238) <> a2(2) And a(238) <> a2(3) And a(238) <> a2(4) Then GoTo 2370
For j291 = m21 To m22
a(291) = a2(j291)
If a(291) = a(289) Or a(291) = a(290) Then GoTo 2910
a(309) = s3 - a(219) - a(237) - a(255) - a(273) - a(291)
If a(309) <> a2(1) And a(309) <> a2(2) And a(309) <> a2(3) And a(309) <> a2(4) Then GoTo 2910
If a(309) = a(307) Or a(309) = a(308) Then GoTo 2910
a(292) = s2 - a(289) - a(290) - a(291)
If a(292) <> a2(1) And a(292) <> a2(2) And a(292) <> a2(3) And a(292) <> a2(4) Then GoTo 2910
a(310) = s2 - a(307) - a(308) - a(309)
If a(310) <> a2(1) And a(310) <> a2(2) And a(310) <> a2(3) And a(310) <> a2(4) Then GoTo 2910
GoSub 3000: If fl1 = 0 Then GoTo 2910 'Check Self Orthogonal
n9 = n9 + 1: GoSub 2750: End
2910 Next j291
2370 Next j237
2190 Next j219
530 Next j53
500 Next j50
490 Next j49
2720 Next j272
2540 Next j254
2360 Next j236
2180 Next j218
340 Next j34
330 Next j33
320 Next j32
310 Next j31
2710 Next j271
2530 Next j253
2350 Next j235
2170 Next j217
160 Next j16
150 Next j15
140 Next j14
130 Next j13
2900 Next j290
2730 Next j273
2560 Next j256
690 Next j69
520 Next j52
350 Next j35
180 Next j18
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 18
For i2 = 1 To 18
i3 = i3 + 1
a0(i1, i2) = a(i3)
Next i2
Next i1
i3 = 0
For i1 = 1 To 18
For i2 = 1 To 18
i3 = i3 + 1
b1(i3) = a0(i2, i1)
Next i2
Next i1
''Return
' Determine Simple Magic Square c()
For i1 = 1 To 324
c(i1) = a(i1) + 18 * (b1(i1) - 1)
Next i1
' Check Identical Numbers
For j1 = 1 To 324
c2 = c(j1): If c2 = -18 Then GoTo 3010
For j2 = (1 + j1) To 324
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 18
a20 = b(j1): If a20 = 0 Then GoTo 1810
For j2 = (1 + j1) To 18
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 + 19: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 19
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 18
For i2 = 1 To 18
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 + 19: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 19
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 18
For i2 = 1 To 18
i3 = i3 + 1
If c(i3) <> -18 Then
Cells(k1 + i1 + 22, k2 + i2).Value = c(i3)
End If
Next i2
Next i1
Return
End Sub
