Get["~/doc/research/first_order_singularities/mma/schofield.wl"]

Definitions

h1=h[0];
F1=RF[2];
eq1=eq[F1,h1][1];

θc1=1.2;

sol1=FindRoot[eq1/.θc->θc1,{{A,RandomReal[{0,3}]},{gC[0],RandomReal[]},{FC[0],RandomReal[]},{FC[1],RandomReal[]},{FC[2],RandomReal[]}},MaxIterations->500]

Plot[Evaluate[RF[2][θ]/.B->ruleB[g1]/.sol1/.θc->θc1],{θ,-θc1,θc1}]

h2=h[3];
F2=RF[2];
eq2=eq[F2,h2][2];

sol2=FindRoot[eq2/.θc->θc1,{{A,A/.sol1},{gC[0],gC[0]/.sol1},{FC[0],FC[0]/.sol1},{FC[1],FC[1]/.sol1},{FC[2],FC[2]/.sol1},{gC[1],0},{gC[2],0},{gC[3],RandomReal[]}},MaxIterations->10000]

GraphicsRow[{
Plot[h2[θ]/.sol2/.θc->θc1,{θ,-θc1,θc1}],
Plot[F2[θ]/.B->ruleB[h2]/.sol2/.θc->θc1,{θ,-θc1,θc1}]
}]

ParametricPlot[Evaluate[(R|->{R t[θ],(R^(Δ[2]))h2[θ]})/@{0.25,0.375,0.5,0.75,1}/.sol2/.θc->θc1],{θ,-θc1,θc1}]

ListPlot[Table[{t[θ]((h2[θ])^(-1/Δ[2])),((h2[θ])^(-2/Δ[2]))(F2[θ]-(((t[θ])^2)/(8π))Log[((t[θ])^2)])}/.B->ruleB[h2]/.sol2/.θc->θc1,{θ,0.0001,θc1-0.0001,0.0001}],Joined->True,PlotRange->{{-20,20},{-2,0}}]

ListPlot[Table[{h2[θ]((t[θ])^(-Δ[2])),-(Transpose[Inverse[D[{R t[θp],(R^(Δ[2]))h2[θp]},{{R,θp}}]/.θp->θ]].(D[(R^2)(F2[θp]+((t[θp])^2)Log[(R^2)]/(8π)),{{R,θp}}]/.θp->θ))[[2]]/(((R t[θ]))^(1/8))}/.B->ruleB[h2]/.sol2/.θc->θc1/.R->1,{θ,1+0.001,θc1-0.001,0.001}],Joined->True]

ListPlot[Table[{h2[θ]((t[θ])^(-Δ[2])),-(Transpose[Inverse[D[{R t[θp],(R^(Δ[2]))h2[θp]},{{R,θp}}]]].D[(Transpose[Inverse[D[{R t[θp],(R^(Δ[2]))h2[θp]},{{R,θp}}]]].D[(R^2)(F2[θp]+((t[θp])^2)Log[(R^2)]/(8π)),{{R,θp}}])[[2]],{{R,θp}}])[[2]](((R t[θp]))^(7/4))}/.θp->θ/.B->ruleB[h2]/.sol2/.θc->θc1/.R->1,{θ,1+0.001,θc1-0.001,0.001}],Joined->True]

g3=g[4];
F3=RF[2];
eq3=eq[F3,g3][3];

sol3=FindRoot[eq3,{{A,A/.sol2},{gC[0],gC[0]/.sol2},{FC[0],FC[0]/.sol2},{FC[1],FC[1]/.sol2},{FC[2],FC[2]/.sol2},{gC[1],gC[1]/.sol2},{gC[2],gC[2]/.sol2},{θc,θc/.sol2},{gC[3],0},{gC[4],0}},MaxIterations->500]

GraphicsRow[{
Plot[g2[θ]/.sol2/.θc->θc1,{θ,0,θc1}],
Plot[F2[θ]/.B->ruleB[g2]/.sol2/.θc->θc1,{θ,0,θc1}]
}]

g3=g[gC,θc][5];
eq3=eq[2][f,g3][2];

θc3=1.1;

sol3=FindRoot[eq3/.θc->θc3,{{M0,M0/.i3},{gC[0],gC[0]/.i3},{gC[1],gC[1]/.i3},{gC[2],gC[2]/.i3},{gC[3],gC[3]/.i3},{gC[4],gC[4]/.i3},{gC[5],gC[5]/.i3}},MaxIterations->500]

GraphicsRow[{
Plot[g3[θ]/.sol3/.θc->θc3,{θ,0,θc3}],
Plot[Rℳ[2][B,θc3,M0][θ]/.B->ruleB[2][f,g3]/.sol3/.θc->θc3,{θ,0,θc3}]
}]

test1=Integrate[((g1''[θ])/(((1+((g1'[θ])^2)))^(3/2))),θ]

test2=Integrate[g2[θ],{θ,0,θc}]

D[((test1/.θ->θc)-(test1/.θ->0))/θc,θc]//Simplify

eq2={eqLow[2][f,g[gC,θc][0]][0],eqHigh[2][f,g[gC,θc][0]][1]}/.rules[f,g[gC,θc][0]];

sol2=FindRoot[eq2/.{θc->1.3},{{M0,M0/.sol1},{gC[0],1}},MaxIterations->5000]

eq3={eqLow[2][f,g[gC,θc][2]][0],eqHigh[2][f,g[gC,θc][2]][1],eqMid[2][f,g[gC,θc][2]][0],eqLow[2][f,g[gC,θc][2]][1]}/.rules[f,g[gC,θc][2]];

eqMid[2][f,g[gC,θc][0]][0]

sol3=FindRoot[eq3/.θc->1.3,{{M0,M0/.sol2},{gC[0],gC[0]/.sol2},{gC[1],0},{gC[2],0}},MaxIterations->5000]

GraphicsRow[{
Plot[g[gC,θc][1][θ]/.sol3/.θc->1.1,{θ,0,1.2}],
Plot[Rℳ[2][B,θc,M0][θ]/.B->ruleB[2][f,g[gC,θc][1]]/.sol3/.θc->1.1,{θ,0,1.2}]
}]

Series[

eqLow[2][f,g[gC,θc][0]][1]

GlRules

θi=1;

n1=2;
eq1={eqLow[n1][0],eqMid[n1][0],eqHigh[n1][1],eqLow[n1][1],eqHigh[n1][2]}//.Join[ℱsol[[1]],ΦRules,GlRules,GhRules,DmetaRules,{gC[0]->1,B->eqB[n1]}];

s1=FindRoot[eq1,{{θc,1+RandomReal[]},{ℳ0,RandomReal[]},{ℳ1,RandomReal[]},{gC[1],RandomReal[]},{gC[2],RandomReal[]}},MaxIterations->1000]

s11=#[[1]]->Re[#[[2]]]&/@s1;

B//.{B->eqB[n1]}/.s1/.gC[0]->1

GraphicsRow[{
Plot[Evaluate[Rℳ[θ]//.{B->eqB[n1]}/.s1/.gC[0]->1],{θ,-1.5,1.5}],
Plot[Evaluate[g[n1][θ]/.{B->eqB[n1]}/.s1/.gC[0]->1],{θ,-2,2}]
}]

{g[n1][θ]((f[n1][θ])^(-Δ)),((f[n1][θ])^(-β))Rℳ[θ]}/.B->eqB[n1]/.s1/.gC[0]->1/.θ->1.04

Show[ListPlot[Table[{g[n1][θ]((f[n1][θ])^(-Δ)),((f[n1][θ])^(-β))Rℳ[θ]}/.B->eqB[n1]/.s1/.gC[0]->1,{θ,1.3,1.4175,0.0001}]],
Plot[1.3578383417066+0.048953289720x/2,{x,0,5}]
]

n2=4;
eq2={eqLow[n2][0],eqMid[n2][0],eqHigh[n2][1],eqLow[n2][1],eqMid[n2][1],eqLow[n2][2],eqHigh[n2][2]}//.Join[ℱsol[[1]],ΦRules,GlRules,GhRules,DmetaRules,{θi->1,gC[0]->1,B->eqB[n2]}];

s2=#[[1]]->Re[#[[2]]]&/@FindRoot[eq2,{{θc,θc/.s1},{ℳ0,ℳ0/.s1},{ℳ1,ℳ1/.s1},{gC[1],gC[1]/.s1},{gC[2],gC[2]/.s1},{gC[3],0},{gC[4],RandomReal[]}},MaxIterations->10000]

GraphicsRow[{
Plot[Evaluate[Rℳ[θ]//.{θi->1,B->eqB[n2]}/.s2/.gC[0]->1],{θ,-1.3,1.3}],
Plot[Evaluate[g[n2][θ]/.{B->eqB[n2]}/.s2/.gC[0]->1/.t∞->100],{θ,-1.3,1.3}]
}]

ListPlot[Table[{g[n2][θ]((f[n2][θ])^(-Δ)),((f[n2][θ])^(-β))Rℳ[θ]}//.{θi->1,B->eqB[n2]}/.s2/.gC[0]->1,{θ,1,1.078,0.001}]]

n3=1;
eq3={eqLow[n3][1],eqMid[n3][0],eqHigh[n3][2],eqMid[n3][1],eqLow[n3][2]}//.Join[ℱsol[[1]],ΦRules,GlRules,GhRules,DmetaRules,{gC[0]->1,B->eqB[n3]}];

s3=FindRoot[eq3,{{θc,θc/.s2},{θi,θi/.s2},{δθ,δθ/.s2},{ℱ1,ℱ1/.s2},{gC[1],0.1RandomReal[]}},MaxIterations->4000]

GraphicsRow[{
Plot[Evaluate[Rℱ[θ]/.ℱsol[[1]]/.{B->eqB[n3]}/.s3/.gC[0]->1],{θ,-1.4,1.4}],
Plot[Evaluate[g[n3][θ]/.{B->eqB[n3]}/.s3/.gC[0]->1],{θ,-1.4,1.4}]
}]

GraphicsRow[{
Plot[Evaluate[Rℱ[θ]/.ℱsol[[1]]/.{B->eqB[n2]}/.s2/.gC[0]->1/.t∞->100],{θ,-1.4,1.4}],
Plot[Evaluate[g[n2][θ]/.{B->eqB[n2]}/.s2/.gC[0]->1/.t∞->100],{θ,-1.4,1.4}]
}]

Rℱ[θ]/.eqB[testN]/.ARule/.ss1/.gC[0]->1/.h0->1

ξ[0][θ]/.eqB[0]/.ARule/.ss1/.{gCoeff[0]->1,h0->1,t∞->1}

Plot[(((((Abs[1-(θ^2)])/(1+(θ^3)/t∞))))^(-β))/.t∞->1000,{θ,1,1.3}]

eqB[0]/.ARule/.ss1/.{gCoeff[0]->1,h0->1,t∞->1}

Plot[RM[θ]/.eqB[0]/.ARule/.ss1/.{gCoeff[0]->1,h0->1,t∞->1}/.m1->0,{θ,-2,2}]

ListLogPlot[Table[{θ,Sign[θc-θ]Abs@ξ[0][θ]}/.eqB[0]/.ARule/.ss1/.{gCoeff[0]->1,h0->1,t∞->1,m1->0},{θ,1.01,1.3,0.001}],PlotRange->All,Joined->True]

tastTab=Table[{Sign[θc-θ]Abs@ξ[0][θ],(((((Abs[1-(θ^2)])/(1+(θ^3)/t∞))))^(-β))RM[θ]}/.eqB[0]/.ARule/.ss1/.{gCoeff[0]->1,h0->1,t∞->1000000,m1->0},{θ,1.01,1.4462747730035337`,0.0001}];

ListLogLogPlot[tastTab,PlotRange->All,Joined->True]

testSol[[All,1]]/.ss1

D[(h^(16/15))ℱ[t (h^(-1/(β δ)))],h]

Series[Simplify[η[0][1/θinv]],{θinv,0,1}]

SeriesCoefficient[Simplify[η[0][1/θinv]],{θinv,0,1}]

eqMeta[3][3]

eqLow[2][1]

Simplify[SeriesCoefficient[G[ξ[0][θ]],{θ,θc,1}]]

Simplify[SeriesCoefficient[Φ[η[3][θ]],{θ,1,2}]]

params[n_]:=Join[{h0,t∞},gParams[n]]

Limit[((1-(((θ/θc))^2))/(1+gN/g∞  (θ^(2n+3))/((θc)^2)))gN (θ^(2n+1)),θ->∞]

Series[((1-(θ^2))/(1 +(θ^3)/t∞))/(((h0 g[θ]))^(1/βδ)),{θ,1,2}]

Series[M[((1-((θinv)^(-2)))/(1 +((θinv)^(-3))/t∞))/(((h0 ginv[θinv]))^(1/βδ))],{θinv,0,2}]

Plot[((1-(θ^2))/(1+0.1 (θ^3))),{θ,0,10}]

Integrate[(x(x-1)-Exp[1/x]ExpIntegralEi[-1/x])/(x^3),x]

R->2^Range[-2,2]

D[x Exp[-(((x))^(-1))]f[x],x]

Plot[x Exp[-(((x))^(-1))],{x,0,10}]

D[-(((E^(1/(x+I y))) ExpIntegralEi[-(1/(x+I y))])/(x+I y)),x]/.{y->0}//Simplify

D[(((x+I y))^(-1))Exp[-(((x+I y))^(-1))],y]/.y->0

Solve[ExpIntegralEi[x]==0,x]

Plot[ExpIntegralEi[x],{x,0,3}]

Plot[-(((θc-θ-1)(E^(1/(θc-θ))) ExpIntegralEi[-(1/(θc-θ))])/(θc-θ))/.{θc->1.3},{θ,-5,3}]

Plot[-(((E^(1/(θc-θ))) ExpIntegralEi[-(1/(θc-θ))])/(θc-θ))+(((E^(1/(θc+θ))) ExpIntegralEi[-(1/(θc+θ))])/(θc+θ))/.{θc->1.3},{θ,-5,5}]

LogPlot[Evaluate[Det[D[{R((1-(θ^2))/(1+2 (θ^3))),(R^(15/8))((1-(((θ/1.08))^2))/(1+1/20 (θ^3)/(1.08^2))) θ},{{R,θ},1}]]/.R->(2^(Range[-2,2]))],{θ,0,10}]

Evaluate[{R((1-(θ^2))/(1+0.5 (θ^3))),(R^(15/8))((1-(((θ/1.3))^2))/(1+1/0.4  (θ^3)/(1.3^2))) θ}/.R->2^Range[-2,2]]

Series[(1-(θ^2))/((((1-(((θ/1.3))^2)) θ))^(8/15)),{θ,∞,1}]

ParametricPlot[Evaluate[{#(1-(θ^2)),((#)^(15/8))(1-(((θ/1.3))^2)) θ}&/@(2^Range[-2,0,0.25])],{θ,0,1.8},PlotRange->All]

Series[(h0 g[θ])/(((((1-(θ^2))/(1+1/t∞ (θ^3)))))^(βδ)),{θ,0,2}]