' Associated Nasik Magic Cubes (m = 2x + 1, m >= 9, 1 < gcd(m, 3 x 5 x 7) < m)
' Tested with Office 2007 under Windows 7
Sub AssNasik22()
y = MsgBox("Locked", vbCritical, "Routine AssNasik22")
End
Sheets("Klad1").Select
m = 25
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
b = i + 2 * j + 4 * k + 3
c = i - 2 * j + 4 * k + 1
While c < 0
c = c + m
Wend
d = i + 2 * j - 4 * k - 1
While d < 0
d = d + m
Wend
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 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 = c1
'' Cells(i1 + 1, j1 + 1 + 27).Value = d1
Next j
Next i
Next k
End Sub
Function Smq(x, m)
q = Gcd(m, 105)
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
ElseIf m Mod 7 = 0 Then
Gcd = 7
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
