' Generates Quaternary Panttriagonal Magic Cubes of order 4 for integers 0 thru 3
' (Compact and Complete)
' Tested with Office 2007 under Windows 7
Sub SudCube4b()
Dim a(64), b(4), a5(16)
y = MsgBox("Locked", vbCritical, "Routine SudCube4b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 3: s1 = 6
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64
a(22) = s1 / 2 - a(64): If a(22) < m1 Or a(22) > m2 Then GoTo 640
For j63 = m1 To m2 'a(63)
a(63) = j63
a(21) = s1 / 2 - a(63): If a(21) < m1 Or a(21) > m2 Then GoTo 630
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
a(24) = s1 / 2 - a(62): If a(24) < m1 Or a(24) > m2 Then GoTo 620
a(23) = -s1 / 2 + a(62) + a(63) + a(64): If a(23) < m1 Or a(23) > m2 Then GoTo 620
For j60 = m1 To m2 'a(60)
a(60) = j60
a(59) = s1 - a(60) - a(63) - a(64): If a(59) < m1 Or a(59) > m2 Then GoTo 600
a(58) = a(60) - a(62) + a(64): If a(58) < m1 Or a(58) > m2 Then GoTo 600
a(57) = -a(60) + a(62) + a(63): If a(57) < m1 Or a(57) > m2 Then GoTo 600
a(20) = s1 / 2 - a(60) + a(62) - a(64): If a(20) < m1 Or a(20) > m2 Then GoTo 600
a(19) = s1 / 2 + a(60) - a(62) - a(63): If a(19) < m1 Or a(19) > m2 Then GoTo 600
a(18) = s1 / 2 - a(60): If a(18) < m1 Or a(18) > m2 Then GoTo 600
a(17) = -s1 / 2 + a(60) + a(63) + a(64): If a(17) < m1 Or a(17) > m2 Then GoTo 600
For j56 = m1 To m2 'a(56)
a(56) = j56
a(55) = -a(56) + a(63) + a(64): If a(55) < m1 Or a(55) > m2 Then GoTo 560
a(54) = a(56) + a(62) - a(64): If a(54) < m1 Or a(54) > m2 Then GoTo 560
a(53) = s1 - a(56) - a(62) - a(63): If a(53) < m1 Or a(53) > m2 Then GoTo 560
a(52) = s1 - a(56) - a(60) - a(64): If a(52) < m1 Or a(52) > m2 Then GoTo 560
a(51) = a(56) + a(60) - a(63): If a(51) < m1 Or a(51) > m2 Then GoTo 560
a(50) = s1 - a(56) - a(60) - a(62): If a(50) < m1 Or a(50) > m2 Then GoTo 560
a(49) = -s1 + a(56) + a(60) + a(62) + a(63) + a(64): If a(49) < m1 Or a(49) > m2 Then GoTo 560
a(32) = s1 / 2 - a(56) - a(62) + a(64): If a(32) < m1 Or a(32) > m2 Then GoTo 560
a(31) = -s1 / 2 + a(56) + a(62) + a(63): If a(31) < m1 Or a(31) > m2 Then GoTo 560
a(30) = s1 / 2 - a(56): If a(30) < m1 Or a(30) > m2 Then GoTo 560
a(29) = s1 / 2 + a(56) - a(63) - a(64): If a(29) < m1 Or a(29) > m2 Then GoTo 560
a(28) = -s1 / 2 + a(56) + a(60) + a(62): If a(28) < m1 Or a(28) > m2 Then GoTo 560
a(27) = 3 * s1 / 2 - a(56) - a(60) - a(62) - a(63) - a(64): If a(27) < m1 Or a(27) > m2 Then GoTo 560
a(26) = -s1 / 2 + a(56) + a(60) + a(64): If a(26) < m1 Or a(26) > m2 Then GoTo 560
a(25) = s1 / 2 - a(56) - a(60) + a(63): If a(25) < m1 Or a(25) > m2 Then GoTo 560
For j48 = m1 To m2 'a(48)
a(48) = j48
a(47) = s1 - a(48) - a(63) - a(64): If a(47) < m1 Or a(47) > m2 Then GoTo 480
a(46) = a(48) - a(62) + a(64): If a(46) < m1 Or a(46) > m2 Then GoTo 480
a(45) = -a(48) + a(62) + a(63): If a(45) < m1 Or a(45) > m2 Then GoTo 480
a(44) = s1 - a(48) - a(60) - a(64): If a(44) < m1 Or a(44) > m2 Then GoTo 480
a(43) = -s1 + a(48) + a(60) + a(63) + 2 * a(64): If a(43) < m1 Or a(43) > m2 Then GoTo 480
a(42) = s1 - a(48) - a(60) + a(62) - 2 * a(64): If a(42) < m1 Or a(42) > m2 Then GoTo 480
a(41) = a(48) + a(60) - a(62) - a(63) + a(64): If a(41) < m1 Or a(41) > m2 Then GoTo 480
a(40) = a(48) - a(56) + a(64): If a(40) < m1 Or a(40) > m2 Then GoTo 480
a(39) = s1 - a(48) + a(56) - a(63) - 2 * a(64): If a(39) < m1 Or a(39) > m2 Then GoTo 480
a(38) = a(48) - a(56) - a(62) + 2 * a(64): If a(38) < m1 Or a(38) > m2 Then GoTo 480
a(37) = -a(48) + a(56) + a(62) + a(63) - a(64): If a(37) < m1 Or a(37) > m2 Then GoTo 480
a(36) = -a(48) + a(56) + a(60): If a(36) < m1 Or a(36) > m2 Then GoTo 480
a(35) = a(48) - a(56) - a(60) + a(63) + a(64): If a(35) < m1 Or a(35) > m2 Then GoTo 480
a(34) = -a(48) + a(56) + a(60) + a(62) - a(64): If a(34) < m1 Or a(34) > m2 Then GoTo 480
a(33) = s1 + a(48) - a(56) - a(60) - a(62) - a(63): If a(33) < m1 Or a(33) > m2 Then GoTo 480
a(16) = s1 / 2 - a(48) + a(56) + a(62) - 2 * a(64): If a(16) < m1 Or a(16) > m2 Then GoTo 480
a(15) = s1 / 2 + a(48) - a(56) - a(62) - a(63) + a(64): If a(15) < m1 Or a(15) > m2 Then GoTo 480
a(14) = s1 / 2 - a(48) + a(56) - a(64): If a(14) < m1 Or a(14) > m2 Then GoTo 480
a(13) = -s1 / 2 + a(48) - a(56) + a(63) + 2 * a(64): If a(13) < m1 Or a(13) > m2 Then GoTo 480
a(12) = s1 / 2 + a(48) - a(56) - a(60) - a(62) + a(64): If a(12) < m1 Or a(12) > m2 Then GoTo 480
a(11) = -s1 / 2 - a(48) + a(56) + a(60) + a(62) + a(63): If a(11) < m1 Or a(11) > m2 Then GoTo 480
a(10) = s1 / 2 + a(48) - a(56) - a(60): If a(10) < m1 Or a(10) > m2 Then GoTo 480
a(9) = s1 / 2 - a(48) + a(56) + a(60) - a(63) - a(64): If a(9) < m1 Or a(9) > m2 Then GoTo 480
a(8) = s1 / 2 - a(48) + a(62) - a(64): If a(8) < m1 Or a(8) > m2 Then GoTo 480
a(7) = s1 / 2 + a(48) - a(62) - a(63): If a(7) < m1 Or a(7) > m2 Then GoTo 480
a(6) = s1 / 2 - a(48): If a(6) < m1 Or a(6) > m2 Then GoTo 480
a(5) = -s1 / 2 + a(48) + a(63) + a(64): If a(5) < m1 Or a(5) > m2 Then GoTo 480
a(4) = -s1 / 2 + a(48) + a(60) - a(62) + 2 * a(64): If a(4) < m1 Or a(4) > m2 Then GoTo 480
a(3) = s1 / 2 - a(48) - a(60) + a(62) + a(63) - a(64): If a(3) < m1 Or a(3) > m2 Then GoTo 480
a(2) = -s1 / 2 + a(48) + a(60) + a(64): If a(2) < m1 Or a(2) > m2 Then GoTo 480
a(1) = 3 * s1 / 2 - a(48) - a(60) - a(63) - 2 * a(64): If a(1) < m1 Or a(1) > m2 Then GoTo 480
n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
' n9 = n9 + 1: GoSub 750 'Print results (planes 11, 12, 13, 14)
' n9 = n9 + 1: GoSub 760 'Print results (3d)
480 Next j48
560 Next j56
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 SudCube4b")
End
' Print results (selected numbers)
740 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (planes 11, 12, 13 and 14)
750 n2 = n2 + 1
If n2 = 7 Then
n2 = 1: k1 = k1 + 20: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
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
If i0 = 1 Then
Cells(k1 + (i0 - 1) * 5, k2 + 1).Value = "Plane 1" + CStr(i0) + " (C" + CStr(n9) + ")"
Else
Cells(k1 + (i0 - 1) * 5, k2 + 1).Value = "Plane 1" + CStr(i0)
End If
Next i0
Return
' Print results (3d)
760 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 29: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 17
End If
For i0 = 1 To 4
i3 = (4 - i0) * 16
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + 1 + (i1 - 1) * 2 + (i0 - 1) * 7, k2 + 7 + (i2 - 1) * 3 - (i1 - 1) * 2).Value = a(i3)
Next i2
Next i1
Next i0
Return
End Sub
