' Associated Pantriagonal Magic Cubes (m = 2x + 1, m >= 5, m Mod 3 = 0)
' Tested with Office 2007 under Windows 7
Sub AssPntr22()
y = MsgBox("Locked", vbCritical, "Routine AssPntr22")
End
Sheets("Klad1").Select
m = 9
For i = 0 To m - 1
For j = 0 To m - 1
j1 = j1 + 1
For k = 0 To m - 1
k1 = k1 + 1: k2 = k2 + 1
b = i + j + k + 1
c = (m - 1) + i + j * (m - 1) - k
d = (m - 1) + i * (m - 1) + j * (m - 1) + k
b1 = b Mod m
c1 = c Mod m
d1 = d Mod m
a = Sm3(b1, m) * m ^ 2 + Sm3(c1, m) * m + Sm3(d1, m) + 1
' Print Cube
If k1 = m + 1 Then k1 = 1
If k2 = m ^ 2 + 1 Then k2 = 1: j1 = j1 + 1
Cells(j1 + 1, k1 + 1).Value = a
' Print Components
' Cells(j1 + 1, k1 + 1 + (m + 1)).Value = Sm3(b1, m)
' Cells(j1 + 1, k1 + 1 + 2 * (m + 1)).Value = Sm3(c1, m)
' Cells(j1 + 1, k1 + 1 + 3 * (m + 1)).Value = Sm3(d1, m)
Next k
Next j
Next i
End Sub
Function Sm3(x, m)
x1 = Int(x / 3)
y1 = x Mod 3
p = m / 3
q = 3
Sm3 = Qpq(p, q, x1, y1)
End Function
Function Qpq(p, q, x, y)
If (0 < x And x < p - 1) Then
If Int(x / 2) = x / 2 Then 'x even
Qpq = q * x + y
Else
Qpq = q * x + (q - 1 - y)
End If
ElseIf x = 0 Then
If Int(y / 2) = y / 2 Then 'y even
Qpq = y / 2 + (q - 1) / 2
Else
Qpq = (y - 1) / 2
End If
ElseIf x = p - 1 Then
If Int(y / 2) = y / 2 Then 'y even
Qpq = y / 2 + (p - 1) * q
Else
Qpq = (y - 1) / 2 + p * q - (q - 1) / 2
End If
Else
y = MsgBox("x = " + CStr(x), 0, "Onbepaald")
End If
End Function
