Dickman Function

Author

Eric W. Weisstein
June 13, 2003

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PrimeNumbers/DickmanFunction.nb.

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

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

Additional Authors

Iterative DSolve code by
Michael Trott
June 13, 2003

Code

Have to use linear since quadratic produces obviously wrong bulges

F[α_]:=1 /;α>=1
F[α_]:=0/;α≤0
F[α_]:=Interpolation[Reverse/@{{0.,0.},{.01,.2697},{.05,.3348},{.1,.3785},{.2,.4430},{.35,.5220},{.5,.6065},{.65,.7047},{.8,.8187},{.9,.9048},{.95,.9512},{.99,.99},{1,1}},InterpolationOrder->1][α]/;0<α<1

G[α_]:=1 /;α>=1
G[α_]:=0/;α≤0
G[α_]:=Interpolation[Reverse/@{{0.,0.},{.01,.0056},{.05,.0273},{.1,.0531},{.2,.1003},{.35,.1611},{.5,.2117},{.65,.2582},{.8,.3104},{.9,.3590},{.95,.3967},{.99,.4517},{1,1}},InterpolationOrder->1][α]/;0<α<1

Plot

<<Graphics`Colors`

Plot[{F[α],G[α]},{α,0,1.2},PlotStyle->{Red,Blue},
AxesLabel->TraditionalForm/@{{α,β},{StyleForm[F[α],FontColor->Red],StyleForm[G[β],FontColor->Blue]}}]

Error

Plot[F[α]-NIntegrate[F[t/(1-t)]/t,{t,0,α},MaxRecursion->10],{α,0,1},
Epilog->{Red,Line[{{#,-1},{#,1}}]&/@Last/@{{0.,0.},{.01,.2697},{.05,.3348},{.1,.3785},{.2,.4430},{.35,.5220},{.5,.6065},{.65,.7047},{.8,.8187},{.9,.9048},{.95,.9512},{.99,.99},{1,1}}}]//Timing

Iterative DSolve

F(α)=(∫_0^α)((F((t/(1-t))))/t)dt

so

F'(α)=F((α/(1-α)))(1/α)

Off[InterpolatingFunction::dmval,NDSolve::precw,Power::"infy",Less::"nord",NDSolve::"nlnum"];

Clear[F];
F[0][x_]=Which[x<0,0,0≤x≤1,Exp[1-1/x],x>1,1];
With[{ε=10^-5,n=20},
Do[ndsol[k]=NDSolve[{F[k]'[x]==F[k-1][x/(1-x)]/x,F[k][ε]==F[k-1][ε]},F[k],{x,ε,1},
WorkingPrecision->35,MaxSteps->10^5,PrecisionGoal->18,AccuracyGoal->18][[1,1,2]];
Print["Step ",k,"..."];
F[k][x_]=Which[x<0,0,0≤x≤1,Evaluate[ndsol[k][x]/ndsol[k][1]],x>1,1],
{k,n}]
]//Timing

Plot[F[20][a],{a,0,1},PlotRange->All,PlotStyle->Red]

Table[Show[GraphicsArray[Block[{$DisplayFunction=Identity},
{Plot[F[k][x],{x,0,1},PlotRange->All,PlotStyle->Red,PlotLabel->k],
Plot[Log[Abs[F[k][x]-F[k-1][x]]],{x,0,1},PlotRange->{All,{-20,-2}},PlotStyle->Red]
}
]]],{k,20}]

Comparison with Knuth

<<Graphics`Colors`

Plot[{FKnuth[a],F[20][a]},{a,0,.35},PlotRange->All,PlotStyle->{Red,Blue}]

Plot[{FKnuth[a],F[20][a]},{a,0,1},PlotRange->All,PlotStyle->{Red,Blue}]

{First[#],Last[#],F[30][First[#]]}&/@Reverse/@{{0.,0.},{0.01,0.2697},{0.05,0.3348},{0.1,0.3785},{0.2,0.443},{0.35,0.522},{0.5,0.6065},{0.65,0.7047},{0.8,0.8187},{0.9,0.9048},{0.95,0.9512},{0.99,0.99},{1,1}}

Differential Delay Equation

ρ[u] = 1 for 0≤u<1
u ρ'[u]+ρ[u-1]=0 for u>1

ρ[u_]:=F[20][1/u]

Table[ρ[u],{u,.01,1,.1}]

Table[u ρ'[u]+ρ[u-1],{u,1.01,5,.1}]

<<Graphics`Colors`

Plot[ρ[u],{u,0,5},PlotStyle->Red,AxesLabel->TraditionalForm/@{u,HoldForm[ρ[u]]}]

Relationship with Golomb-Dickman constant

NIntegrate[F[30][t/(1-t)],{t,0,1}]//FullForm

λ=NIntegrate[Exp[LogIntegral[x]],{x,0,1},WorkingPrecision->110,MaxRecursion->20]