' Associated Pantriagonal Magic Cubes (m = 4x)
' Tested with Office 2007 under Windows 7
Sub AssPntr23()
y = MsgBox("Locked", vbCritical, "Routine AssPntr23")
End
Sheets("Klad1").Select
m = 8
For k = 0 To m - 1
For i = 0 To m - 1
i1 = i1 + 1
For j = 0 To m - 1
j1 = j1 + 1: j2 = j2 + 1
z1 = Int(4 * i / m) + j + Int(2 * k / m)
z3 = k Mod (m / 2)
If Int(z1 / 2) = z1 / 2 Then 'z1 even
b = 2 * hm(z3, m) + rm(i, k, m)
Else
b = m - 1 - (2 * hm(z3, m) + rm(i, k, m))
End If
If Int(k / 2) = k / 2 Then 'k even
c = (i + j + k)
Else
c = m / 2 - 3 - (i + j + k)
While c < 0
c = c + m
Wend
End If
d = (-i + j + k)
If d < 0 Then d = d + m
b1 = b
c1 = c Mod m
d1 = d Mod m
a = b1 * m ^ 2 + Tm(c1, m) * m + Um(d1, m) + 1
' Print Cube
If j1 = m + 1 Then j1 = 1
If j2 = m ^ 2 + 1 Then j2 = 1: i1 = i1 + 1
Cells(i1 + 1, j1 + 1).Value = a
' print Components
' Cells(i1 + 1, j1 + 1 + 9).Value = b1
' Cells(i1 + 1, j1 + 1 + 18).Value = Tm(c1, m)
' Cells(i1 + 1, j1 + 1 + 27).Value = Um(d1, m)
Next j
Next i
Next k
End Sub
Function Tm(x, m)
If x < m / 2 Then
Tm = x
Else
Tm = 3 * m / 2 - 1 - x
End If
End Function
Function Um(x, m)
If x < m / 4 Or x >= 3 * m / 4 Then
Um = x
Else
Um = m - 1 - x
End If
End Function
Function hm(x, m)
If x < m / 4 Then
hm = x
Else
hm = m / 2 - 1 - x
End If
End Function
Function rm(x, y, m)
z10 = Int(2 * x / m + 1 / 2) + Int(2 * y / m + 1 / 2)
If Int(z10 / 2) = z10 / 2 Then 'z10 even
rm = 0
Else
rm = 1
End If
End Function
End Sub
