The Mobius function Blog

Mathematica 8


NN = 12;
xmax = 35;
a = Table[
Sum[(Cos[x*(k)/NN*2*Pi] + Cos[x*(k - 1)/NN*2*Pi])/2, {k, 1,
NN}], {x, 0, xmax, 0.1}];
N[Max[a], 40]
ListLinePlot[a, PlotRange -> {-4, NN + 1/2}]
ListLinePlot[Accumulate[a]]



NN = 12
xmax = 35;
ListLinePlot[
Table[Sum[Cos[x*(k - 1)/NN*2*Pi], {k, 1, NN}], {x, 0, xmax, 0.1}],
PlotRange -> {-4, NN + 1/2}]
ListLinePlot[
Table[Sum[Cos[x*(k)/NN*2*Pi], {k, 1, NN}], {x, 0, xmax, 0.1}],
PlotRange -> {-4, NN + 1/2}]
a = Table[
Sum[(Cos[x*(k)/NN*2*Pi] + Cos[x*(k - 1)/NN*2*Pi])/2, {k, 1,
NN}], {x, 0, xmax, 0.1}];
N[Max[a], 40]
ListLinePlot[
Table[Sum[(Cos[x*(k)/NN*2*Pi] + Cos[x*(k - 1)/NN*2*Pi])/2, {k, 1,
NN}], {x, 0, xmax, 0.1}], PlotRange -> {-4, NN + 1/2}]
ListLinePlot[Accumulate[a]]


By integration:

(*program start*)NN = 12
xmax = 35;
ListLinePlot[
Table[Sum[(Cos[x*(k)/NN*2*Pi] + Cos[x*(k – 1)/NN*2*Pi])/2, {k, 1,
NN}], {x, 0, xmax, 0.1}], PlotRange -> {-4, NN + 1/2}]

ListLinePlot[
Table[Sum[(3 Sin[
1/6 (-1 + k) \[Pi] x])/((-1 + k) \[Pi]) + (3 Sin[(k \[Pi] x)/
6])/(k \[Pi]), {k, 1.000001, NN}], {x, 0, xmax*2, 0.1}],
PlotRange -> {-4, NN*3}, DataRange -> {0, 250}, ImageSize -> Full,
GridLines -> Automatic]
(*program end*)

Mathematica 8


Clear[t, A];
t[1, 1] = 1;
t[n_, k_] :=
t[n, k] = Mod[If[n >= k, Sum[t[n - i, k - 1], {i, 1, k - 1}], 0], 2];
A = Table[Table[t[n, k], {k, 1, 12}], {n, 1, 12}];
MatrixForm[A]


Mathematica 8

MatrixForm[
Table[Im[N[ZetaZero[6]*Log[i], 30]], {i, 1, 24}]/
0.9242998972229388559595701813595900537^2 - 280/99]
MatrixForm[
Table[Im[N[ZetaZero[6]*Log[i], 30]], {i, 1, 100}]/
0.9242998972229388559595701813595900537^2]


The frequencies appear to be logarithms of the natural numbers: 1,2,3,…

The first plot is the Fourier Cosine Transform of the real part of the Riemann zeta function along the line in the complex plane with real part equal to one half.

The second plot is the Fourier Sine Transform of the imaginary part of the Riemann zeta function along the line in the complex plane with real part equal to one half.

Mathematica 8

Clear[a, dct, dst]
Monitor[a = Table[(Zeta[1/2 + I*t]), {t, 0, 1000, 0.01}];, t]
dct = FourierDCT[Re[a]];
dst = FourierDST[Im[a]];
ListLinePlot[dct[[1 ;; 800]], ImageSize -> Large, PlotRange -> {-20, 100}]
ListLinePlot[dst[[1 ;; 800]], ImageSize -> Large, PlotRange -> {20, -100}]


Mathematica 8

The spikes are at x-values equal to logarithms of 1,2,3,…

Clear[a, c, p]
Monitor[a = Table[(Zeta[1/2 + I*t]), {t, 0, 1000, 0.01}];, t]
dct = FourierDCT[Re[a], 3];
dst = FourierDST[Im[a], 3];
ListLinePlot[dct[[1 ;; 800]], ImageSize -> Large, PlotRange -> {-20, 200}]
ListLinePlot[dst[[1 ;; 800]], ImageSize -> Large, PlotRange -> {20, -200}]

(*Mathematica 8*)
Clear[f]
scale = 1000000;
f = Range[scale] + 1;
xres = .002;
xlist = Exp[Range[0, Log[scale], xres]];
tmax = 60;
tres = .015;
Monitor[errList =
Table[((xlist^(1/2 - 1 + I t).(f[[Floor[xlist]]] - xlist)))*(1/2 +
I t), {t, Range[0, 60, tres]}];, t]
ListLinePlot[-Re[errList]/Length[xlist], DataRange -> {0, 60},
PlotRange -> {-0.1, .3}, Axes -> True, Filling -> Axis]


Plot[Re[(Zeta[1/2 + I t])], {t, 0, 60}, Filling -> Axis]

Clear[f]
scale = 1000000;
f = Range[scale] - 1;
xres = .002;
xlist = Exp[Range[0, Log[scale], xres]];
tmax = 60;
tres = .015;
Monitor[errList =
Table[((xlist^(1/2 - 1 + I t).(f[[Floor[xlist]]] - xlist)))*(1/2 +
I t), {t, Range[0, 60, tres]}];, t]
ListLinePlot[Im[errList]/Length[xlist], DataRange -> {0, 60},
PlotRange -> {-.2, .2}, Axes -> True, Filling -> Axis]



Plot[Im[(Zeta[1/2 + I t])], {t, 0, 60}, Filling -> Axis]


Clear[f]
scale = 1000000;
f = Range[scale];
xres = .002;
xlist = Exp[Range[0, Log[scale], xres]];
tmax = 60;
tres = .015;
Monitor[errList1 =
Table[((xlist^(1/2 - 1 + I t).(f[[Floor[xlist]]] - xlist + 1)))*(1/
2 + I t), {t, Range[0, 60, tres]}];, t]
Monitor[errList2 =
Table[((xlist^(1/2 - 1 + I t).(f[[Floor[xlist]]] - xlist - 1)))*(1/
2 + I t), {t, Range[0, 60, tres]}];, t]
ListLinePlot[{-Re[errList1]/Length[xlist],
Im[errList2]/Length[xlist]}, DataRange -> {0, 60},
PlotRange -> {-.2, .3}, Axes -> True, Filling -> Axis]

Plot[{Re[(Zeta[1/2 + I t])], Im[(Zeta[1/2 + I t])]}, {t, 0, 60},
Filling -> Axis]

Clear[f]
scale = 1000000;
f = Range[scale];
xres = .002;
xlist = Exp[Range[0, Log[scale], xres]];
tmax = 60;
tres = .015;
Monitor[errList1 =
Table[((xlist^(1/2 - 1 + I t).(SawtoothWave[xlist] - 1)))*(1/2 +
I t), {t, Range[0, 60, tres]}];, t]
Monitor[errList2 =
Table[((xlist^(1/2 - 1 + I t).(SawtoothWave[xlist] + 1)))*(1/2 +
I t), {t, Range[0, 60, tres]}];, t]
ListLinePlot[{Re[errList1]/Length[xlist], -Im[errList2]/
Length[xlist]}, DataRange -> {0, 60}, PlotRange -> {-.2, .3},
Axes -> True, Filling -> Axis]

From this page by Robert Baillie at Wolfram Demonstrations:
Mertens function

I learned to plot approximately the Mobius function:

Clear[n, k, A, a, B, b, kk, ii, i]
kk = 70;(*number of Zeta zeros used*)
ii = 10;(*reciprocal of x-axis spacing*)
n = Table[i, {i, 0, 42, 1/ii}];
n[[1]] = 1;
Monitor[A =
Table[Re[N[1/Zeta'[ZetaZero[k]]*n^(ZetaZero[k] - 1)]], {k, 1,
kk}];, k]
a = Table[{i/ii, Plus @@ A[[All, i]]}, {i, 1, Length[n]}];
(*a[[ii+1]]={(ii+1)/ii,0};*)
b = Table[{i + 1/4, MoebiusMu[i]}, {i, 1, 42}];
g1 = ListPlot[b, PlotMarkers -> {Automatic, 12}, PlotStyle -> {Black}];
g2 = ListLinePlot[a, PlotRange -> {-3, 3}];
Show[g1, g2, PlotRange -> {-3, 3}, ImageSize -> Large]

Mathematica 8:

Clear[a, b, c]
a = Sin[N[Im[ZetaZero[1]], 30]]
b = 7 + Times @@ Exp[2*Pi/N[Im[ZetaZero[Range[8]]], 30]]^-1;
c = 6 + Exp[2*Pi/N[Im[ZetaZero[8]], 30]];
b/c

Output:

0.9999970188092790189088067450271
0.9999970144615309213084306406440

Which has 9 digits in common

Posted to math stackexchange:
What are the exact values of the local minima in this spectrum?

Apply this program, originally written by Heike and here modified:

(*Mathematica 8 start*)
Clear[f]
scale = 1000000;
f = Range[scale] - 1;
xres = .002;
xlist = Exp[Range[0, Log[scale], xres]];
tmax = 100;
tres = .015;
ymin = -0.025;
ymax = 0.015;
zz = N[Im[ZetaZero[1]]];
Monitor[errList =
Table[(xlist^(-1/2 + I t).(f[[Floor[xlist]]] - xlist)), {t,
Range[0, tmax, tres]}];, t]
g1 = ListLinePlot[Im[errList]/Length[xlist], DataRange -> {0, tmax},
PlotRange -> {ymin, ymax}, Frame -> True, Axes -> False];
g2 = Graphics[
Line[{{N[Im[ZetaZero[1]]], ymin}, {N[Im[ZetaZero[1]]], ymax}}]];
g3 = Graphics[
Line[{{N[Im[ZetaZero[2]]], ymin}, {N[Im[ZetaZero[2]]], ymax}}]];
g4 = Graphics[
Line[{{N[Im[ZetaZero[3]]], ymin}, {N[Im[ZetaZero[3]]], ymax}}]];
g5 = Graphics[
Line[{{N[Im[ZetaZero[4]]], ymin}, {N[Im[ZetaZero[4]]], ymax}}]];
g6 = Graphics[
Line[{{N[Im[ZetaZero[5]]], ymin}, {N[Im[ZetaZero[5]]], ymax}}]];
g7 = Graphics[
Line[{{N[Im[ZetaZero[6]]], ymin}, {N[Im[ZetaZero[6]]], ymax}}]];
g8 = Graphics[
Line[{{N[Im[ZetaZero[7]]], ymin}, {N[Im[ZetaZero[7]]], ymax}}]];
g9 = Graphics[
Line[{{N[Im[ZetaZero[8]]], ymin}, {N[Im[ZetaZero[8]]], ymax}}]];
g10 = Graphics[
Line[{{N[Im[ZetaZero[9]]], ymin}, {N[Im[ZetaZero[9]]], ymax}}]];
g11 = Graphics[
Line[{{N[Im[ZetaZero[10]]], ymin}, {N[Im[ZetaZero[10]]], ymax}}]];
g12 = Graphics[
Line[{{N[Im[ZetaZero[11]]], ymin}, {N[Im[ZetaZero[11]]], ymax}}]];
g13 = Graphics[
Line[{{N[Im[ZetaZero[12]]], ymin}, {N[Im[ZetaZero[12]]], ymax}}]];
g14 = Graphics[
Line[{{N[Im[ZetaZero[13]]], ymin}, {N[Im[ZetaZero[13]]], ymax}}]];
g15 = Graphics[
Line[{{N[Im[ZetaZero[14]]], ymin}, {N[Im[ZetaZero[14]]], ymax}}]];
g16 = Graphics[
Line[{{N[Im[ZetaZero[15]]], ymin}, {N[Im[ZetaZero[15]]], ymax}}]];
g17 = Graphics[
Line[{{N[Im[ZetaZero[16]]], ymin}, {N[Im[ZetaZero[16]]], ymax}}]];
g18 = Graphics[
Line[{{N[Im[ZetaZero[17]]], ymin}, {N[Im[ZetaZero[17]]], ymax}}]];
g19 = Graphics[
Line[{{N[Im[ZetaZero[18]]], ymin}, {N[Im[ZetaZero[18]]], ymax}}]];
g20 = Graphics[
Line[{{N[Im[ZetaZero[19]]], ymin}, {N[Im[ZetaZero[19]]], ymax}}]];
g21 = Graphics[
Line[{{N[Im[ZetaZero[20]]], ymin}, {N[Im[ZetaZero[20]]], ymax}}]];
g22 = Graphics[
Line[{{N[Im[ZetaZero[21]]], ymin}, {N[Im[ZetaZero[21]]], ymax}}]];
g23 = Graphics[
Line[{{N[Im[ZetaZero[22]]], ymin}, {N[Im[ZetaZero[22]]], ymax}}]];
g24 = Graphics[
Line[{{N[Im[ZetaZero[23]]], ymin}, {N[Im[ZetaZero[23]]], ymax}}]];
g25 = Graphics[
Line[{{N[Im[ZetaZero[24]]], ymin}, {N[Im[ZetaZero[24]]], ymax}}]];
g26 = Graphics[
Line[{{N[Im[ZetaZero[25]]], ymin}, {N[Im[ZetaZero[25]]], ymax}}]];
g27 = Graphics[
Line[{{N[Im[ZetaZero[26]]], ymin}, {N[Im[ZetaZero[26]]], ymax}}]];
g28 = Graphics[
Line[{{N[Im[ZetaZero[27]]], ymin}, {N[Im[ZetaZero[27]]], ymax}}]];
g29 = Graphics[
Line[{{N[Im[ZetaZero[28]]], ymin}, {N[Im[ZetaZero[28]]], ymax}}]];
g30 = Graphics[
Line[{{N[Im[ZetaZero[29]]], ymin}, {N[Im[ZetaZero[29]]], ymax}}]];
gw = Show[g1, g2, g3, g4, g5, g6, g7, g8, g9, g10, g11, g12, g13, g14,
g15, g16, g17, g18, g19, g20, g21, g22, g23, g24, g25, g26, g27,
g28, g29, g30, ImageSize -> Large]
(*Mathematica 8 end*)

The result is a plot with local minima that are close to the imaginary part of the Riemann zeta zeros: