About the Author

' 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
```

 About the Author