' Associated Pandiagonal Magic Cubes (m = 2x + 1, m >= 7, 1 < gcd(m, 3 x 5) < m)

' Tested with Office 2007 under Windows 7

```Sub AssPanDia22()

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

m = 25

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 + 2 * j + 3 * k + ((m - 1) / 2 + 3)
c = i + 3 * j + 2 * k + ((m - 1) / 2 + 3)
d = 2 * i + 3 * j - k + ((m - 1) / 2 + 2)
If d < m Then d = d + m

b1 = b Mod m
c1 = c Mod m
d1 = d Mod m

a = Smq(b1, m) * m ^ 2 + Smq(c1, m) * m + Smq(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 = Smq(b1, m)
'   Cells(j1 + 1, k1 + 1 + 2 * (m + 1)).Value = Smq(c1, m)
'   Cells(j1 + 1, k1 + 1 + 3 * (m + 1)).Value = Smq(d1, m)

Next k
Next j
Next i

End Sub

Function Smq(x, m)

q = Gcd(m, 15)
p = m / q
x1 = Int(x / q)
y1 = x Mod q
Smq = Qpq(p, q, x1, y1)

End Function

Function Gcd(m, z)

If m Mod 3 = 0 Then
Gcd = 3
ElseIf m Mod 5 = 0 Then
Gcd = 5
Else
y = MsgBox("Not applicable", vbExclamation, "Test")
End
End If

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
End If

End Function
```