Definitions

Rs[f_,α_,V0_][m_]:=((-m(1-(m^2)))/(2(((f[1]-(1-(m^2))f'[1]))^2)))(α (V0^2)f'[1]+(2-α)f[1](((f[1])/(1-(m^2)))-f'[1])-α (Sqrt[((4(V0^2))/α)f[1]f'[1](((f[1])/(1-(m^2)))-f'[1])+((((((f[1])^2)/(1-(m^2)))-((V0^2)+f[1])f'[1]))^2)]))
𝒮Ω[f_,α_,V0_][m_]:=-(α/2)(Log[1-((f[1])/(f'[1]))((1+m/Rs[f,α,V0][m])/(1-(m^2)))]+((V0^2)/(f[1]))(((1-((f'[1])/(f[1]))((1-(m^2))/(1+m/Rs[f,α,V0][m]))))^(-1)))+(1/2)Log[((-m)/(Rs[f,α,V0][m]))]

Von[f_,α_]:=(Sqrt[((1-α+(Sqrt[1-α]))/α)f[1]])
Vsh[f_,α_]:=(Sqrt[((2(1+(Sqrt[1-α]))-α)/α)f[1](1-((f[1])/(f'[1])))])
VSATs[f_,α_]:=(Sqrt[((f'[1])/α)-f[1]])
VSAT[f_,α_?NumericQ]:=V0/.FindRoot[𝒮Ω[f,α,V0][(10^(-15))],{V0,VSATs[f,α]}]

mMin[f_,α_,V0_]:=√((-(V0^2) (-2+α) f[1] (f[1]-2 f'[1]) f'[1]+(V0^4) α ((f'[1])^2)+2 (Sqrt[-(V0^4) (-1+α) ((f[1])^4) ((f'[1])^2)])+α ((f[1])^2) f'[1] (-f[1]+f'[1]))/(((V0^4) α+2 (V0^2) (-2+α) f[1]+α ((f[1])^2)) ((f'[1])^2)))

ms[f_,α_,V0_]:=((Sqrt[-(V0^2) α-α f[1]+f'[1]])/(Sqrt[f'[1]]))

mMax[f_,α_?NumericQ,V0_?NumericQ]:=m/.FindRoot[𝒮Ω[f,α,V0][m],{m,ms[f,α,V0]}]

𝒮𝒩[f_,α_,V0_,ϵ_][m_,mh_,Ap_,Am_,D_,R_]:=mh+(1/2)I ϵ Am-α (1/2)Log[((f'[1](D f[1]+(R^2)f'[1])-(1/2)((((R-(1/2)Ap))^2)+(1/2)(Am^2))f[1]f''[1])/((1/4)(((R+(1/2)Ap))^2)((f'[1])^2)))]-α (1/2)Log[(((ϵ^2)+I ϵ f'[1] Am+(1/4)((Ap^2)-(Am^2))((f'[1])^2))/((1/4)(((R+(1/2)Ap))^2)((f'[1])^2)))]+(1/2)Log[((D(1-(m^2))+(R^2)-2R m mh+(mh^2))/((1/4)(((R+(1/2)Ap))^2)))]+(1/2)Log[(((Ap^2)-(Am^2))/(((R+(1/2)Ap))^2))]-(1/2)α (V0^2)(((f[1]+(((R^2)((f'[1])^2))/(D f'[1]-(1/2)((((R-(1/2)Ap))^2)+(1/2)(Am^2))f''[1]))))^(-1))

f3=Function[q,(1/2)(q^3)];

Plots

Action examples

actionPlot1=Plot[Evaluate[Function[V0,𝒮Ω[Function[q,q],1/2,V0][m]]/@Range[0,4/3,1/3]],{m,-1,1},Frame->True,FrameStyle->Black,FrameLabel->{m,(Subscript[𝒮, χ])[m]},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},Epilog->{Inset[LineLegend[ColorData[97]/@Range[5],NumberForm[#,{∞,3}]&/@N[Range[0,4/3,1/3]],LegendLayout->{"Column",1},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},LegendFunction->Panel,LegendLabel->(Subscript[V, 0])],Scaled[{0.2,0.32}]],Text[Style["f(q) = q",FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Scaled[{0.85,0.91}]]},ImageSize->590/2+22,AspectRatio->9/10,PlotRange->{{-0.025,1.025},{-0.249,0.049}},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}]}]

es={0,2(Sqrt[(1/2)+(1/(Sqrt[2]))])/3,(Sqrt[(1/2)+(1/(Sqrt[2]))]),1.25`,1.3250000000000002`,1.375,(Sqrt[1+((2 (Sqrt[2]))/3)]),1.42,1.44042348655380148084529792564829760627`20.,1.46};
actionPlot3=Plot[Evaluate[Function[V0,𝒮Ω[Function[q,(1/2)(q^3)],1/2,V0][m]]/@es],{m,-0.2,1},Frame->True,FrameStyle->Black,FrameLabel->{m,Style[(Subscript[𝒮, χ])[m],FontOpacity->0]},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}]},PlotRange->{{-0.025,1.025},{-0.249,0.049}},Epilog->{Inset[LineLegend[ColorData[97]/@Range[10],NumberForm[#,{∞,3}]&/@N[es],LegendLabel->(Subscript[V, 0]),LegendLayout->{"Column",2},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},LegendFunction->Panel],Scaled[{0.32,0.32}]],Text[Style["f(q) = (1/2)(q^3)",FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Scaled[{0.83,0.91}]]},ImageSize->590/2+22,AspectRatio->9/10,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

SetDirectory[NotebookDirectory[]];
Export["figs/action_1.pdf",actionPlot1];
Export["figs/action_3.pdf",actionPlot3];

Action in different regimes

es=0.5;
regimePlot1=Plot[𝒮Ω[f3,es,1/2][m],{m,-0.2,1},Frame->True,FrameStyle->Black,FrameLabel->{m,(Subscript[𝒮, χ])[m]},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}],{Dashed,Line[{{mMin[f3,1/2,es],-0.175},{mMin[f3,1/2,es],𝒮Ω[f3,1/2,es][mMin[f3,1/2,es]]}}]},{Dashed,Line[{{ms[f3,1/2,es],-0.135},{ms[f3,1/2,es],0}}]},Text[Style[(Subscript[m, min]),FontFamily->"BitstreamCharter",FontSize->12,Black],{0.025+mMin[f3,1/2,es],-0.185}],Text[Style[(SuperStar[m]),FontFamily->"BitstreamCharter",FontSize->12,Black],{0.015+ms[f3,1/2,es],-0.145}]},PlotRange->{{-0.05,1.05},{-0.249,0.049}},Epilog->{Text[Style[(Subscript[V, 0])==0.5,FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Scaled[{0.92,0.97}],ImageScaled[{1,1}]],Text[Style["Connected",FontFamily->"BitstreamCharter",FontSize->12,Black,Bold],Scaled[{0.07,0.02}],ImageScaled[{0,0}]]},ImageSize->590/4+30,AspectRatio->12/10]

es=1.37;
regimePlot2=Plot[𝒮Ω[f3,1/2,es][m],{m,-0.2,1},Frame->True,FrameStyle->Black,FrameLabel->{m,Style[(Subscript[𝒮, χ])[m],FontOpacity->0]},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}],{Dashed,Line[{{mMin[f3,1/2,es],-0.175},{mMin[f3,1/2,es],𝒮Ω[f3,1/2,es][mMin[f3,1/2,es]]}}]},{Dashed,Line[{{mMax[f3,1/2,es],-0.135},{mMax[f3,1/2,es],0}}]},Text[Style[(Subscript[m, min]),FontFamily->"BitstreamCharter",FontSize->12,Black],{0.07+mMin[f3,1/2,es],-0.185}],Text[Style[(Subscript[m, max]),FontFamily->"BitstreamCharter",FontSize->12,Black],{0.07+mMax[f3,1/2,es],-0.145}]},PlotRange->{{-0.05,1.05},{-0.249,0.049}},Epilog->{Text[Style[(Subscript[V, 0])==1.37,FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Scaled[{0.92,0.97}],ImageScaled[{1,1}]],Text[Style["Onset",FontFamily->"BitstreamCharter",FontSize->12,Black,Bold],Scaled[{0.07,0.02}],ImageScaled[{0,0}]]},ImageSize->590/4+30,AspectRatio->12/10,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

es=1.4;
regimePlot3=Plot[𝒮Ω[f3,1/2,es][m],{m,-0.2,1},Frame->True,FrameStyle->Black,FrameLabel->{m,Style[(Subscript[𝒮, χ])[m],FontOpacity->0]},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}],{Dashed,Line[{{mMax[f3,1/2,es],-0.135},{mMax[f3,1/2,es],0}}]},Text[Style[(Subscript[m, max]),FontFamily->"BitstreamCharter",FontSize->12,Black],{0.07+mMax[f3,1/2,es],-0.145}]},PlotRange->{{-0.05,1.05},{-0.249,0.049}},Epilog->{Text[Style[(Subscript[V, 0])==1.4,FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Scaled[{0.92,0.97}],ImageScaled[{1,1}]],Text[Style["Shattered",FontFamily->"BitstreamCharter",FontSize->12,Black,Bold],Scaled[{0.07,0.02}],ImageScaled[{0,0}]]},ImageSize->590/4+30,AspectRatio->12/10,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

es=1.47;
regimePlot4=Plot[𝒮Ω[f3,1/2,es][m],{m,-0.2,1},Frame->True,FrameStyle->Black,FrameLabel->{m,Style[(Subscript[𝒮, χ])[m],FontOpacity->0]},LabelStyle->{FontFamily->"BitstreamCharter",FontSize->12,Black},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}]},PlotRange->{{-0.05,1.05},{-0.249,0.049}},Epilog->{Text[Style[(Subscript[V, 0])==es,FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Scaled[{0.92,0.97}],ImageScaled[{1,1}]],Text[Style["UNSAT",FontFamily->"BitstreamCharter",FontSize->12,Black,Bold],Scaled[{0.07,0.02}],ImageScaled[{0,0}]]},ImageSize->590/4+30,AspectRatio->12/10,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

SetDirectory[NotebookDirectory[]];
Export["figs/regime_1.pdf",regimePlot1];
Export["figs/regime_2.pdf",regimePlot2];
Export["figs/regime_3.pdf",regimePlot3];
Export["figs/regime_4.pdf",regimePlot4];

Phase diagrams

phasesPlot1=Plot[Evaluate[Reverse@{VSATs[f,α],VSATs[f,α]}/(α^(-1/2))/.f->Function[q,((q^1))]],{α,0,1},Frame->True,FrameStyle->Black,Prolog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}]},PlotRange->{{-0.06,1+0.06},{-0.075,1.275}},Epilog->{Inset[LineLegend[ColorData[97]/@Reverse@Range[3],{(Subscript[V, Style["sat",FontVariations->{"CapsType"->"SmallCaps"}]]),(Subscript[V, sh]),(Subscript[V, on])},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black}],Scaled[{0.75,0.75}]],Text[Style["f(q) = q",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.25,0.15}]]},FrameLabel->{α,"(Subscript[V, 0]) (α^(1/2))"},Filling->{1->Axis},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/3+25,AspectRatio->1,PlotStyle->{ColorData[97][1],ColorData[97][3]}]

phasesPlot2=Plot[Evaluate[Reverse@{VSAT[f,α],Vsh[f,α],Von[f,α]}/(α^(-1/2))/.f->Function[q,(1/2)((q^2))]],{α,0,1},Frame->True,FrameStyle->Black,Prolog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}]},PlotRange->{{-0.06,1+0.06},{-0.075,1.275}},Epilog->{Text[Style["f(q) = (1/2)(q^2)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.3,0.15}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{1->Axis,2->{1},3->{2}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/3+25,AspectRatio->1,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

phasesPlot3=Plot[Evaluate[Reverse@{VSAT[f,α],Vsh[f,α],Von[f,α]}/(α^(-1/2))/.f->Function[q,(1/2)((q^3))]],{α,0,1},Frame->True,FrameStyle->Black,Prolog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}]},PlotRange->{{-0.06,1+0.06},{-0.075,1.275}},Epilog->{Line[{{0.23,1.1716747792652888`},{-0.0,1.1716747792652888`}}],Line[{{0.35,(Sqrt[4/3])-0.06},{0.23,(Sqrt[4/3])-0.06},{0.23,(Sqrt[4/3])},{-0.0,(Sqrt[4/3])}}],,Text[Style["(Subscript[E, gs])",{FontFamily->"Bitstream Charter",FontSize->12,Black}],{0.3,1.165}],Text[Style["(Subscript[E, th])",{FontFamily->"Bitstream Charter",FontSize->12,Black}],{0.43,1.1}],Text[Style["f(q) = (1/2)(q^3)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.3,0.15}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{1->Axis,2->{1},3->{2}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/3+25,AspectRatio->1,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

SetDirectory[NotebookDirectory[]];
Export["figs/phases_1.pdf",phasesPlot1];
Export["figs/phases_2.pdf",phasesPlot2];
Export["figs/phases_3.pdf",phasesPlot3];

Complexity solutions

𝒮SSG=𝒮𝒩[f,α,e/(α^(1/2)),0][m,(OverHat[m]),Ap,Am,D,R]/.α->0;

eqsSSG=D[𝒮SSG,{{m,Ap,Am,R,D,(OverHat[m])}}]/.{(OverHat[m])->0,α->0};

solD=Solve[0==Last[eqsSSG],D]

eqsSSG2=FullSimplify[Most[Drop[eqsSSG,2]]/.D f'[1]-(1/2) (((Am^2)/2)+(((-(Ap/2)+R))^2)) f''[1]->(y- (R^2)((f'[1])^2))/f[1]/.solD[[1]]]

sCompSSG=Solve[0==Append[eqsSSG2,D f'[1]-(1/2) (((Am^2)/2)+(((-(Ap/2)+R))^2)) f''[1]-(y- (R^2)((f'[1])^2))/f[1]/.solD[[1]]]/.f->Function[q,(1/2)(q^3)],{Ap,Am,R,y}];

Chop[Rest[eqsSSG]/.solD[[1]]/.sCompSSG/.{m->0.5,f->Function[q,(1/2)(q^3)],e->1}]

mMax1=ms[Function[q,(1/2)(q^3)],α,1/(α^(1/2))]/.α->0

mMax2=m/.FindMaximum[𝒮SSG/.solD[[1]]/.{(OverHat[m])->0,ϵ->0}/.sCompSSG[[1]]/.{f->Function[q,(1/2)(q^3)],e->1},{m,0.54,0.58}][[2]]

mMax3=m/.FindMaximum[𝒮SSG/.solD[[1]]/.{(OverHat[m])->0,ϵ->0}/.sCompSSG[[3]]/.{f->Function[q,(1/2)(q^3)],e->1},{m,0.55,0.58}][[2]]

insetRange={{0.544,0.584},{-0.0006,0.00145}};
pCompSSGz=Plot[Evaluate[𝒮SSG/.solD[[1]]/.{(OverHat[m])->0}/.sCompSSG[[{1,3,11}]]/.{f->Function[q,(1/2)(q^3)],e->1}],{m,0.505,0.595},PlotRange->insetRange,Frame->True,FrameStyle->Black,LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/5,FrameTicksStyle->Directive[FontOpacity->0,FontSize->0],Prolog->{Line[{{mMax2,-0.002},{mMax2,0.002}}],{Dashed,Line[{{mMax3,-0.002},{mMax3,0.002}}]},Line[{{mMax1,0},{mMax1,0.0007}}],Text[Style[(SuperStar[m]),FontFamily->"Bitstream Charter",FontSize->12,Black],{mMax1+0.001,0.0009}]}]

pCompSSG=Plot[Evaluate[𝒮SSG/.solD[[1]]/.{(OverHat[m])->0}/.sCompSSG[[{1,3,11}]]/.{f->Function[q,(1/2)(q^3)],e->1}],{m,0.505,0.7},PlotRange->{{0.505,0.6195},{-0.0175,0.0025}},Frame->True,FrameStyle->Black,LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/2-10,FrameLabel->{m,(Subscript[𝒮, 𝒩])[m]},Prolog->{FaceForm[None],EdgeForm[Black],Rectangle@@Transpose[insetRange]},Epilog->Inset[pCompSSGz,Scaled[{0.6,0.3}]]]

testdat=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_16.dat"],"-nan"];
testdat2=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_32.dat"],"-nan"];
testdat3=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_64.dat"],"-nan"];
testdat4=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_128.dat"],"-nan"];
testdat5=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_256.dat"],"-nan"];
testdat6=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_512.dat"],"-nan"];
testdat7=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_1024.dat"],"-nan"];
testdat8=DeleteCases[Flatten@Import["~/doc/research/least_squares/code/test_1.0_2048.dat"],"-nan"];
Histogram[{(*Abs@testdat,Abs@testdat2,Abs@testdat3,*)Abs@testdat4,Abs@testdat5,Abs@testdat6,Abs@testdat7,Abs@testdat8},35,{"Log","Probability"},Prolog->{Line[{{mMax1,-10},{mMax1,10}}],Line[{{mMax2,-10},{mMax2,10}}],Line[{{mMax3,-10},{mMax3,10}}]}]

Histogram[{Abs@testdat7,Abs@testdat8},35,"Probability",Prolog->{Line[{{mMax1,-10},{mMax1,10}}],Line[{{mMax2,-10},{mMax2,10}}],Line[{{mMax3,-10},{mMax3,10}}]}]

Length/@{testdat2,testdat3,testdat4,testdat5,testdat6,testdat7,testdat8}

fittest1=LinearModelFit[Log@Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@((mMax3)-Abs@{testdat4,testdat5,testdat6}),x,x]

Show[ListLogLogPlot[Thread[{2^Range[4,11],Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@((mMax3)-Abs@{testdat,testdat2,testdat3,testdat4,testdat5,testdat6,testdat7,testdat8})}]],LogLogPlot[Exp[fittest1[Log2[x]-6]],{x,0,3000}]]

fittest=LinearModelFit[Log@Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@(mMax1-Abs@{testdat5,testdat6,testdat7,testdat8}),x,x]

Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@(mMax1-Abs@{testdat2,testdat3,testdat4,testdat5,testdat6,testdat7,testdat8})

convergence=Show[
LogLogPlot[Exp[fittest[Log2[x]-7]],{x,12,2500},PlotStyle->Black,Epilog->{Line[{{0,Log[mMax1-(mMax2)]},{100,Log[(mMax1)-(mMax2)]}}],{Dashed,Line[{{0,Log[(mMax1)-(mMax3)]},{100,Log[(mMax1)-(mMax3)]}}]}},Frame->True,FrameStyle->Black,LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/2-15,FrameLabel->{N,m-(SuperStar[m])}],ListLogLogPlot[Thread[{2^Range[4,11],Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@((mMax1)-Abs@{testdat,testdat2,testdat3,testdat4,testdat5,testdat6,testdat7,testdat8})}]]]

SetDirectory[NotebookDirectory[]];
Export["figs/alt_sols_1.pdf",pCompSSG];
Export["figs/alt_sols_2.pdf",convergence];

(Exp@fittest[6-3]-Mean[#])/(StandardDeviation[#]/(Sqrt[Length[#]]))&@(mMax1-Abs[testdat7])
(Exp@fittest[7-3]-Mean[#])/(StandardDeviation[#]/(Sqrt[Length[#]]))&@(mMax1-Abs[testdat8])

nfit=NonlinearModelFit[Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@(Abs@{testdat5,testdat6,testdat7,testdat8}),m0-Exp[b-1/2 x],{{m0,0.5773502735179695`},b},x]

nfit2=NonlinearModelFit[Around[Mean[#],StandardDeviation[#]/(Sqrt[Length[#]])]&/@(Abs@{testdat4,testdat5,testdat6,testdat7,testdat8}),m0-Exp[b-c x],{{m0,0.5773502735179695`},b,c},x]

ListPlot[{(Around@@nfit["ParameterTableEntries"][[1,;;2]])-mMax1,(Around@@nfit2["ParameterTableEntries"][[1,;;2]])-mMax1,(Around@@nfit["ParameterTableEntries"][[1,;;2]])-mMax2,(Around@@nfit2["ParameterTableEntries"][[1,;;2]])-mMax2,(Around@@nfit["ParameterTableEntries"][[1,;;2]])-mMax3,(Around@@nfit2["ParameterTableEntries"][[1,;;2]])-mMax3}]

Spheres

randf2[n_]:=(1/(4n))Sum[RandomVariate[NormalDistribution[]]Cos[kx θ]Cos[ ky ϕ]+RandomVariate[NormalDistribution[]]Cos[kx θ]Sin[ky ϕ]+RandomVariate[NormalDistribution[]]Sin[kx θ]Cos[ky ϕ]+RandomVariate[NormalDistribution[]]Sin[kx θ]Sin[ky ϕ],{kx,1,n},{ky,1,n}]

testf=randf2[5];

conF=0+0.3testf+((Cos[2θ])^3)+((Cos[θ])^4);

conF=0+0.3testf+0((Cos[2θ])^3)+6((Cos[θ])^4)+Sin[ϕ+π 7/8];

cPlot2=Show[ContourPlot[0==conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},ContourStyle->{Black,Thickness[0.007]}],AspectRatio->2,Background->White,PlotPoints->100]

dϕC=Evaluate@D[conF,ϕ];

cPointsSpotsC=Select[DeleteDuplicates@Table[untilSuccess@FindRoot[{dϕC,conF},{{θ,RandomReal[{0,π}]},{ϕ,RandomReal[{0,2π}]}}],{20}],0<=θ<=π&&0<=ϕ<=2π/.#&];

cPlot2=Show[ContourPlot[0==conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},ContourStyle->{Black,Thickness[0.007]},PlotPoints->50],ListPlot[{θ,ϕ}/.cPointsSpotsC,PlotMarkers->{Automatic,PointSize[0.02]},PlotStyle->Red],AspectRatio->2,Background->ColorData[97][1]]

cplot3=Image[Show[cPlot2,Frame->False,ImagePadding->0,PlotRangePadding->0,ImageSize->3000]];

sphereSpots1=SphericalPlot3D[1,{θ,0,π},{ϕ,0,2π},Mesh->False,PlotStyle->Directive[Texture[cplot3]],Lighting->"Neutral",PlotPoints->40]

vp={-2.6236811602783363`,2.134048495909731`,0};
vv={1/2/(Sqrt[2]),1/(Sqrt[2]),1/(Sqrt[2])};

connectedManifold=Show[Graphics3D[{Thick,Arrow[{{0,0,-1.3},{0,0,1.3}}]}],sphereSpots1,Boxed->False,ViewPoint->Dynamic[vp],ViewVertical->Dynamic[vv],ImageSize->165,Axes->False]

testf=randf2[15];

conF=0+testf+((Cos[2θ])^3)+((Cos[θ])^4)/.θ->2(θ-π/2)+π/2;

conF=-0.5+(0.5testf+0.3((Cos[2θ])^3)+6((Cos[θ])^2)+((Sin[16ϕ+π 7/8])^1))+0.3(testf/.θ->0);

cPlot2=Show[ContourPlot[0==conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},ContourStyle->{Black,Thickness[0.007]}],AspectRatio->2,Background->White,PlotPoints->150]

dϕC=Evaluate@D[conF,ϕ];

cPointsSpotsC=Select[DeleteDuplicates@Table[untilSuccess@FindRoot[{dϕC,conF},{{θ,RandomReal[{π/4,3π/4}]},{ϕ,RandomReal[{0,2π}]}}],{100}],π/4<=θ<=3π/4&&0<=ϕ<=2π/.#&];

cPlot2=Show[ContourPlot[0==conF,{θ,π/4,3π/4},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},ContourStyle->{Black,Thickness[0.007]},PlotPoints->50],ListPlot[{θ,ϕ}/.cPointsSpotsC,PlotMarkers->{Automatic,PointSize[0.02]},PlotStyle->Red],AspectRatio->2,Background->ColorData[97][2]]

cplot3=Image[Show[cPlot2,Frame->False,ImagePadding->0,PlotRangePadding->0,ImageSize->3000]];

sphereSpots1=SphericalPlot3D[1,{θ,0,π},{ϕ,0,2π},Mesh->False,PlotStyle->Directive[Texture[cplot3]],Lighting->"Neutral",PlotPoints->40]

vp={-2.6236811602783363`,2.134048495909731`,0};
vv={1/2/(Sqrt[2]),1/(Sqrt[2]),1/(Sqrt[2])};

coextManifold=Show[Graphics3D[{Thick,Arrow[{{0,0,-1.3},{0,0,1.3}}]}],sphereSpots1,Boxed->False,ViewPoint->Dynamic[vp],ViewVertical->Dynamic[vv],ImageSize->165,Axes->False]

fSpots=randf2[35];
fConst=fSpots-2(((Cos[θ]^2))^2)-0.15/.θ->5/2(θ-π/2)+π/2;

fConst=fSpots-0.3((Cos[2θ])^3)+6((Cos[θ])^2)-0.2;

rPlot=ContourPlot[0==fConst,{θ,0,π},{ϕ,0,2π},ContourStyle->{Black,Thickness[0.007]},PlotPoints->100,PlotRange->{{0,π},{0,2π}}]

dϕ=Evaluate@D[fConst,ϕ];

cPointsSpots=Select[DeleteDuplicates@Table[untilSuccess@FindRoot[{dϕ,fConst},{{θ,RandomReal[{0,π}]},{ϕ,RandomReal[{0,2π}]}}],{1000}],π/4<=θ<=3π/4&&0<=ϕ<=2π/.#&];

rPlot2=Show[rPlot,ListPlot[{θ,ϕ}/.cPointsSpots,PlotMarkers->{Automatic,PointSize[0.02]},PlotStyle->Red],AspectRatio->2,Background->ColorData[97][3]]

rplot3=Image[Show[rPlot2,Frame->False,ImagePadding->0,PlotRangePadding->0,ImageSize->3000]];

sphereSpots2=SphericalPlot3D[1,{θ,0,π},{ϕ,0,2π},Mesh->False,PlotStyle->Directive[Texture[rplot3]],Lighting->"Neutral",PlotPoints->50]

shatteredManifold=Show[Graphics3D[{Thick,Black,Arrow[{{0,0,-1.3},{0,0,1.3}}]}],sphereSpots2,Axes->False,Boxed->False,ViewPoint->vp,ViewVertical->vv,ImageSize->165]

noManifold=Show[Graphics3D[{Thick,Black,Arrow[{{0,0,-1.3},{0,0,1.3}}]}],Graphics3D[Sphere[]],Axes->False,Boxed->False,ViewPoint->vp,ViewVertical->vv,ImageSize->165]

sphereBar=Graphics[{Arrow[{{0,0},{4,0}}],Line[{{0,-1/16},{0,1/16}}],Line[{{1,-1/32},{1,1/32}}],Line[{{2,-1/32},{2,1/32}}],Line[{{3,-1/32},{3,1/32}}],Text[Style[(Subscript[V, on]),Black,FontFamily->"Bitstream Charter",FontSize->12],{1,-0.11}],
Text[Style[(Subscript[V, sh]),Black,FontFamily->"Bitstream Charter",FontSize->12],{2,-0.11}],
Text[Style[(Subscript[V, Style[sat,FontVariations->{"CapsType"->"SmallCaps"}]]),Black,FontFamily->"Bitstream Charter",FontSize->12],{3,-0.1}],Text[Style[(Subscript[V, 0]),Black,FontFamily->"Bitstream Charter",FontSize->12],{4,-0.1}]},ImageSize->590]

SetDirectory[NotebookDirectory[]];
Export["figs/connected.pdf",connectedManifold];
Export["figs/shattered.pdf",shatteredManifold];
Export["figs/coexist.pdf",coextManifold];
Export["figs/gone.pdf",noManifold];
Export["figs/bar.pdf",sphereBar];