Lehmer's Phenomenon

Author

Eric W. Weisstein
January 3, 2006

This notebook downloaded from http://mathworld.wolfram.com/notebooks/NumberTheory/LehmersPhenomenon.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/LehmersPhenomenon.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Initialization

<<Utilities`Plot`

Code

g[n_?NumericQ,prec_:10]:=GramPoint[n,WorkingPrecision->prec]

Plot

Lehmer

g[4760]

Plot[RiemannSiegelZ[g[t,10]],{t,4760,4770},PlotStyle->Red,WorkingPrecision->10]

Plot[RiemannSiegelZ[g[t]],{t,4763,4764},PlotStyle->Red]

Show[GraphicsArray[{
Plot[Abs[Zeta[1/2+(7005+t)I]]^2,{t,-1,1},
DisplayFunction->Identity,PlotStyle->Red,AxesLabel->TraditionalForm/@{t,Abs[Zeta[1/2+(7005+t)I]]^2}],
Plot[Abs[Zeta[1/2+(7005+t)I]]^2,{t,.05,.11},PlotRange->{Automatic,{0,.00005}},PlotStyle->Red,
AxesOrigin->{.05,Automatic},
AxesLabel->TraditionalForm/@{t,Abs[Zeta[1/2+(7005+t)I]]^2},
DisplayFunction->Identity]
},GraphicsSpacing->-.1]]

Plot[RiemannSiegelZ[7500+t],{t,.05,.11},PlotStyle->Red]

Plot[Abs[Zeta[1/2+(7005+t)I]],{t,0,.12},PlotStyle->Red,WorkingPrecision->10]

N[ZetaZero[1,7005],10]

Timing[zero=t/.FindRoot[Zeta[1/2+(7005+t) I],Evaluate[{t,Sequence@@#}],WorkingPrecision->50]&/@{{.06,.07},{.09,.1}}]

Function[t,Zeta[1/2+(7005+t) I]]/@zero

g[6707.65]

Plot[RiemannSiegelZ[g[t]],{t,6703,6712},PlotStyle->Red]

Plot[RiemannSiegelZ[g[t]],{t,6707,6708},PlotStyle->Red]

Plot[RiemannSiegelZ[g[t]],{t,6703,6712},PlotRange->.1{-1,1},PlotStyle->Red]

Plot[RiemannSiegelZ[t],{t,17143.5,17144},PlotRange->.1{-1,1},PlotStyle->Red]

Rosser et al.

Plot[RiemannSiegelZ[g[t]],{t,13400000,13400010},PlotStyle->Red]

Decreasing Extrema

roots=PlotRoots[Re[XiFunction[1/2+I t]],{t,0,220},WorkingPrecision->25,PlotRange->All]

pairs=Partition[roots,2,1];

extrema=If[Re[XiFunction[1/2+I Mean[#]]]<0,FindMinimum,FindMaximum][Re[XiFunction[1/2+I t]],{t,Sequence@@#}]&/@pairs;

abs=Abs[First/@extrema]

LowWaterMarks[abs]

PlotRoots

SetAttributes[f1, NumericFunction];
f1[t_?InexactNumberQ] := Re[XiFunction[1/2+I t]]
f2[t_] := N[f1[SetPrecision[t, Infinity]], $MachinePrecision + 1]

f2[5225]

PlotRoots[(10^1776)f2[t],{t,5226,5227},PlotStyle->Red,WorkingPrecision->20]

f2[7005.05]

PlotRoots[(10^2385)f2[t],{t,7005,7005.2},WorkingPrecision->20]

g[13400000]//Round

f2[6548606]

PlotRoots[(10^22336780)f2[t],{t,6548604,6548608},WorkingPrecision->20]