' Generates SelfOrthogonal Latin Diagonal Squares (9 x 9)
' Based on Compact Pan Magic Ternary Squares
' Tested with Office 365 under Windows 11
Sub SelfOrth9b()
Dim b1(2, 81), a(81), b(9), s(81)
Dim b2(81), c2(81), a0(9, 9)
Sheets("Klad1").Select
y = MsgBox("Locked", vbCritical, "Routine SelfOrth9b")
End
n4 = 3456 'Base Case
n2 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 36: s2 = 8
t1 = Timer
For j1 = 1 To n4
For j2 = 1 To n4
If j2 = j1 Then GoTo 20
j10 = j1: j20 = 1: GoSub 100 'Read Ternary Square 1
j10 = j2: j20 = 2: GoSub 100 'Read Ternary Square 2
For j4 = 1 To 81
a(j4) = b1(1, j4) + 3 * b1(2, j4)
Next j4
'' GoSub 1050: If fl1 = 1 Then GoTo 20 'Exclude Associated (Option)
GoSub 1800: If fl1 = 0 Then GoTo 20 'Check identical numbers
'in rows, columns, main diagonals
GoSub 1500: If fl1 = 0 Then GoTo 20 'Check SelfOrthogonal
n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
' n9 = n9 + 1: GoSub 750 'Print results (squares)
20 Next j2
Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SelfOrth9b")
End
' Read Ternary Squares (Line Format)
100 For i1 = 1 To 81
b1(j20, i1) = Sheets("TrnLns9").Cells(j10, i1).Value
Next i1
Return
' Check identical numbers
' in rows, columns, main diagonals and sub squares (partly compact only)
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
' Check identical numbers
1860 fl1 = 1
For j10 = 1 To 9
b20 = b(j10)
For j20 = (1 + j10) To 9
If b20 = b(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Print results (selected numbers)
740 ''Cells(n9, 81).Select
For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 82).Value = j1
Cells(n9, 83).Value = j2
Cells(1, 84).Value = j1
Cells(1, 85).Value = n9
Return
' Print results (squares)
750 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 = n9
Cells(k1, k2 + 2).Value = j1
Cells(k1, k2 + 3).Value = j2
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
' Check Associated Magic Squares (Option)
1050 fl1 = 1
s(1) = a(1) + a(81): s(11) = a(11) + a(71): s(21) = a(21) + a(61): s(31) = a(31) + a(51):
s(2) = a(2) + a(80): s(12) = a(12) + a(70): s(22) = a(22) + a(60): s(32) = a(32) + a(50):
s(3) = a(3) + a(79): s(13) = a(13) + a(69): s(23) = a(23) + a(59): s(33) = a(33) + a(49):
s(4) = a(4) + a(78): s(14) = a(14) + a(68): s(24) = a(24) + a(58): s(34) = a(34) + a(48):
s(5) = a(5) + a(77): s(15) = a(15) + a(67): s(25) = a(25) + a(57): s(35) = a(35) + a(47):
s(6) = a(6) + a(76): s(16) = a(16) + a(66): s(26) = a(26) + a(56): s(36) = a(36) + a(46):
s(7) = a(7) + a(75): s(17) = a(17) + a(65): s(27) = a(27) + a(55): s(37) = a(37) + a(45):
s(8) = a(8) + a(74): s(18) = a(18) + a(64): s(28) = a(28) + a(54): s(38) = a(38) + a(44):
s(9) = a(9) + a(73): s(19) = a(19) + a(63): s(29) = a(29) + a(53): s(39) = a(39) + a(43):
s(10) = a(10) + a(72): s(20) = a(20) + a(62): s(30) = a(30) + a(52): s(40) = a(40) + a(42):
For j20 = 1 To 40
If s(j20) <> s2 Then fl1 = 0: Exit For
Next j20
Return
' Check SelfOrthogonal
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 j10 = 1 To 81
a20 = c2(j10): ''If a20 = 1 Then GoTo 1510
For j20 = (1 + j10) To 81
If a20 = c2(j20) Then fl1 = 0: Return
Next j20
1510 Next j10
Return
End Sub
