Logistic Map

Author

Eric W. Weisstein
October 26, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/DynamicalSystems/LogisticMap.nb.

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

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

Additional Authors

Michael Trott

Code

If[$VersionNumber<6.0,
Discriminant[p_?PolynomialQ,x_]:=With[{m=Exponent[p,x]},Cancel[((-1)^(1/2m(m-1))Resultant[p,D[p,x],x])/Coefficient[p,x,m]^(2m-1)]
]
]

CycleOnsetGroebner[n_Integer/;n>2,opts___?OptionQ]:=Module[{a=Array[x,n],r},
Evaluate[
GroebnerBasis[
Append[r #1(1-#1)-#2&@@@Partition[a,2,1,1],
r^n Times@@((1-2#)&/@a)-1],
r,a,opts,MonomialOrder->EliminationOrder][[1]]/.r->#]&
]

CycleOnset[1,opts___?OptionQ]:=1
CycleOnset[2,opts___?OptionQ]:=3
CycleOnset[n_Integer/;n>2,opts___?OptionQ]:=Min[x/.{ToRules[Reduce[CycleOnsetGroebner[n,opts][x]==0&&x>3,x]]}]

NCycleOnset[n_,opts___]:=Module[{a=Array[x,n],r},Select[Select[Union[r/.NSolve[
Append[r #1(1-#1)-#2&@@@Partition[a,2,1,1],
r^n Times@@( (1-2#)&/@a)-1],
r,a,opts]],Positive],#>3&]
]

NCycleMinimize[n_,opts___]:=Module[{a=Array[x,n],r},NMinimize[{r,
And@@Append[r #1(1-#1)==#2&@@@Partition[a,2,1,1],
r^n Times@@( (1-2#)&/@a)==1]&&3<r<4&&And@@(0<#<1&/@a)
},
Prepend[a,r],
opts
][[1]]
]

f[x_]:=r x(1-x)

Web Diagram

LogisticSegments[r_,x0_,its_]:=Module[
{l=NestList[r#(1-#)&,x0,its]},
Partition[Flatten[Transpose[{l,l}]],2,1]
]

p2=Partition[LogisticSegments[3.741,.00079,15],2,1];

movie=Table[Plot[{3.741x(1-x),x},{x,0,1},PlotStyle->{{},Dashing[{.02}]},
Prolog->MapIndexed[{Hue[#2[[1]]/Length[p2]],Line[#]}&,Take[p2,i]],
AspectRatio->Automatic,
AxesLabel->TraditionalForm/@{(Subscript[x, n]),(Subscript[x, n+1])}
],{i,Length[p2]}];

<<Utilities`GIF`;

Export[gifs<>"logistic.gif",movie]//Timing

movie=Table[Plot[{3.741x(1-x),x},{x,0,1},PlotStyle->{{},Dashing[{.02}]},
Prolog->MapIndexed[{Hue[#2[[1]]/Length[p2]],Line[#]}&,Take[p2,i]],
AspectRatio->Automatic,
AxesLabel->TraditionalForm/@{(Subscript[x, n]),(Subscript[x, n+1])}
],{i,Length[p2]}];

ListAnimate[movie]

Last[movie]

Iterations

Factor[Table[Nest[r#(1-#)&,x,n],{n,3}]]//TableForm//TraditionalForm

Plots

Show[GraphicsArray[Partition[Table[
Plot[Evaluate[Table[Nest[r#(1-#)&,x,n],{n,5}]],{x,0,1},PlotRange->All,PlotStyle->{Red,Yellow,Green,Blue,Purple},AxesLabel->TraditionalForm/@{(Subscript[x, 0]),(Subscript[x, n])},PlotLabel->TraditionalForm[HoldForm[r]==r],
DisplayFunction->Identity],
{r,4}],2]],ImageSize->500]

Bifurcation Diagrams

LogisticMap=Compile[{{μ,_Real}},({μ,#}&)/@Union[Drop[NestList[μ # (1-#)&,.2,300],100]]];

f=Table[LogisticMap[μ],{μ,0,4,.002}];//Timing

ListPlot[Flatten[f,1],
PlotStyle->{Red,AbsolutePointSize[.001]},Frame->True,
FrameLabel->TraditionalForm/@{r,x},PlotLabel->TraditionalForm[(Subscript[x, n])==r (Subscript[x, n-1])(1-(Subscript[x, n-1]))]
]

f=Table[LogisticMap[μ],{μ,1.0,4.0,.002}];//Timing

ListPlot[Flatten[f,1],
PlotStyle->{Red,AbsolutePointSize[.001]},Frame->True,
FrameLabel->TraditionalForm/@{r,x},PlotLabel->TraditionalForm[(Subscript[x, n])==r (Subscript[x, n-1])(1-(Subscript[x, n-1]))]
]

f=Table[LogisticMap[μ],{μ,3.44,3.58,.00005}];//Timing

ListPlot[Flatten[f,1],
PlotStyle->{Red,AbsolutePointSize[.001]},Frame->True,
FrameLabel->TraditionalForm/@{r,x},
Axes->False,PlotLabel->TraditionalForm[(Subscript[x, n])==r (Subscript[x, n-1])(1-(Subscript[x, n-1]))],
Prolog->{{Blue,Line[{{#,0},{#,1}}]&/@{3.44949,3.544090,3.564407,3.56875,3.56969,3.56989,3.569934,3.569943,3.5699451,3.569945557,3.569945672}}}
]

Solvable Cases

r=-2

With[{r=-2},
RSolve[{x[k+1]==r x[k](1-x[k]),x[0]==x0},x[k],k]
]

r=2

With[{r=2},
RSolve[{x[k+1]==r x[k](1-x[k]),x[0]==x0},x[k],k]
]

r=4

With[{r=4},
RSolve[{x[k+1]==r x[k](1-x[k]),x[0]==x0},x[k],k]
]

Periods

Period 1

LogisticPeriod[1]

Period 2

LogisticPeriod[2]

Period 3

CycleOnset[3]//Timing

N[1+2Sqrt[2],20]

NCycleOnset[3,WorkingPrecision->20]

Table[Print[NCycleMinimize[3,WorkingPrecision->20,Method->{"SimulatedAnnealing","RandomSeed"->i}]//Timing];,{i,0,2}]

p3=Collect[Factor[(Nest[f,x,3]-x)/(f[x]-x)],x]

d3=Factor[Discriminant[p3,x]]

{#,N[#]}&/@Union[Select[r/.{ToRules[Roots[Numerator[d3]==0,r]]},Im[#]==0&&Positive[#]&]]

Select[RootReduce[LogisticPeriod[3]],Im[#[[-1,-1]]]==0&&#[[-1,-1]]>0&]//Timing

Roots[-7+70 x-161 (x^2)-134 (x^3)+868 (x^4)-980 (x^5)+343 (x^6)==0,x]//N

Relation to the silver constant

Sort[RootReduce[FunctionExpand[Table[(Sqrt[2])-(1/7)(1-2(Sqrt[2]))(2+2Cos[2i π/7]-5),{i,3}]]],#1<#2&]

Roots[r^2-2r-7==0,r]

Upper bound for the r-values supporting stable period-3 orbits

s1=Select[Last/@List@@Roots[s^3-11s^2+37s-108==0,s,Cubics->False],Positive][[1]]

RootReduce[1+Sqrt[s1]]

RootReduce[Select[Last/@List@@Roots[-81-36 x-14 (x^2)+24 (x^3)+4 (x^4)-6 (x^5)+(x^6)==0,x,Cubics->False],Positive][[1]]]

Period 4

Using Eliminate

Eliminate[#==0&/@{x2-r x1(1-x1),x3-r x2(1-x2),x4-r x3(1-x3),x1-r x4(1-x4),r^4(1-2x1)(1-2x2)(1-2x3)(1-2x4)+1},{x1,x2,x3,x4}]//Timing

Using Gröbner Basis

Factor/@GroebnerBasis[{x2-r x1(1-x1),x3-r x2(1-x2),x4-r x3(1-x3),x1-r x4(1-x4),r^4(1-2x1)(1-2x2)(1-2x3)(1-2x4)+1},r,{x1,x2,x3,x4},MonomialOrder->EliminationOrder]//Timing

CycleOnset[4]//Timing

CycleOnset[4,Method->"GroebnerWalk"]//Timing

N[1+Sqrt[6],30]

(p4=CycleOnsetGroebner[4][[1]]//Factor)//Timing

Roots[#==0,r]&/@First/@FactorList[p4]

Select[#,Positive]&/@(r/.{ToRules[Roots[#==0,r]]}&/@First/@Rest[FactorList[p4]])

N[%]

NMinimize

NCycleMinimize[4,WorkingPrecision->50,Method->{"SimulatedAnnealing","RandomSeed"->0}]//Timing

Using FindRoot

f[x_]:=r x(1-x)

g=(Nest[f,x,4]-x)/(Nest[f,x,2]-x);

gN[r_?NumericQ,x_]=g;
dG[r_?NumericQ,x_,ε_]:=(gN[r,x+ε/2]-gN[r,x-ε/2])/ε

FindRoot[{gN[r,x]==0,dG[r,x,10^-12]==0},{r,3.4,3.5},{x,0.2,0.5},WorkingPrecision->30,Method->Secant,PrecisionGoal->12,MaxIterations->500]

r/.FindRoot[{gN[r,x]==0,dG[r,x,10^-120]==0},{r,3.4,3.5},{x,0.4,0.5},WorkingPrecision->200,Method->Secant,PrecisionGoal->100,MaxIterations->2000]

N[1+Sqrt[6],100]

<<Simplify`

ToExact[N[%58,80]]

Numerically

<<Simplify`

r4=NCycleOnset[4,WorkingPrecision->20]

ToExact[r4[[1]]]

Using the discriminant

p4=Collect[Factor[(Nest[f,x,4]-x)/(Nest[f,x,2]-x)],x]

d4=Factor[Discriminant[p4,x]]

Reduce[Numerator[d4]==0&&r>0,r]

N[%,20]

Period 5

r5=ExactConstant["logistic map 5-bifurcation"]

AlgebraicDegree[r5]

N[x/.{ToRules[Reduce[First[r5][x]==0&&x>0,x]]},7]

NMinimize

Timing[r5=NCycleMinimize[5,WorkingPrecision->100,Method->{"SimulatedAnnealing","RandomSeed"->0}]]

Timing[r5=NCycleMinimize[5,WorkingPrecision->200,Method->{"SimulatedAnnealing","RandomSeed"->0},MaxIterations->200]]

ToExact[3.7381723752659623694302615596795319734441154404899,MaxOrder->22]

Gröbner Basis

CycleOnset[5]//Timing

RootReduce[CycleOnset[5,Method->"GroebnerWalk"]]//Timing

N[Last[%]]

Discriminant

p5=Collect[Factor[(Nest[f,x,5]-x)/(f[x]-x)],x];

d5=Factor[Discriminant[p5,x]]

Reduce[(-28629151-31399714 r-14329471 (r^2)+3613360 (r^3)+13369804 (r^4)+5836984 (r^5)-1495060 (r^6)-4002880 (r^7)-1613676 (r^8)+1484268 (r^9)+808298 (r^10)-234632 (r^11)-294146 (r^12)+8008 (r^13)+103556 (r^14)-17344 (r^15)-18092 (r^16)+7488 (r^17)+116 (r^18)-700 (r^19)+189 (r^20)-22 (r^21)+(r^22))==0&&r>0,r]

N[%,20]

Period 6

r6=ExactConstant["logistic map 6-bifurcation"]

AlgebraicDegree[r6]

N[x/.{ToRules[Reduce[First[r6][x]==0&&x>0,x]]},7]

N[r6,100]

Period 7

r7=ExactConstant["logistic map 7-bifurcation"]

AlgebraicDegree[r7]

N[x/.{ToRules[Reduce[First[r7][x]==0&&x>0,x]]},7]

N[r7,100]

First Step

With[{a=Array[x,7]},
GroebnerBasis[
Append[r #1(1-#1)-#2&@@@Partition[a,2,1,1],
r^n Times@@((1-2#)&/@a)-1],
Append[a,r],MonomialOrder->DegreeLexicographic,Sort->True]
];//Timing

Period 8

r8=ExactConstant["logistic map 8-bifurcation"]

N[%,100]

AlgebraicDegree[r8]

GroebnerWalk

CycleOnset[8,Method->"GroebnerWalk"]//Timing

1.2 GB after 1 hr; 3 GB after 200 minutes

Groebner Basis

(p8=CycleOnsetGroebner[8][[1]]//Factor)//Timing

Numerically

NCycleOnset[8]//Timing

FindRoot

With[{n=8},
a=Array[x,n];
FindRoot[Append[r #1(1-#1)==#2&@@@Partition[a,2,1,1],
r^n Times@@( (1-2#)&/@a)==1],{r,3.544090,3.544089,3.544091},Evaluate[Sequence@@({#,.3}&/@a)]]
]

f[x_]:=r x(1-x)

g=(Nest[f,x,8]-x)/(Nest[f,x,4]-x);

gN[r_?NumericQ,x_]=g;
dG[r_?NumericQ,x_,ε_]:=(gN[r,x+ε/2]-gN[r,x-ε/2])/ε

FindRoot[{gN[r,x]==0,dG[r,x,10^-30]==0},{r,3.5,3.6},{x,0.3,0.9},WorkingPrecision->100,Method->Secant,PrecisionGoal->20,MaxIterations->100,
DampingFactor->5]

NMinimize

Timing[r8=NCycleMinimize[8,WorkingPrecision->100,Method->{"SimulatedAnnealing","RandomSeed"->0}]]

Timing[r8=NCycleMinimize[8,WorkingPrecision->100,Method->{"SimulatedAnnealing","RandomSeed"->1}]]

Timing[r8=NCycleMinimize[8,WorkingPrecision->100,Method->{"SimulatedAnnealing","RandomSeed"->2}]]

Discriminant

p8=(Nest[f,x,8]-x)/(Nest[f,x,4]-x);

Expand//@p8

d8=Discriminant[Together[p8],x]

Period 16

Exact Value

r16=ExactConstant["logistic map 16-bifurcation"];

N[r16,20]

(Subscript[r, 16])((Subscript[r, 16])-2)

N[{r16(r16-2),ExactConstant["logistic map r16(r16-2)"]},20]

Developer`ZeroQ[zero=r16(r16-2)-ExactConstant["logistic map r16(r16-2)"]]//Timing

Simplify[zero]//Timing

RootReduce[zero]//Timing

Table

Do[
Print[{
n,
r=RootReduce[CycleOnset[n,Method->"GroebnerWalk"]]//Timing;
AlgebraicDegree[Last[r]],
N[Last[r],10],
r
}],{n,15}]

Do[
Print[{
n,
r=RootReduce[CycleOnset[n,Method->"GroebnerWalk"]]//Timing;
AlgebraicDegree[Last[r]],
N[Last[r],10],
r
}],{n,8,8}]

...7.1 GB after 27 hr...

...out of memory?...

Do[
Print[{
n,
r=RootReduce[CycleOnset[n,Method->"GroebnerWalk"]]//Timing;
AlgebraicDegree[Last[r]],
N[Last[r],10],
r
}],{n,9,9}]

...out of memory?

Do[
Print[{
n,
r=RootReduce[CycleOnset[n,Method->"GroebnerWalk"]]//Timing;
AlgebraicDegree[Last[r]],
N[Last[r],10],
r
}],{n,10,10}]

...~1GB...

Misc. Computations

failed conjecture: x=(1/2) (1-f((2^n)(f^(-1))(1-2(Subscript[x, 0]))))

new conjecture: x=(1/2) (1-f((a^n)(f^(-1))(1-2(Subscript[x, 0]))))

This conjecture is correct for a≠1!

Known cases:

x -> a x (1-x)

a==2:       (Subscript[x, n])=(1/2) (1-exp((2^n) log(1-2 (Subscript[x, 0]))))
a==4:        (Subscript[x, n])=(1/2) (1-cos((2^n) (cos^(-1))(1-2 (Subscript[x, 0]))))

From a  p(Subscript[F, q]) point of view we have:
a=2:   0(Subscript[F, 0])(;;z)
a=4:  (Subscript[, 0])(Subscript[F, 1])(;(1/2);(z/2))

For generic a the series is "strange" (not hypergeometric, but also not Dirichlet, rather "cyclotomic"):

l=CoefficientList[makeSeries[a, x, 10],x]

The terms 1, 1, 1, 1, 5, 7, 21, 33, … are A002596, the coefficients in the series expansion of Sqrt[1+x]

FullSimplify[21+14 a+14 (a^2)+8 (a^3)+3 (a^4)]

FullSimplify[33+30 a+37 (a^2)+32 (a^3)+27 (a^4)+12 (a^5)+8 (a^6)+(a^7)]

Exponent[Numerator[CoefficientList[makeSeries[a,x,20],x]],a]

Timing[ns=Exponent[Numerator[CoefficientList[makeSeries[a,x,25],x]],a]]

Subtract@@@Partition[ns,2,1]

Subtract@@@Partition[%,2,1]

Not in EIS

ToCyclotomic[eqn_,x_]:=Module[{n=1},
If[FreeQ[eqn,x],Return[eqn]];
While[Expand[Cyclotomic[n,x]-eqn]=!=0,n++];
Phi[n,x]
]

ConvertToCyclotomic[l_,a_]:=Module[{t=Transpose[FactorList[l]]},
Times@@((ToCyclotomic[#,a]&/@t[[1]])^t[[2]])
]

ConvertToCyclotomic[#,a]&/@Denominator[CoefficientList[makeSeries[a,x,15],x]]//ColumnForm

Flatten[Transpose[Table[{1,2,8,16,128,256,1024,2048},{2}]]]

IntegerExponent[#,2]&/@Flatten[Transpose[Table[{1,2,8,16,128,256,1024,2048},{2}]]]

which is Sloane's A011371, equal to n-DigitCount[n,2,1]

test[n_,a_]:=2^(n-DigitCount[n,2,1])Times@@Table[Phi[k,a]^Floor[(n-1)/k],{k,n-1}]

Product[Cyclotomic[k,a]^Floor[(n-1)/k],{k,n-1}]

Product[Phi[k,a]^Floor[(n-1)/k],{k,n-1}]

Table[test[n],{n,0,15}]//ColumnForm

{Table[n-DigitCount[n,2,1],{n,20}],Table[n-Count[IntegerDigits[n,2],1],{n,20}]}

With[{n=20},
Table[test[k,a],{k,0,n}]/.Phi:>Cyclotomic-Denominator[CoefficientList[makeSeries[a,x,n+1],x]]
]

First let's write the a=4 case in this way (this is not a trivial rewrite!):

a==4:        f=cosh((Sqrt[2x]))
                   (f^(-1))=(1/2) (((cosh^(-1))(x))^2)

For a generic a the following function will calculate the correct series expansion of f (I can't prove this, but numerical experiments confirm this). d is the number of terms of the series wanted.

makeSeries[a_?(# =!= 1&), x_, d_] :=
Module[{α, f, eq, sum, ser, sc, sol},
 eq = 2 - 2 f[a x] + a (f[x]^2 - 1);
 Do[sum = 1 + x + Sum[α[k] x^k, {k, 2, o}];
    ser = eq /. {f[x] -> sum + O[x]^(o + 1), f[a x] -> (sum /. x ->  a x)};
    sc = SeriesCoefficient[ser, o];
    sol = Solve[sc == 0, α[o]];
    α[o] = Factor[Together[α[o] /. sol[[1]]]], {o, 2, d + 1}];
 sum + O[x]^d]

CheckPFQ[n_,{p_,q_},x_]:=Module[{a,h,z,soln,m},
h=HypergeometricPFQ[Array[a,p],Array[a,q],z a[p+q+1]];
l=CoefficientList[m=makeSeries[n,z,p+q+2],z] /.z->1;
soln=h/.Solve[l==CoefficientList[FullSimplify@Series[h,{z,0,p+q+1}],z],
Array[a,p+q+1]
] /. z->x;
Print[{p,q,soln}];
FullSimplify@(Normal[#-makeSeries[n,x,p+q+3]]===0)&/@Series[soln,{x,0,p+q+2}]
]

Michael's proof of nonexistence for general a

x -> a x (1-x)

known cases:
a==4:        (Subscript[x, n])=(1/2) (1-cos((2^n) (cos^(-1))(1-2 (Subscript[x, 0]))))

a==2:       (Subscript[x, n])=(1/2) (1-(e^((2^n) log(1-2 (Subscript[x, 0])))))

conjecture:

x=(1/2) (1-f((2^n)(f^(-1))(1-2(Subscript[x, 0]))))

Then we have the following

(Subscript[x, 1])=a (Subscript[x, 0])(1-(Subscript[x, 0]))  (by definition)
     =-(a/4)((((1-2(Subscript[x, 0])))^2)-1) (just rewritten)
      =-(a/4)(((f((f^(-1))((1-2(Subscript[x, 0])))))^2)-1)  (insert identity f (f^(-1)))
      =(1/2)(1-f(2(f^(-1))(1-2(Subscript[x, 0]))))   (by conjectured identity)

This means, if f exists, it must fulfill the following polynomial duplication formula:
 2-2f(2x)==-a(((f(x))^2)-1).

Because only elliptic function fulfill polynomial duplication formulas, f, if it exists, must be an elliptic function.
As such it must be sufficiently smooth, and must have a convergent Taylor expansion:

f(x)=(∑_(k=0)^∞)(Subscript[α, k])(a)(x^k)

Let's try to calculate some terms of this series.

identity = 2 - 2 f[2 x] + a (f[x]^2 - 1);

o = 8;
sum = Sum[α[k] x^k, {k, 0, o}];
identitySeries = 
   identity  /. {f[ x] -> sum + O[x]^(o + 1),
                 f[2x] -> (sum /. x -> 2x)}

The constant term must vanish:

Coefficient[identitySeries, x, 0] // Simplify

Solve[Coefficient[identitySeries, x, 0] == 0, α[0]]

Let's follow the possibility (Subscript[α, 0])==1.

identitySeries1 = identitySeries /. α[0] -> 1;

Now the series term ∼ (x^1). Here the special case a=2 arises. For generic a, (Subscript[α, 1]) has to vanish.

Coefficient[identitySeries1, x, 1] // Factor

Now the series term ∼ (x^2). Here the special case a=4 arises. For generic a, (Subscript[α, 2]) has to vanish.

Coefficient[identitySeries1 /. α[1] -> 0, x, 2] // Factor

Now the series term ∼ (x^2). Here the special case a=8 arises (this means there probably exists a closed form for this case). For generic a, (Subscript[α, 3]) has to vanish.

Coefficient[identitySeries1 /. α[1] -> 0 /. α[2] -> 0, x, 3] // Factor

Being a bit more careful, messing around with symbolic expressions for the nth series term by induction follows that for generic a all series terms of f(x) vanish. This is in contradiction to the known smoothness of an elliptic function.

Let's follow the possibility (Subscript[α, 0])==(2-a)/a.

identitySeries2 = identitySeries /. α[0] -> (2 - a)/a;

Now the series term ∼ (x^1). Here the special case a=0 (trivial) arises. For generic a, (Subscript[α, 1]) has to vanish.

Coefficient[identitySeries2, x, 1] // Factor

Now the series term ∼ (x^2). Here the special case a=-2 arises. For generic a, (Subscript[α, 2]) has to vanish.

Coefficient[identitySeries2 /. α[1] -> 0, x, 2] // Factor

And so on as in case one.

⟹ No smooth f exists that represents a closed form solution of the logistic map iteration for generic a.

This leaves open a nonsmooth f (Cantor like). It might exist, but surely can't be expressed in any named special function.

Generlized Hyperbolic

GeneralizedHyperbolicF[a_,{n_,r_},0]:=1;
GeneralizedHyperbolicF[a_,{n_,r_},x_]:=Sum[a^k/(n k+r)!x^(n k+r),{k,0,Infinity}]

FullSimplify[Table[GeneralizedHyperbolicF[α,{n,0},x^(1/n)],{n,4}]]

FullSimplify[Table[GeneralizedHyperbolicF[α,{n,b},x^(1/n)],{n,4}]]

FullSimplify[Table[GeneralizedHyperbolicF[α,{n,-1},x^(1/n)],{n,5}]]

FullSimplify[Table[GeneralizedHyperbolicF[α,{n,0},x^(1/n)],{n,5}]]

FullSimplify[Table[GeneralizedHyperbolicF[α,{n,1},x^(1/n)],{n,5}]]

FullSimplify[Table[GeneralizedHyperbolicF[α,{n,2},x^(1/n)],{n,5}]]

Limit[(((E^(x α)) (x^b) (((x α))^(-b)) (Gamma[b]-Gamma[b,x α]))/(Gamma[b])),b->0]

{Limit[#,b->0],#/.b->0}&[(((x^(b/2)) HypergeometricPFQ[{1},{(1/2)+(b/2),1+(b/2)},((x α)/4)])/(Gamma[1+b]))]

(((x^(b/3)) HypergeometricPFQ[{1},{(1/3)+(b/3),(2/3)+(b/3),1+(b/3)},((x α)/27)])/(Gamma[1+b]))/.b->0

Series[%39,{x,0,4}] /. α->6

makeSeries[8,x,10]

a=-4

makeSeries[-4,x,10]

coefs=CoefficientList[makeSeries[-4,x,30],x];

Take[Denominator[coefs],10]

Table[(5n)!,{n,6}]

FactorInteger[Denominator[d]]

ds=Denominator[d];

Number of zeros in denominators seems to be A011371 (n minus the number of 1s in the binary expansion of n)

Function[f,Position[Reverse[IntegerDigits[f]],_?(#≠0&),{0,∞},1][[1,1]]-1]/@ds

Table[n!!!,{n,5}]

1/Divide@@@Partition[Denominator[d],2,1]

a=-8

makeSeries[-8,x,10]

a=-4

makeSeries[-4,x,10]

a=-3

makeSeries[-3,x,10]

a=-1

makeSeries[-1,x,2]

a=3

series=makeSeries[3, x, 10]

1/CoefficientList[series,x]//N

Sqrt[makeSeries[3,x,10]]

(makeSeries[3,x,10])^(1/3)

makeSeries[3,x,10]^2

makeSeries[3,x,10]^3

cl=CoefficientList[makeSeries[3,x,15],x];

1/Divide@@@Partition[Denominator[cl],2,1]

Numerator[cl]

Divide@@@Partition[Numerator[cl],2,1]

a=5

makeSeries[5, x, 10]

a=6

makeSeries[6, x, 10]

a=8

makeSeries[8,x,10]

The series expansion around x==Infinity looks better (according to Michael)

y==2/8 Exp[(3 x)^(1/3)]

series=-(3864345/(4294967296*y^15))+51705/(33554432*y^13)-45765/(16777216*y^11)+2655/(524288*y^9)-165/(16384*y^7)+45/(2048*y^5)-15/(256*y^3)+3/(8*y)+y

1/First/@Partition[Rest[CoefficientList[%8/.y->1/x,x]],2]//N

denom=Flatten[First/@Partition[IntegerExponent[#,2]&/@Denominator[Join[Rest[CoefficientList[series/.y->1/x,x]],{0}]],2]]

2^%

-Subtract@@@Partition[pow,2,1]

numer=Flatten[First/@Partition[Numerator[Join[Rest[CoefficientList[series/.y->1/x,x]],{0}]],2]]

1/Divide@@@Partition[numer,2,1]

a=16

makeSeries[16,x,10]

Series[HypergeometricPFQ[{},{1/4,2/4,3/4},x/4^4 24],{x,0,10}]

Misc.

Now the question is: what is the function for generic a.
From a  p(Subscript[F, q]) point of view we have:
a=2:   0(Subscript[F, 0])(;;z)
a=4:  (Subscript[, 0])(Subscript[F, 1])(;(1/2);(z/2))

Here is were I got currently stuck. I tried a variety of generalizattions of  p(Subscript[F, q])s. None work. Also FoxH-MittagLeffler generalizations seem not to cover the a=3,6,...case.
The (Subscript[α, k])(x^k) in the series is for  a=3,6,... not hypergeometric or even fractional hypergeometric form.
I also calculate the zeries value at x=1 to many digits, but the inverse calculators can't find it.

I also tried to recognize the inverse series-without success.

Any idea what it could be?