' Generates Semi Latin Composed Magic Squares (10 x 10)
' Self Orthogonal
' Tested with Office 365 under Windows 11
Sub CompLat10()
Dim a(100), b(10), a1(6), a2(4)
Dim b1(100), c(100)
y = MsgBox("Locked", vbCritical, "Routine CompLat10")
End
' Define Sub Ranges
n2 = 0: n9 = 0: k1 = 1: k2 = 1: s1 = 55
m11 = 1: m12 = 6:
a1(1) = 3: a1(2) = 4: a1(3) = 5: a1(4) = 6:: a1(5) = 7: a1(6) = 8:
m21 = 1: m22 = 4:
a2(1) = 1: a2(2) = 2: a2(3) = 9: a2(4) = 10:
' Define Corner Squares
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
a(i3) = Sheets("Input10").Cells(i1 + 1, i2 + 1)
Next i2
Next i1
' Generate Squares
Sheets("Klad1").Select
t1 = Timer
' Main Diagonal (Latin)
For j10 = m11 To m12 '
a(10) = a1(j10)
If a(10) = a(46) Or a(10) = a(55) Then GoTo 100
For j19 = m11 To m12 '
a(19) = a1(j19)
If a(19) = a(46) Or a(19) = a(55) Then GoTo 190
If a(19) = a(10) Then GoTo 190
For j28 = m11 To m12 '
a(28) = a1(j28)
If a(28) = a(46) Or a(28) = a(55) Then GoTo 280
If a(28) = a(10) Or a(28) = a(19) Then GoTo 280
For j37 = m11 To m12 '
a(37) = a1(j37)
If a(37) = a(46) Or a(37) = a(55) Then GoTo 370
If a(37) = a(10) Or a(37) = a(19) Or a(37) = a(28) Then GoTo 370
For j64 = m21 To m22
a(64) = a2(j64)
If a(64) = a(46) Or a(64) = a(55) Then GoTo 640
If a(64) = a(10) Or a(64) = a(19) Or a(64) = a(28) Or a(64) = a(37) Then GoTo 640
For j73 = m21 To m22
a(73) = a2(j73)
If a(73) = a(46) Or a(73) = a(55) Then GoTo 730
If a(73) = a(10) Or a(73) = a(19) Or a(73) = a(28) Or a(73) = a(37) Or a(73) = a(64) Then GoTo 730
For j82 = m21 To m22
a(82) = a2(j82)
a(91) = s1 - a(82) - a(73) - a(64) - a(55) - a(46) - a(37) - a(28) - a(19) - a(10)
If a(91) < a2(m21) Or a(91) > a2(m22) Then GoTo 820
i2 = 10: For i1 = 1 To 10: b(i1) = a(i2): i2 = i2 + 9: Next i1 'Back Check Diagonal
GoSub 1800: If fl1 = 0 Then GoTo 820
' Row 1
For j5 = m11 To m12
a(5) = a1(j5)
For j6 = m11 To m12
a(6) = a1(j6)
For j7 = m11 To m12
a(7) = a1(j7)
For j8 = m11 To m12
a(8) = a1(j8)
a(9) = s1 - a(1) - a(2) - a(3) - a(4) - a(5) - a(6) - a(7) - a(8) - a(10)
If a(9) < a1(m11) Or a(9) > a1(m12) Then GoTo 80
For i1 = 1 To 10: b(i1) = a(i1): Next i1 'Back Check Row 1
GoSub 1800: If fl1 = 0 Then GoTo 80
' Column 1
For j41 = m21 To m22
a(41) = a2(j41)
For j51 = m22 To m21 Step -1
a(51) = a2(j51)
For j61 = m22 To m21 Step -1
a(61) = a2(j61)
If a(61) = a(64) Then GoTo 610
For j71 = m21 To m22
a(71) = a2(j71)
If a(71) = a(73) Then GoTo 710
a(81) = s1 - a(1) - a(11) - a(21) - a(31) - a(41) - a(51) - a(61) - a(71) - a(91)
If a(81) < a2(m21) Or a(81) > a2(m22) Then GoTo 710
If a(81) = a(82) Then GoTo 710
' Row 2
For j15 = m12 To m11 Step -1
a(15) = a1(j15)
For j16 = m12 To m11 Step -1
a(16) = a1(j16)
For j17 = m12 To m11 Step -1
a(17) = a1(j17)
a(27) = s1 - a(7) - a(17) - a(37) - a(47) - a(57) - a(67) - a(77) - a(87) - a(97)
If a(27) < a1(m11) Or a(27) > a1(m12) Then GoTo 170
For j18 = m12 To m11 Step -1
a(18) = a1(j18)
a(20) = s1 - a(11) - a(12) - a(13) - a(14) - a(15) - a(16) - a(17) - a(18) - a(19)
If a(20) < a1(m11) Or a(20) > a1(m12) Then GoTo 180
a(38) = s1 - a(8) - a(18) - a(28) - a(48) - a(58) - a(68) - a(78) - a(88) - a(98)
If a(38) < a1(m11) Or a(38) > a1(m12) Then GoTo 180
For i1 = 11 To 20: b(i1 - 10) = a(i1): Next i1 'Back Check Row 2
GoSub 1800: If fl1 = 0 Then GoTo 180
' Column 2
For j42 = m21 To m22
a(42) = a2(j42)
If a(42) = a(41) Then GoTo 420
For j52 = m21 To m22
a(52) = a2(j52)
If a(52) = a(51) Then GoTo 520
For j62 = m21 To m22
a(62) = a2(j62)
If a(62) = a(64) Or a(62) = a(61) Then GoTo 620
a(63) = s1 - a(61) - a(62) - a(64) - a(65) - a(66) - a(67) - a(68) - a(69) - a(70)
If a(63) < a2(m21) Or a(63) > a2(m22) Then GoTo 620
For j72 = m21 To m22
a(72) = a2(j72)
If a(72) = a(73) Or a(72) = a(71) Then GoTo 720
a(74) = s1 - a(71) - a(72) - a(73) - a(75) - a(76) - a(77) - a(78) - a(79) - a(80)
If a(74) < a2(m21) Or a(74) > a2(m22) Then GoTo 720
a(92) = s1 - a(2) - a(12) - a(22) - a(32) - a(42) - a(52) - a(62) - a(72) - a(82)
If a(92) < a2(m21) Or a(92) > a2(m22) Then GoTo 720
If a(92) = a(91) Then GoTo 720
' Row 3 / 4
For j25 = m11 To m12
a(25) = a1(j25)
If a(25) = a(27) Or a(25) = a(28) Then GoTo 250
a(35) = s1 - a(5) - a(15) - a(25) - a(45) - a(55) - a(65) - a(75) - a(85) - a(95)
If a(35) < a1(m11) Or a(35) > a1(m12) Then GoTo 250
For j26 = m11 To m12
a(26) = a1(j26)
If a(26) = a(25) Or a(26) = a(27) Or a(26) = a(28) Then GoTo 260
a(36) = s1 - a(6) - a(16) - a(26) - a(46) - a(56) - a(66) - a(76) - a(86) - a(96)
If a(36) < a1(m11) Or a(36) > a1(m12) Then GoTo 260
For j29 = m11 To m12
a(29) = a1(j29)
If a(29) = a(25) Or a(29) = a(26) Or a(29) = a(27) Or a(29) = a(28) Then GoTo 290
a(39) = s1 - a(9) - a(19) - a(29) - a(49) - a(59) - a(69) - a(79) - a(89) - a(99)
If a(39) < a1(m11) Or a(39) > a1(m12) Then GoTo 290
a(30) = s1 - a(21) - a(22) - a(23) - a(24) - a(25) - a(26) - a(27) - a(28) - a(29)
If a(30) < a1(m11) Or a(30) > a1(m12) Then GoTo 290
For i1 = 21 To 30: b(i1 - 20) = a(i1): Next i1 'Back Check Row 3
GoSub 1800: If fl1 = 0 Then GoTo 290
a(40) = s1 - a(31) - a(32) - a(33) - a(34) - a(35) - a(36) - a(37) - a(38) - a(39)
If a(40) < a1(m11) Or a(40) > a1(m12) Then GoTo 290
For i1 = 31 To 40: b(i1 - 30) = a(i1): Next i1 'BacK Check Row 4
GoSub 1800: If fl1 = 0 Then GoTo 290
' Column 3 / 4
For j43 = m21 To m22
a(43) = a2(j43)
If a(43) = a(41) Or a(43) = a(42) Then GoTo 430
a(44) = s1 - a(41) - a(42) - a(43) - a(45) - a(46) - a(47) - a(48) - a(49) - a(50)
If a(44) < a2(m21) Or a(44) > a2(m22) Then GoTo 430
For j53 = m21 To m22
a(53) = a2(j53)
If a(53) = a(51) Or a(53) = a(52) Then GoTo 530
a(54) = s1 - a(51) - a(52) - a(53) - a(55) - a(56) - a(57) - a(58) - a(59) - a(60)
If a(54) < a2(m21) Or a(54) > a2(m22) Then GoTo 530
For j83 = m21 To m22
a(83) = a2(j83)
If a(83) = a(81) Or a(83) = a(82) Then GoTo 830
a(93) = s1 - a(3) - a(13) - a(23) - a(33) - a(43) - a(53) - a(63) - a(73) - a(83)
If a(93) < a2(m21) Or a(93) > a2(m22) Then GoTo 830
If a(93) = a(92) Or a(93) = a(91) Then GoTo 830
a(84) = s1 - a(81) - a(82) - a(83) - a(85) - a(86) - a(87) - a(88) - a(89) - a(90)
If a(84) < a2(m21) Or a(84) > a2(m22) Then GoTo 830
a(94) = s1 - a(91) - a(92) - a(93) - a(95) - a(96) - a(97) - a(98) - a(99) - a(100)
If a(94) < a2(m21) Or a(94) > a2(m22) Then GoTo 830
GoSub 3000: If fl1 = 0 Then GoTo 830 'Check Self Orthogonal
n9 = n9 + 1: GoSub 2750: 'Print Magic Squares
''n9 = n9 + 1: Cells(1, 1).Value = n9
830 Next j83
530 Next j53
430 Next j43
290 Next j29
260 Next j26
250 Next j25
720 Next j72
620 Next j62
520 Next j52
420 Next j42
180 Next j18
170 Next j17
160 Next j16
150 Next j15
710 Next j71
610 Next j61
510 Next j51
410 Next j41
80 Next j8
70 Next j7
60 Next j6
50 Next j5
820 Next j82
730 Next j73
640 Next j64
370 Next j37
280 Next j28
190 Next j19
100 Next j10
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CompLat10")
End
3000 fl1 = 1
' Transpose a()
b1(1) = a(1): b1(2) = a(11): b1(3) = a(21): b1(4) = a(31): b1(5) = a(41):
b1(6) = a(51): b1(7) = a(61): b1(8) = a(71): b1(9) = a(81): b1(10) = a(91):
b1(11) = a(2): b1(12) = a(12): b1(13) = a(22): b1(14) = a(32): b1(15) = a(42):
b1(16) = a(52): b1(17) = a(62): b1(18) = a(72): b1(19) = a(82): b1(20) = a(92):
b1(21) = a(3): b1(22) = a(13): b1(23) = a(23): b1(24) = a(33): b1(25) = a(43):
b1(26) = a(53): b1(27) = a(63): b1(28) = a(73): b1(29) = a(83): b1(30) = a(93):
b1(31) = a(4): b1(32) = a(14): b1(33) = a(24): b1(34) = a(34): b1(35) = a(44):
b1(36) = a(54): b1(37) = a(64): b1(38) = a(74): b1(39) = a(84): b1(40) = a(94):
b1(41) = a(5): b1(42) = a(15): b1(43) = a(25): b1(44) = a(35): b1(45) = a(45):
b1(46) = a(55): b1(47) = a(65): b1(48) = a(75): b1(49) = a(85): b1(50) = a(95):
b1(51) = a(6): b1(52) = a(16): b1(53) = a(26): b1(54) = a(36): b1(55) = a(46):
b1(56) = a(56): b1(57) = a(66): b1(58) = a(76): b1(59) = a(86): b1(60) = a(96):
b1(61) = a(7): b1(62) = a(17): b1(63) = a(27): b1(64) = a(37): b1(65) = a(47):
b1(66) = a(57): b1(67) = a(67): b1(68) = a(77): b1(69) = a(87): b1(70) = a(97):
b1(71) = a(8): b1(72) = a(18): b1(73) = a(28): b1(74) = a(38): b1(75) = a(48):
b1(76) = a(58): b1(77) = a(68): b1(78) = a(78): b1(79) = a(88): b1(80) = a(98):
b1(81) = a(9): b1(82) = a(19): b1(83) = a(29): b1(84) = a(39): b1(85) = a(49):
b1(86) = a(59): b1(87) = a(69): b1(88) = a(79): b1(89) = a(89): b1(90) = a(99):
b1(91) = a(10): b1(92) = a(20): b1(93) = a(30): b1(94) = a(40): b1(95) = a(50):
b1(96) = a(60): b1(97) = a(70): b1(98) = a(80): b1(99) = a(90): b1(100) = a(100):
' Determine Simple Magic Square c()
For i1 = 1 To 100
c(i1) = a(i1) + 10 * (b1(i1) - 1)
Next i1
' Check Identical Numbers
For j1 = 1 To 100
c2 = c(j1): If c2 = -10 Then GoTo 3010
For j2 = (1 + j1) To 100
If c2 = c(j2) Then fl1 = 0: Return
Next j2
3010 Next j1
Return
' Exclude solutions with identical numbers Latin Lines Order 10
1800 fl1 = 1
For j1 = 1 To 10
a20 = b(j1): If a20 = 0 Then GoTo 1810
For j2 = (1 + j1) To 10
If a20 = b(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
' Print results (semi-latin squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Print results (magic squares)
2750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
If c(i3) <> -10 Then
Cells(k1 + i1 + 15, k2 + i2).Value = c(i3)
End If
Next i2
Next i1
Return
End Sub
