' Perfect Diagonal Magic Cubes (m >= 18, m Mod 3 = 0)

' Tested with Office 2007 under Windows 7

```Sub Perfect18()

y = MsgBox("Locked", vbCritical, "Routine Perfect18")
End

m = 18: N = 8

For k = 0 To m - 1

If k < m - 1 - k Then k1 = k Else k1 = m - 1 - k

For i = 0 To m - 1
i11 = i11 + 1

If i < m - 1 - i Then i1 = i Else i1 = m - 1 - i

For j = 0 To m - 1
j11 = j11 + 1: j12 = j12 + 1

If j < m - 1 - j Then j1 = j Else j1 = m - 1 - j

v = 4*Int(2*i/m) + 2*Int(2*j/m) + ((Int(2*i/m) + Int(2*j/m) + Int(2*k/m)) Mod 2) ' (0 <= v <= 7),

z1 = (i1 + j1 - 2 * k1)
While z1 < 0
z1 = z1 + m / 2
Wend

z = z1 Mod (m / 2)

cijk = (2 * i1 + j1 + k1) Mod (m / 2) ' 0 <= bijk < m/2
dijk = (i1 + 2 * j1 + k1) Mod (m / 2) ' 0 <= cijk < m/2
eijk = (i1 + j1 + 2 * k1) Mod (m / 2) ' 0 <= dijk < m/2

x = F8(v, z, N)

bijk = D8(x, i1, j1, k1, i, j, k, m)

'   Print Cube

If j11 = m + 1 Then j11 = 1
If j12 = m ^ 2 + 1 Then j12 = 1: i11 = i11 + 1

aijk = bijk * (m / 2) ^ 3 + S93(cijk) * (m / 2) ^ 2 + S93(dijk) * (m / 2) + S93(eijk) + 1

Cells(i11 + 1, j11 + 1).Value = aijk

Next j
Next i
Next k

End

End Sub

Function S93(x)

S93 = Q33(Int(x / 3), x Mod 3)

End Function

Function Q33(x, y)

p = 3: q = 3

If 0 < x And x < p - 1 Then

If Int(x / 2) = x / 2 Then    'x is even
Q33 = q * x + y
Else                          'x is odd
Q33 = q * x + (q - 1 - y)
End If

ElseIf x = 0 Then

If Int(y / 2) = y / 2 Then    'y is even
Q33 = y / 2 + (q - 1) / 2
Else                          'y is odd
Q33 = (y - 1) / 2
End If

ElseIf x = p - 1 Then

If Int(y / 2) = y / 2 Then    'y is even
Q33 = y / 2 + (p - 1) * q
Else                          'y is odd
Q33 = (y - 1) / 2 + p * q - (q - 1) / 2
End If

End If

End Function

Function F8(v, z, N)

If Int(v / 2) = v / 2 Then    'v is even

Select Case z

Case 0:       F8 = v
Case 1:       F8 = v + 1
Case 2:       F8 = N / 2 - 1 - v / 2
Case 3:       F8 = N - 1 - v / 2
Case 4, 6, 8: F8 = N - 1 - v
Case 5, 7:    F8 = v

End Select

Else                          'v is odd

Select Case z

Case 0:       F8 = v
Case 1:       F8 = v - 1
Case 2:       F8 = N - 1 - (v - 1) / 2
Case 3:       F8 = N / 2 - 1 - (v - 1) / 2
Case 4, 6, 8: F8 = N - 1 - v
Case 5, 7:    F8 = v

End Select

End If

End Function

Function D8(x, i1, j1, k1, i, j, k, m)

fl1 = 0: fl2 = 0

If j1 = (k1 + 1) Mod (m / 2) And i >= m / 2 And i1 = k1 Then fl1 = 1: GoTo 10
If i1 = (k1 + 1) Mod (m / 2) And j >= m / 2 And j1 = k1 Then fl1 = 1: GoTo 10
If j1 = (k1 + (m + 2) / 4) Mod (m / 2) And i >= m / 2 And i1 = j1 Then fl1 = 1: GoTo 10

k2 = (k1 - 1) Mod (m / 2)
If k2 < 0 Then k2 = (k1 - 1 + m / 2) Mod (m / 2)

If j1 = (k1 + 1) Mod (m / 2) And i >= m / 2 And i1 = k2 Then fl1 = 1: GoTo 10
If i1 = (k1 + 1) Mod (m / 2) And j >= m / 2 And j1 = k2 Then fl1 = 1: GoTo 10

i2 = (j1 - 1) Mod (m / 2)
If i2 < 0 Then i2 = (j1 - 1 + m / 2) Mod (m / 2)

If j1 = (k1 + (m + 2) / 4) Mod (m / 2) And i >= m / 2 And i1 = i2 Then fl1 = 1: GoTo 10

10

If fl1 = 1 Then

D8 = x + (-1) ^ x

Else

D8 = x

End If

End Function
```