' Generates SelfOrthogonal Latin Diagonal Squares (9 x 9)
' Compact (3 x 3), Third-rows and Third-columns Summing to s1/3
' Tested with Office 365 under Windows 11
Sub SudSqr9e()
Dim a(81), b(9)
Dim b2(81), c2(81), a0(9, 9)
y = MsgBox("Locked", vbCritical, "Routine SudSqr9e")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 8: s1 = 36
Sheets("Klad1").Select
t1 = Timer
' Row 1
For j81 = m1 To m2 'a(81)
a(81) = j81
For j80 = m1 To m2 'a(80)
a(80) = j80
If a(80) = a(81) Then GoTo 800
a(79) = s1 / 3 - a(80) - a(81)
If a(79) < m1 Or a(79) > m2 Then GoTo 800
If a(79) = a(80) Or a(79) = a(81) Then GoTo 800
For j78 = m1 To m2 'a(78)
a(78) = j78
If a(78) = a(79) Or a(78) = a(80) Or a(78) = a(81) Then GoTo 780
For j77 = m1 To m2 'a(77)
a(77) = j77
If a(77) = a(78) Or a(77) = a(79) Or a(77) = a(80) Or a(77) = a(81) Then GoTo 770
a(76) = s1 / 3 - a(77) - a(78)
If a(76) < m1 Or a(76) > m2 Then GoTo 770
If a(76) = a(77) Or a(76) = a(78) Or a(76) = a(79) Or a(76) = a(80) Or a(76) = a(81) Then GoTo 770
For j75 = m1 To m2 'a(75)
a(75) = j75
If a(75) = a(77) Or a(75) = a(78) Or a(75) = a(79) Or a(75) = a(80) Or a(75) = a(81) Then GoTo 750
If a(75) = a(76) Then GoTo 750
For j74 = m1 To m2 'a(74)
a(74) = j74
If a(74) = a(77) Or a(74) = a(78) Or a(74) = a(79) Or a(74) = a(80) Or a(74) = a(81) Then GoTo 740
If a(74) = a(75) Or a(74) = a(76) Then GoTo 740
a(73) = s1 / 3 - a(74) - a(75)
If a(73) < m1 Or a(73) > m2 Then GoTo 740
If a(73) = a(77) Or a(73) = a(78) Or a(73) = a(79) Or a(73) = a(80) Or a(73) = a(81) Then GoTo 740
If a(73) = a(74) Or a(73) = a(75) Or a(73) = a(76) Then GoTo 740
' Row 2
For j72 = m1 To m2 'a(72)
a(72) = j72
If a(72) = a(81) Then GoTo 720
If a(72) = a(80) Then GoTo 720
For j71 = m1 To m2 'a(71)
a(71) = j71
If a(71) = a(80) Then GoTo 710
If a(71) = a(72) Then GoTo 710
If a(71) = a(81) Then GoTo 710 'Diagonal
a(70) = s1 / 3 - a(71) - a(72)
If a(70) < m1 Or a(70) > m2 Then GoTo 710
If a(70) = a(71) Or a(70) = a(72) Then GoTo 710
For j69 = m1 To m2 'a(69)
a(69) = j69
If a(69) = a(78) Then GoTo 690
If a(69) = a(70) Or a(69) = a(71) Or a(69) = a(72) Then GoTo 690
For j68 = m1 To m2 'a(68)
a(68) = j68
If a(68) = a(77) Then GoTo 680
If a(68) = a(69) Or a(68) = a(70) Or a(68) = a(71) Or a(68) = a(72) Then GoTo 680
a(67) = s1 / 3 - a(68) - a(69)
If a(67) < m1 Or a(67) > m2 Then GoTo 680
If a(67) = a(68) Or a(67) = a(69) Or a(67) = a(70) Or a(67) = a(71) Or a(67) = a(72) Then GoTo 680
For j66 = m1 To m2 'a(66)
a(66) = j66
If a(66) = a(75) Then GoTo 660
If a(66) = a(68) Or a(66) = a(69) Or a(66) = a(70) Or a(66) = a(71) Or a(66) = a(72) Then GoTo 660
If a(66) = a(67) Then GoTo 660
For j65 = m1 To m2 'a(65)
a(65) = j65
If a(65) = a(74) Then GoTo 650
If a(65) = a(68) Or a(65) = a(69) Or a(65) = a(70) Or a(65) = a(71) Or a(65) = a(72) Then GoTo 650
If a(65) = a(66) Or a(65) = a(67) Then GoTo 650
If a(65) = a(73) Then GoTo 650 'Diagonal
a(64) = s1 / 3 - a(65) - a(66)
If a(64) < m1 Or a(64) > m2 Then GoTo 650
If a(64) = a(68) Or a(64) = a(69) Or a(64) = a(70) Or a(64) = a(71) Or a(64) = a(72) Then GoTo 650
If a(64) = a(65) Or a(64) = a(66) Or a(64) = a(67) Then GoTo 650
If a(64) = a(73) Then GoTo 650
' Row 3
a(63) = s1 / 3 - a(72) - a(81)
If a(63) < m1 Or a(63) > m2 Then GoTo 650
If a(63) = a(79) Then GoTo 650
a(62) = s1 / 3 - a(71) - a(80)
If a(62) < m1 Or a(62) > m2 Then GoTo 650
If a(62) = a(70) Then GoTo 650
a(61) = -s1 / 3 + a(71) + a(72) + a(80) + a(81)
If a(61) < m1 Or a(61) > m2 Then GoTo 650
If a(61) = a(71) Or a(61) = a(81) Then GoTo 650 'Diagonal
a(60) = s1 / 3 - a(69) - a(78)
If a(60) < m1 Or a(60) > m2 Then GoTo 650
a(59) = s1 / 3 - a(68) - a(77)
If a(59) < m1 Or a(59) > m2 Then GoTo 650
a(58) = -s1 / 3 + a(68) + a(69) + a(77) + a(78)
If a(59) < m1 Or a(59) > m2 Then GoTo 650
a(57) = s1 / 3 - a(66) - a(75)
If a(57) < m1 Or a(57) > m2 Then GoTo 650
a(56) = s1 / 3 - a(65) - a(74)
If a(56) < m1 Or a(56) > m2 Then GoTo 650
a(55) = -s1 / 3 + a(65) + a(66) + a(74) + a(75)
If a(55) < m1 Or a(55) > m2 Then GoTo 650
For i1 = 1 To 9 'Check Row 3
b(i1) = a(i1 + 54)
Next i1
GoSub 1860: If fl1 = 0 Then GoTo 650
For i1 = 55 To 63 'Check Columns
If a(i1) = a(i1 + 9) Then GoTo 650
If a(i1) = a(i1 + 18) Then GoTo 650
Next i1
' Row 4
For j54 = m1 To m2 'a(54)
a(54) = j54
If a(54) = a(63) Or a(54) = a(72) Or a(54) = a(81) Then GoTo 540
If a(54) = a(78) Then GoTo 540
For j53 = m1 To m2 'a(53)
a(53) = j53
If a(53) = a(54) Then GoTo 530
If a(53) = a(62) Or a(53) = a(71) Or a(53) = a(80) Then GoTo 530
If a(53) = a(69) Then GoTo 530
a(52) = s1 / 3 - a(53) - a(54)
If a(52) < m1 Or a(52) > m2 Then GoTo 530
a(51) = a(54) + a(78) - a(81)
If a(51) < m1 Or a(51) > m2 Then GoTo 530
If a(51) = a(61) Or a(51) = a(71) Or a(51) = a(81) Then GoTo 530 'Check Diagonal
a(50) = a(53) + a(77) - a(80)
If a(50) < m1 Or a(50) > m2 Then GoTo 530
a(49) = s1 / 3 - a(50) - a(51)
If a(49) < m1 Or a(49) > m2 Then GoTo 530
If a(49) = a(57) Or a(49) = a(65) Or a(49) = a(73) Then GoTo 530 'Check Diagonal
a(48) = a(54) + a(75) - a(81)
If a(48) < m1 Or a(48) > m2 Then GoTo 530
a(47) = a(53) + a(74) - a(80)
If a(47) < m1 Or a(47) > m2 Then GoTo 530
a(46) = s1 / 3 - a(47) - a(48)
If a(46) < m1 Or a(46) > m2 Then GoTo 530
For i1 = 1 To 9 'Check Row 4
b(i1) = a(i1 + 45)
Next i1
GoSub 1860: If fl1 = 0 Then GoTo 530
For i1 = 46 To 54 'Check Columns
If a(i1) = a(i1 + 9) Then GoTo 530
If a(i1) = a(i1 + 18) Then GoTo 530
If a(i1) = a(i1 + 27) Then GoTo 530
Next i1
' Row 5
For j45 = m1 To m2 'a(45)
a(45) = j45
If a(45) = a(54) Or a(45) = a(63) Or a(45) = a(72) Or a(45) = a(81) Then GoTo 450
If a(45) = a(77) Then GoTo 450
For j44 = m1 To m2 'a(44)
a(44) = j44
If a(44) = a(45) Then GoTo 440
If a(44) = a(53) Or a(44) = a(62) Or a(44) = a(71) Or a(44) = a(80) Then GoTo 440
If a(44) = a(68) Then GoTo 440
a(43) = s1 / 3 - a(44) - a(45)
If a(43) < m1 Or a(43) > m2 Then GoTo 440
a(42) = a(45) + a(69) - a(72)
If a(42) < m1 Or a(42) > m2 Then GoTo 440
a(41) = a(44) + a(68) - a(71)
If a(41) < m1 Or a(41) > m2 Then GoTo 440
If a(41) = a(51) Or a(41) = a(61) Or a(41) = a(71) Or a(41) = a(81) Then GoTo 440 'Check Diagonal
If a(41) = a(49) Or a(41) = a(57) Or a(41) = a(65) Or a(41) = a(73) Then GoTo 440 'Check Diagonal
a(40) = s1 / 3 - a(41) - a(42)
If a(40) < m1 Or a(40) > m2 Then GoTo 440
a(39) = a(45) + a(66) - a(72)
If a(39) < m1 Or a(39) > m2 Then GoTo 440
a(38) = a(44) + a(65) - a(71)
If a(38) < m1 Or a(38) > m2 Then GoTo 440
a(37) = s1 / 3 - a(38) - a(39)
If a(37) < m1 Or a(37) > m2 Then GoTo 440
For i1 = 1 To 9 'Check Row 5
b(i1) = a(i1 + 36)
Next i1
GoSub 1860: If fl1 = 0 Then GoTo 440
For i1 = 37 To 45 'Check Columns
If a(i1) = a(i1 + 9) Then GoTo 440
If a(i1) = a(i1 + 18) Then GoTo 440
If a(i1) = a(i1 + 27) Then GoTo 440
If a(i1) = a(i1 + 36) Then GoTo 440
Next i1
' Row 6
a(36) = s1 / 3 - a(45) - a(54)
If a(36) < m1 Or a(36) > m2 Then GoTo 440
a(35) = s1 / 3 - a(44) - a(53)
If a(35) < m1 Or a(35) > m2 Then GoTo 440
a(34) = s1 / 3 - a(35) - a(36)
If a(34) < m1 Or a(34) > m2 Then GoTo 440
a(33) = s1 / 3 - a(42) - a(51)
If a(33) < m1 Or a(33) > m2 Then GoTo 440
If a(33) = a(41) Or a(33) = a(49) Or a(33) = a(57) Or a(33) = a(65) Or a(33) = a(73) Then GoTo 440
a(32) = s1 / 3 - a(41) - a(50)
If a(32) < m1 Or a(32) > m2 Then GoTo 440
a(31) = s1 / 3 - a(32) - a(33)
If a(31) < m1 Or a(31) > m2 Then GoTo 440
If a(31) = a(41) Or a(31) = a(51) Or a(31) = a(61) Or a(31) = a(71) Or a(31) = a(81) Then GoTo 440
a(30) = s1 / 3 - a(39) - a(48)
If a(30) < m1 Or a(30) > m2 Then GoTo 440
a(29) = s1 / 3 - a(38) - a(47)
If a(29) < m1 Or a(29) > m2 Then GoTo 440
a(28) = s1 / 3 - a(29) - a(30)
If a(28) < m1 Or a(28) > m2 Then GoTo 440
For i1 = 1 To 9 'Check Row 6
b(i1) = a(i1 + 27)
Next i1
GoSub 1860: If fl1 = 0 Then GoTo 440
For i1 = 28 To 36 'Check Columns
If a(i1) = a(i1 + 9) Then GoTo 440
If a(i1) = a(i1 + 18) Then GoTo 440
If a(i1) = a(i1 + 27) Then GoTo 440
If a(i1) = a(i1 + 36) Then GoTo 440
If a(i1) = a(i1 + 45) Then GoTo 440
Next i1
' Row 7
For j27 = m1 To m2 'a(27)
a(27) = j27
If a(27) = a(45) Or a(27) = a(54) Or a(27) = a(63) Or a(27) = a(72) Or a(27) = a(81) Then GoTo 270
If a(27) = a(36) Then GoTo 270
If a(27) = a(75) Then GoTo 270
For j26 = m1 To m2 'a(26)
a(26) = j26
If a(26) = a(27) Then GoTo 260
If a(26) = a(44) Or a(26) = a(53) Or a(26) = a(62) Or a(26) = a(71) Or a(26) = a(80) Then GoTo 260
If a(26) = a(35) Then GoTo 260
If a(26) = a(66) Then GoTo 260
a(25) = s1 / 3 - a(26) - a(27)
If a(25) < m1 Or a(25) > m2 Then GoTo 260
If a(25) = a(41) Or a(25) = a(49) Or a(25) = a(57) Or a(25) = a(65) Or a(25) = a(73) Then GoTo 260
a(24) = a(27) + a(78) - a(81)
If a(24) < m1 Or a(24) > m2 Then GoTo 260
a(23) = a(26) + a(77) - a(80)
If a(23) < m1 Or a(23) > m2 Then GoTo 260
a(22) = s1 / 3 - a(23) - a(24)
If a(22) < m1 Or a(22) > m2 Then GoTo 260
a(21) = a(27) + a(75) - a(81)
If a(21) < m1 Or a(21) > m2 Then GoTo 260
If a(21) = a(41) Or a(21) = a(51) Or a(21) = a(61) Or a(21) = a(71) Or a(21) = a(81) Then GoTo 260
a(20) = a(26) + a(74) - a(80)
If a(20) < m1 Or a(20) > m2 Then GoTo 260
a(19) = s1 / 3 - a(20) - a(21)
If a(19) < m1 Or a(19) > m2 Then GoTo 260
For i1 = 1 To 9 'Check Row 7
b(i1) = a(i1 + 18)
Next i1
GoSub 1860: If fl1 = 0 Then GoTo 260
For i1 = 19 To 27 'Check Columns
If a(i1) = a(i1 + 9) Then GoTo 260
If a(i1) = a(i1 + 18) Then GoTo 260
If a(i1) = a(i1 + 27) Then GoTo 260
If a(i1) = a(i1 + 36) Then GoTo 260
If a(i1) = a(i1 + 45) Then GoTo 260
If a(i1) = a(i1 + 54) Then GoTo 260
Next i1
' Row 8
a(18) = s1 + a(19) - a(21) - a(45) - a(53) - 2 * a(54) - a(66) - a(69) + a(72) - a(77) - 2 * a(78)
If a(18) < m1 Or a(18) > m2 Then GoTo 260
If a(18) = a(74) Then GoTo 260
a(17) = s1 / 3 - a(44) - a(65) - a(68) + a(71)
If a(17) < m1 Or a(17) > m2 Then GoTo 260
If a(17) = a(65) Then GoTo 260
a(16) = s1 / 3 - a(17) - a(18)
If a(16) < m1 Or a(16) > m2 Then GoTo 260
a(15) = a(18) + a(69) - a(72)
If a(15) < m1 Or a(15) > m2 Then GoTo 260
a(14) = s1 / 3 - a(44) - a(65)
If a(14) < m1 Or a(14) > m2 Then GoTo 260
a(13) = s1 / 3 - a(14) - a(15)
If a(13) < m1 Or a(13) > m2 Then GoTo 260
a(12) = a(15) + a(66) - a(69)
If a(12) < m1 Or a(12) > m2 Then GoTo 260
a(11) = s1 / 3 - a(44) - a(68)
If a(11) < m1 Or a(11) > m2 Then GoTo 260
a(10) = s1 / 3 - a(11) - a(12)
If a(10) < m1 Or a(10) > m2 Then GoTo 260
' Row 9
a(9) = s1 / 3 - a(18) - a(27)
If a(9) < m1 Or a(9) > m2 Then GoTo 260
a(8) = s1 / 3 - a(17) - a(26)
If a(8) < m1 Or a(8) > m2 Then GoTo 260
a(7) = s1 / 3 - a(8) - a(9)
If a(7) < m1 Or a(7) > m2 Then GoTo 260
a(6) = s1 / 3 - a(15) - a(24)
If a(6) < m1 Or a(6) > m2 Then GoTo 260
a(5) = s1 / 3 - a(14) - a(23)
If a(5) < m1 Or a(5) > m2 Then GoTo 260
a(4) = s1 / 3 - a(5) - a(6)
If a(4) < m1 Or a(4) > m2 Then GoTo 260
a(3) = s1 / 3 - a(12) - a(21)
If a(3) < m1 Or a(3) > m2 Then GoTo 260
a(2) = s1 / 3 - a(11) - a(20)
If a(2) < m1 Or a(2) > m2 Then GoTo 260
a(1) = s1 / 3 - a(2) - a(3)
If a(1) < m1 Or a(1) > m2 Then GoTo 260
' Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)
GoSub 1800: If fl1 = 0 Then GoTo 5
GoSub 1500: If fl1 = 0 Then GoTo 5 'Check Self Orthogonal
n9 = n9 + 1
' Cells(3, 1).Value = n9 'Counting
' GoSub 2650 'Print results (squares)
GoSub 2645 'Print results (selected numbers)
''End
5
260 Next j26
270 Next j27
440 Next j44
450 Next j45
530 Next j53
540 Next j54
650 Next j65
660 Next j66
680 Next j68
690 Next j69
710 Next j71
720 Next j72
740 Next j74
750 Next j75
770 Next j77
780 Next j78
800 Next j80
810 Next j81
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudSqr9e")
End
' Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)
1800 fl1 = 1
' Rows
i1 = -8
For i0 = 1 To 9
i1 = i1 + 9
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3): b(5) = a(i1 + 4)
b(6) = a(i1 + 5): b(7) = a(i1 + 6): b(8) = a(i1 + 7): b(9) = a(i1 + 8)
GoSub 1860: If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0
For i0 = 1 To 9
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 9): b(3) = a(i1 + 18): b(4) = a(i1 + 27): b(5) = a(i1 + 36)
b(6) = a(i1 + 45): b(7) = a(i1 + 54): b(8) = a(i1 + 63): b(9) = a(i1 + 72)
GoSub 1860: If fl1 = 0 Then Return
Next i0
' Main Diagonals
b(1) = a(1): b(2) = a(11): b(3) = a(21): b(4) = a(31): b(5) = a(41): b(6) = a(51): b(7) = a(61): b(8) = a(71): b(9) = a(81):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(9): b(2) = a(17): b(3) = a(25): b(4) = a(33): b(5) = a(41): b(6) = a(49): b(7) = a(57): b(8) = a(65): b(9) = a(73):
GoSub 1860: If fl1 = 0 Then Return
Return
1860 fl1 = 1
For j1 = 1 To 9
b20 = b(j1)
For j2 = (1 + j1) To 9
If b20 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
1500 fl1 = 1
' Transpose a()
i3 = 0: Erase a0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
a0(i1, i2) = a(i3)
Next i2
Next i1
i3 = 0:
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
b2(i3) = a0(i2, i1)
Next i2
Next i1
' Calculate c2()
Erase c2
For i1 = 1 To 81
c2(i1) = 9 * a(i1) + b2(i1) + 1
Next i1
fl1 = 1: n20 = 0
For j1 = 1 To 81
a20 = c2(j1):
For j2 = (1 + j1) To 81
If a20 = c2(j2) Then fl1 = 0: Return
Next j2
1510 Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 82).Value = n9
Cells(1, 83).Value = n9
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
'' Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
