' Generates Associated Latin Cubes of order 4 for integers 0 thru 7
' Self Orthogonal
' Tested with Office 365 under Windows 10
Sub SudCube4d2()
Dim a(64), b(8), s(8) 'Latin Cube
Dim a8(64), b8(64), c8(64), c(64), a1(8), a2(8) 'Semi Latin Equivalent Square
y = MsgBox("Locked", vbCritical, "Routine SudCube4d2")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 7: s1 = 14
' Define Correlated Magic Lines
ShtNm2 = "CrltLns8": j40 = 2
For i1 = 1 To 8
a1(i1) = Sheets(ShtNm2).Cells(j40, i1).Value
a2(i1) = Sheets(ShtNm2).Cells(j40, i1 + 9).Value
Next i1
s8 = Sheets(ShtNm2).Cells(j40, 21).Value
s4 = s8 / 2
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64
For j63 = m1 To m2 'a(63)
a(63) = j63
For j62 = m1 To m2 'a(62)
a(62) = j62
a(61) = s1 - a(62) - a(63) - a(64): If a(61) < m1 Or a(61) > m2 Then GoTo 620
For j60 = m1 To m2 'a(60)
a(60) = j60
For j59 = m1 To m2 'a(59)
a(59) = j59
For j58 = m1 To m2 'a(58)
a(58) = j58
a(57) = s1 - a(58) - a(59) - a(60): If a(57) < m1 Or a(57) > m2 Then GoTo 580
For j56 = m1 To m2 'a(56)
a(56) = j56
a(52) = s1 - a(56) - a(60) - a(64): If a(52) < m1 Or a(52) > m2 Then GoTo 560
For j55 = m1 To m2 'a(55)
a(55) = j55
a(51) = s1 - a(55) - a(59) - a(63): If a(51) < m1 Or a(51) > m2 Then GoTo 550
For j54 = m1 To m2 'a(54)
a(54) = j54
a(53) = s1 - a(54) - a(55) - a(56): If a(53) < m1 Or a(53) > m2 Then GoTo 540
a(50) = s1 - a(54) - a(58) - a(62): If a(50) < m1 Or a(50) > m2 Then GoTo 540
a(49) = -2 * s1 + a(54) + a(55) + a(56) + a(58) + a(59) + a(60) + a(62) + a(63) + a(64)
If a(49) < m1 Or a(49) > m2 Then GoTo 540
' Check Top Square
b(1) = a(49): b(2) = a(50): b(3) = a(51): b(4) = a(52): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(53): b(2) = a(54): b(3) = a(55): b(4) = a(56): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(57): b(2) = a(58): b(3) = a(59): b(4) = a(60): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(61): b(2) = a(62): b(3) = a(63): b(4) = a(64): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(49): b(2) = a(53): b(3) = a(57): b(4) = a(61): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(50): b(2) = a(54): b(3) = a(58): b(4) = a(62): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(51): b(2) = a(55): b(3) = a(59): b(4) = a(63): GoSub 860: If fl1 = 0 Then GoTo 540
b(1) = a(52): b(2) = a(56): b(3) = a(60): b(4) = a(64): GoSub 860: If fl1 = 0 Then GoTo 540
For j48 = m1 To m2 'a(48)
a(48) = j48
a(33) = 2 * s1 + a(48) - a(54) - a(55) - a(56) - a(58) - a(59) - a(60) - a(62) - a(63)
If a(33) < m1 Or a(33) > m2 Then GoTo 480
For j47 = m1 To m2 'a(47)
a(47) = j47
a(34) = -s1 + a(47) + a(54) + a(58) + a(62) + a(63): If a(34) < m1 Or a(34) > m2 Then GoTo 470
For j46 = m1 To m2 'a(46)
a(46) = j46
a(45) = s1 - a(46) - a(47) - a(48): If a(45) < m1 Or a(45) > m2 Then GoTo 460
a(36) = s1 - a(46) - a(47) - a(48) + a(56) + a(60) - a(62) - a(63): If a(36) < m1 Or a(36) > m2 Then GoTo 460
a(35) = -s1 + a(46) + a(55) + a(59) + a(62) + a(63): If a(35) < m1 Or a(35) > m2 Then GoTo 460
For j44 = m1 To m2 'a(44)
a(44) = j44
a(41) = -s1 - a(44) + a(46) + a(47) + a(58) + a(59) + a(62) + a(63): If a(41) < m1 Or a(41) > m2 Then GoTo 440
a(40) = -a(44) + a(46) + a(47) - a(56) - a(60) + a(62) + a(63): If a(40) < m1 Or a(40) > m2 Then GoTo 440
a(37) = -s1 + a(44) + a(54) + a(55) + a(56) + a(60): If a(37) < m1 Or a(37) > m2 Then GoTo 440
For j43 = m1 To m2 'a(43)
a(43) = j43
a(42) = 2 * s1 - a(43) - a(46) - a(47) - a(58) - a(59) - a(62) - a(63): If a(42) < m1 Or a(42) > m2 Then GoTo 430
a(39) = 2 * s1 - a(43) - a(46) - a(47) - a(55) - a(59) - a(62) - a(63): If a(39) < m1 Or a(39) > m2 Then GoTo 430
a(38) = a(43) - a(54) + a(59): If a(38) < m1 Or a(38) > m2 Then GoTo 430
a(1) = s1 / 2 - a(64): a(2) = s1 / 2 - a(63): a(3) = s1 / 2 - a(62): a(4) = s1 / 2 - a(61)
a(5) = s1 / 2 - a(60): a(6) = s1 / 2 - a(59): a(7) = s1 / 2 - a(58): a(8) = s1 / 2 - a(57)
a(9) = s1 / 2 - a(56): a(10) = s1 / 2 - a(55): a(11) = s1 / 2 - a(54): a(12) = s1 / 2 - a(53)
a(13) = s1 / 2 - a(52): a(14) = s1 / 2 - a(51): a(15) = s1 / 2 - a(50): a(16) = s1 / 2 - a(49)
a(17) = s1 / 2 - a(48): a(18) = s1 / 2 - a(47): a(19) = s1 / 2 - a(46): a(20) = s1 / 2 - a(45)
a(21) = s1 / 2 - a(44): a(22) = s1 / 2 - a(43): a(23) = s1 / 2 - a(42): a(24) = s1 / 2 - a(41)
a(25) = s1 / 2 - a(40): a(26) = s1 / 2 - a(39): a(27) = s1 / 2 - a(38): a(28) = s1 / 2 - a(37)
a(29) = s1 / 2 - a(36): a(30) = s1 / 2 - a(35): a(31) = s1 / 2 - a(34): a(32) = s1 / 2 - a(33)
' Exclude solutions with identical numbers in rows, colums or pillars
GoSub 800: If fl1 = 0 Then GoTo 430 'rows, colums or pillars
GoSub 900: If fl1 = 0 Then GoTo 430 'Valid (Semi) Latin Cube
GoSub 1500: If fl1 = 0 Then GoTo 430 'Check Self Orthogonal
' n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
n9 = n9 + 1: GoSub 750 'Print results (planes 1, 2, 3, 4)
' n9 = n9 + 1: GoSub 760 'Print results (Equivalent Square 8 x 8)
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
430 Next j43
440 Next j44
460 Next j46
470 Next j47
480 Next j48
540 Next j54
550 Next j55
560 Next j56
580 Next j58
590 Next j59
600 Next j60
620 Next j62
630 Next j63
640 Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudCube4d2")
End
' Check and Construct Self Orthogonal Semi Latin Square (8 x 8)
1500 fl1 = 1
' Equivalent Square (8 x 8)
' Equivalent Square (8 x 8)
a8(1) = a(49): a8(2) = a(50): a8(3) = a(51): a8(4) = a(52): a8(5) = a(33): a8(6) = a(34): a8(7) = a(35): a8(8) = a(36):
a8(9) = a(53): a8(10) = a(54): a8(11) = a(55): a8(12) = a(56): a8(13) = a(37): a8(14) = a(38): a8(15) = a(39): a8(16) = a(40):
a8(17) = a(57): a8(18) = a(58): a8(19) = a(59): a8(20) = a(60): a8(21) = a(41): a8(22) = a(42): a8(23) = a(43): a8(24) = a(44):
a8(25) = a(61): a8(26) = a(62): a8(27) = a(63): a8(28) = a(64): a8(29) = a(45): a8(30) = a(46): a8(31) = a(47): a8(32) = a(48):
a8(33) = a(17): a8(34) = a(18): a8(35) = a(19): a8(36) = a(20): a8(37) = a(1): a8(38) = a(2): a8(39) = a(3): a8(40) = a(4):
a8(41) = a(21): a8(42) = a(22): a8(43) = a(23): a8(44) = a(24): a8(45) = a(5): a8(46) = a(6): a8(47) = a(7): a8(48) = a(8):
a8(49) = a(25): a8(50) = a(26): a8(51) = a(27): a8(52) = a(28): a8(53) = a(9): a8(54) = a(10): a8(55) = a(11): a8(56) = a(12):
a8(57) = a(29): a8(58) = a(30): a8(59) = a(31): a8(60) = a(32): a8(61) = a(13): a8(62) = a(14): a8(63) = a(15): a8(64) = a(16):
' Check Semi Latin Property
GoSub 1800: If fl1 = 0 Then Return
' Transposed Equiv. Sqr (8 x 8)
b8(1) = a8(1): b8(9) = a8(2): b8(17) = a8(3): b8(25) = a8(4): b8(33) = a8(5): b8(41) = a8(6): b8(49) = a8(7): b8(57) = a8(8):
b8(2) = a8(9): b8(10) = a8(10): b8(18) = a8(11): b8(26) = a8(12): b8(34) = a8(13): b8(42) = a8(14): b8(50) = a8(15): b8(58) = a8(16):
b8(3) = a8(17): b8(11) = a8(18): b8(19) = a8(19): b8(27) = a8(20): b8(35) = a8(21): b8(43) = a8(22): b8(51) = a8(23): b8(59) = a8(24):
b8(4) = a8(25): b8(12) = a8(26): b8(20) = a8(27): b8(28) = a8(28): b8(36) = a8(29): b8(44) = a8(30): b8(52) = a8(31): b8(60) = a8(32):
b8(5) = a8(33): b8(13) = a8(34): b8(21) = a8(35): b8(29) = a8(36): b8(37) = a8(37): b8(45) = a8(38): b8(53) = a8(39): b8(61) = a8(40):
b8(6) = a8(41): b8(14) = a8(42): b8(22) = a8(43): b8(30) = a8(44): b8(38) = a8(45): b8(46) = a8(46): b8(54) = a8(47): b8(62) = a8(48):
b8(7) = a8(49): b8(15) = a8(50): b8(23) = a8(51): b8(31) = a8(52): b8(39) = a8(53): b8(47) = a8(54): b8(55) = a8(55): b8(63) = a8(56):
b8(8) = a8(57): b8(16) = a8(58): b8(24) = a8(59): b8(32) = a8(60): b8(40) = a8(61): b8(48) = a8(62): b8(56) = a8(63): b8(64) = a8(64):
' Resulting Prime Number Magic Square
For j4 = 1 To 64
i1 = a8(j4) + 1:
i2 = b8(j4) + 1:
c8(j4) = a1(i1) + a2(i2)
Next j4
' Check Identical Numbers
fl1 = 1
For j1 = 1 To 64
a20 = c8(j1):
For j2 = (1 + j1) To 64
If a20 = c8(j2) Then fl1 = 0: Return
Next j2
Next j1
' Retransform to Cube Format
c(1) = c8(1): c(2) = c8(2): c(3) = c8(3): c(4) = c8(4): c(17) = c8(5): c(18) = c8(6): c(19) = c8(7): c(20) = c8(8):
c(5) = c8(9): c(6) = c8(10): c(7) = c8(11): c(8) = c8(12): c(21) = c8(13): c(22) = c8(14): c(23) = c8(15): c(24) = c8(16):
c(9) = c8(17): c(10) = c8(18): c(11) = c8(19): c(12) = c8(20): c(25) = c8(21): c(26) = c8(22): c(27) = c8(23): c(28) = c8(24):
c(13) = c8(25): c(14) = c8(26): c(15) = c8(27): c(16) = c8(28): c(29) = c8(29): c(30) = c8(30): c(31) = c8(31): c(32) = c8(32):
c(33) = c8(33): c(34) = c8(34): c(35) = c8(35): c(36) = c8(36): c(49) = c8(37): c(50) = c8(38): c(51) = c8(39): c(52) = c8(40):
c(37) = c8(41): c(38) = c8(42): c(39) = c8(43): c(40) = c8(44): c(53) = c8(45): c(54) = c8(46): c(55) = c8(47): c(56) = c8(48):
c(41) = c8(49): c(42) = c8(50): c(43) = c8(51): c(44) = c8(52): c(57) = c8(53): c(58) = c8(54): c(59) = c8(55): c(60) = c8(56):
c(45) = c8(57): c(46) = c8(58): c(47) = c8(59): c(48) = c8(60): c(61) = c8(61): c(62) = c8(62): c(63) = c8(63): c(64) = c8(64):
Return
' Check Semi Latin Property
1800
' Rows
i1 = -7
For i0 = 1 To 8
i1 = i1 + 8
b(1) = a8(i1): b(2) = a8(i1 + 1): b(3) = a8(i1 + 2): b(4) = a8(i1 + 3):
b(5) = a8(i1 + 4): b(6) = a8(i1 + 5): b(7) = a8(i1 + 6): b(8) = a8(i1 + 7)
GoSub 1860: If fl1 = 0 Then Return
Next i0
' Columns
'' i1 = 0
'' For i0 = 1 To 8
'' i1 = i1 + 1
'' b(1) = a8(i1): b(2) = a8(i1 + 8): b(3) = a8(i1 + 16): b(4) = a8(i1 + 24):
'' b(5) = a8(i1 + 32): b(6) = a8(i1 + 40): b(7) = a8(i1 + 48): b(8) = a8(i1 + 56)
'' GoSub 1860: If fl1 = 0 Then Return
'' Next i0
' Main Diagonals
b(1) = a8(1): b(2) = a8(10): b(3) = a8(19): b(4) = a8(28): b(5) = a8(37): b(6) = a8(46): b(7) = a8(55): b(8) = a8(64)
GoSub 1860: If fl1 = 0 Then Return
b(1) = a8(8): b(2) = a8(15): b(3) = a8(22): b(4) = a8(29): b(5) = a8(36): b(6) = a8(43): b(7) = a8(50): b(8) = a8(57)
GoSub 1860: If fl1 = 0 Then Return
Return
' Check identical numbers
1860 fl1 = 1
For j10 = 1 To 8
b2 = b(j10)
For j20 = (1 + j10) To 8
If b2 = b(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Print results (selected numbers)
740 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(1, 67).Value = n9
Return
' Print results (planes 11, 12, 13 and 14)
750 n2 = n2 + 1
If n2 = 9 Then
n2 = 1: k1 = k1 + 20: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
For i0 = 1 To 4
i3 = (4 - i0) * 16
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + i1 + (i0 - 1) * 5, k2 + i2).Value = a(i3)
Next i2
Next i1
''Cells(k1 + (i0 - 1) * 5, k2 + 1).Value = "Plane 1" + CStr(i0)
Next i0
Return
' Print results (Equivalent Magic Square)
760 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c8(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers in rows, colums or pillars
800 fl1 = 1
' Rows
i1 = -3
For i0 = 1 To 16
i1 = i1 + 4
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3)
GoSub 860
If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0: i2 = 0
For i0 = 1 To 16
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 4): b(3) = a(i1 + 8): b(4) = a(i1 + 12)
i2 = i2 + 1: If i2 = 4 Then i2 = 0: i1 = i1 + 12
GoSub 860
If fl1 = 0 Then Return
Next i0
' Pillars
i1 = 0: i2 = 0
For i0 = 1 To 16
i1 = i0
b(1) = a(i1): b(2) = a(i1 + 16): b(3) = a(i1 + 32): b(4) = a(i1 + 48)
GoSub 860
If fl1 = 0 Then Return
Next i0
' Space Diagonals
b(1) = a(1): b(2) = a(22): b(3) = a(43): b(4) = a(64): GoSub 860: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(23): b(3) = a(42): b(4) = a(61): GoSub 860: If fl1 = 0 Then Return
b(1) = a(13): b(2) = a(26): b(3) = a(39): b(4) = a(52): GoSub 860: If fl1 = 0 Then Return
b(1) = a(16): b(2) = a(27): b(3) = a(38): b(4) = a(49): GoSub 860: If fl1 = 0 Then Return
850 Return
860 fl1 = 1
For j1 = 1 To 4
b2 = b(j1)
For j2 = (1 + j1) To 4
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
GoSub 875 'Check suitable for Prime Numbers
Return
' Check suitable for Prime Numbers
875 fl1 = 1
Erase s
For j1 = 1 To 4
s(b(j1) + 1) = s(b(j1) + 1) + 1
Next j1
For j1 = 1 To 4
If s(j1) <> s(9 - j1) Then fl1 = 0: Return
Next j1
Return
' Valid (Semi) Latin Cube
900 fl1 = 1
Erase s
For i1 = 1 To 64
s(a(i1) + 1) = s(a(i1) + 1) + 1
Next i1
For i1 = 1 To 8
If s(i1) <> 8 Then fl1 = 0: Return
Next i1
Return
End Sub
