Definitions

SetAttributes[untilSuccess,HoldAll];
untilSuccess[e_]:=Quiet[Check[e,untilSuccess[e]]]

Extensive M

RsOverM[f_,α_,V0_][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])-α √(((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+1/RsOverM[f,α,V0][m])/(1-(m^2)))]+((V0^2)/(f[1]))(((1-((f'[1])/(f[1]))((1-(m^2))/(1+1/RsOverM[f,α,V0][m]))))^(-1)))+(1/2)Log[((-1)/(RsOverM[f,α,V0][m]))]

𝒮χ2m0[f_,α_,V0_]:=Re[𝒮χ[f,α,V0][0]]

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

mc[f_,α_,V0_]:=√(1-((2(1-α)f[1]f'[1])/((2-α)f[1]f''[1]+2(1-α)((f'[1])^2)-(Sqrt[α f''[1]])(Sqrt[4(V0^2)(1-α)((f'[1])^2)+α ((f[1])^2)f''[1]]))))
𝒮𝒩[f_,α_,V0_][m_]:=Piecewise[{{𝒮χ[f,α,V0][m],(m^2)>=((mc[f,α,V0])^2)},{𝒮𝒩s[f,α,V0][m],(m^2)<((mc[f,α,V0])^2)}}]

Von1[f_,α_]:=(Sqrt[(1/α)((1-α)(((f'[1])^2)/(f''[1]))-α f[1])])

Von[f_,α_]:=(Sqrt[(1/α)(1-α+(Sqrt[1-α]))f[1]])
Vsh[f_,α_]:=(Sqrt[(1/α)(((1+(Sqrt[1-α])))^2)f[1](1-((f[1])/(f'[1])))])

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

VSATs[f_,α_]:=(Sqrt[((f'[1])/α)-f[1]])
VSAT[f_][α_?NumericQ]:=Block[{V0,αα=Rationalize[α,(10^(-30))]},V0/.FindRoot[Re@𝒮χ[f,αα,V0][0],{V0,2VSATs[f,αα]},WorkingPrecision->20]]

Vtriv[f_][α_?NumericQ]:=Block[{V0,a=Derivative[1][f][0],b=(1/2)Derivative[2][f][0],αα=Rationalize[α,(10^(-30))]},
Abs[V0] /.FindRoot[𝒮χ2m0[f,αα,V0],{V0,(Sqrt[a (E^((-αα+Log[(b/(a+b))])/(αα)))+b (E^((-αα+Log[(b/(a+b))])/(αα)))])},WorkingPrecision->20]]

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

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

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

rsbInstab[f_,α_,V0_]:=With[{R11=RsOverM[f,α,V0][0]},(((1+R11))^3) ((f[1])^3)-3 R11 (((1+R11))^2) ((f[1])^2) f'[1]+R11 α ((f'[0])^2) f'[1]-(R11^3) ((f'[1])^3)+(V0^2) α (2 (1+R11) ((f'[0])^2)+R11 f'[1] f''[0])-(1+R11) f[1] (-3 (R11^2) ((f'[1])^2)+α (((f'[0])^2)+(V0^2) f''[0]))]

rsbInstab2[f_,α_,V0_]:=With[{R11=RsOverM[f,α,V0][0]},-((((1+R11) f[1]-R11 f'[1]))^3) (-α ((f'[0])^2)+((f'[1])^2)) (-α ((f'[0])^2)+f'[1] (f[1]+R11 f[1]-R11 f'[1]))+(R11^2) (V0^4) (α^2) ((f'[1])^2) f''[0] ((1+R11) ((f'[0])^2)+R11 f'[1] f''[0])+(V0^2) α ((1+R11) f[1]-R11 f'[1]) ((1+R11) ((f'[0])^2) ((1+R11) f[1]-R11 f'[1]) (α ((f'[0])^2)-((f'[1])^2))+R11 f'[1] (α ((f'[0])^2) (f[1]+R11 f[1]-2 R11 f'[1])+(-1+R11) ((f'[1])^2) (f[1]+R11 f[1]-R11 f'[1])) f''[0])]

M = 1 (Spherical spin glasses)

RsOverM[f_,E_][m_]:=((-(1-(m^2)))/(2(((f[1]-(1-(m^2))f'[1]))^2)))((E^2)f'[1]+2f[1](((f[1])/(1-(m^2)))-f'[1])-(Sqrt[4 (E^2) f[1] (((f[1])/(1-(m^2)))-f'[1]) f'[1]+(E^4) ((f'[1])^2)]))
𝒮χ[f_,E_][m_]:=-(1/2)((E^2)/(f[1]))(((1-((f'[1])/(f[1]))((1-(m^2))/(1+1/RsOverM[f,E][m]))))^(-1))+(1/2)Log[((-1)/(RsOverM[f,E][m]))]

𝒮𝒩s[f_,E_][m_]:=(1/2)Log[((f''[1](1-(m^2)))/(f'[1]))]-(1/2)(((E^2)(f''[1](1-(m^2))-f'[1]))/((1-(m^2))(f''[1]f[1]+((f'[1])^2))-f[1]f'[1]))

mc[f_,E_]:=(Sqrt[1-((f[1]f'[1])/(f[1]f''[1]+((f'[1])^2)-(Sqrt[f''[1]])(Sqrt[(E^2)((f'[1])^2)])))])
𝒮𝒩[f_,E_][m_]:=Piecewise[{{𝒮χ[f,E][m],(m^2)>=((mc[f,E])^2)},{𝒮𝒩s[f,E][m],(m^2)<((mc[f,E])^2)}}]

μm[f_]:=(Sqrt[4f''[1]])

Eon1[f_]:=(Sqrt[(((f'[1])^2)/(f''[1]))])
Eon[f_,α_]:=(Sqrt[2f[1]])

Eth[f_]:=((f[1] (f''[1]-f'[1])+((f'[1])^2))/(f'[1] (Sqrt[f''[1]])))

Esh[f_]:=(Sqrt[4f[1](1-((f[1])/(f'[1])))])

ESATs[f_]:=(Sqrt[f'[1]])

ESAT[f_]:=Block[{e},e/.FindRoot[𝒮𝒩[f,e][0],{e,ESATs[f]},WorkingPrecision->20]]

Egs[f_]:=Block[{e},e/.FindRoot[𝒮𝒩[f,e][0],{e,ESATs[f]},WorkingPrecision->20]]

mMin[f_,E_]:=(Sqrt[1-(((f[1])^2)/(f'[1]))(4/(4f[1]-(E^2)))])

ms[f_,E_]:=(Sqrt[1-((E^2)/(f'[1]))])

General

Ealg[f_]:=NIntegrate[((f''[q])^(1/2)),{q,0,1},WorkingPrecision->40]

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

f34=Function[q,(1/2)((q^3)+(q^4))];

fp[p_]:=Function[q,(1/2)(q^p)]

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->(Framed[#,Background->White,FrameStyle->Thin]&),LegendLabel->(Subscript[V, 0])],Scaled[{0.075,0.025}],ImageScaled[{0,0}]],Inset[Framed[Style["f(q) = q",FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Background->White,FrameStyle->Thin],Scaled[{0.95,0.975}],ImageScaled[{1,1}]]},ImageSize->590/2+22,AspectRatio->9/10,PlotRange->{{-0.025,1.025},{-0.249,0.099}},Prolog->{Line[{{-1,0},{2,0}}],Line[{{0,-4},{0,1}}],Line[{{1,-4},{1,1}}]}]

es={(10^(-5)),(2/3)Von[fp[3],1/2],Von[fp[3],1/2],1.25,1.325,1.375,Vsh[fp[3],1/2],1.42,VSAT[fp[3]][1/2],1.46};
actionPlot3=Plot[Evaluate[Join[Function[V0,𝒮χ[fp[3],1/2,V0][m]]/@es,Function[V0,Re[𝒮χ[fp[3],1/2,V0][m]]]/@es]],{m,-0.2,1},Frame->True,FrameStyle->Black,PlotStyle->Join[ColorData[97]/@Range[Length[es]],{Dashed,ColorData[97][#]}&/@Range[Length[es]]],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.099}},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->(Framed[#,Background->White,FrameStyle->Thin]&)],Scaled[{0.075,0.025}],ImageScaled[{0,0}]],Inset[Framed[Style["f(q) = (1/2)(q^3)",FontFamily->"BitstreamCharter",FontSize->12,Black,ScriptLevel->1],Background->White,FrameStyle->Thin],Scaled[{0.95,0.975}],ImageScaled[{1,1}]]},ImageSize->590/2+22,AspectRatio->9/10,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}},Exclusions->None]

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

Phase diagrams

lineThickness=Thickness[0.004];

phasesPlot1=Plot[Evaluate[Reverse@{VSATs[f,α],-VSATs[f,α]}/(α^(-1/2))/.f->Function[q,((q^1))]],{α,0,1},Frame->True,FrameStyle->Black,Prolog->{},PlotRange->{{-0.06,1+0.06},{-0.075,1.275}},Epilog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Inset[SwatchLegend[Append[ColorData[97]/@Range[4],White],{"I","II","III",IV,"V"},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},LegendLayout->{"Column",2},LegendFunction->(Framed[#,Background->White,FrameStyle->Thin]&),LegendLabel->Style["Regime",Bold]],Scaled[{0.085,0.07}],ImageScaled[{0,0}]],Text[Style["f(q) = q",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.9,0.925}],ImageScaled[{1,1}]]},FrameLabel->{α,"(Subscript[V, 0]) (α^(1/2))"},Filling->{1->{{2},Directive[ColorData[97][1]]}},PlotStyle->Directive[Black,lineThickness],LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/3+25,AspectRatio->1,PlotStyle->{ColorData[97][1],ColorData[97][3]}]

phasesPlot2=Plot[Evaluate[{-Vsh[f,α],Vsh[f,α],VSAT[f][α],-Von[f,α],Von[f,α],(1/2) (Sqrt[-1+(2/α)-((2 (Sqrt[1-α]))/α)]),-(1/2) (Sqrt[-1+(2/α)-((2 (Sqrt[1-α]))/α)])}/(α^(-1/2))/.f->Function[q,(1/2)((q^2))]],{α,0,1},Frame->True,PlotStyle->Join[ConstantArray[Directive[Black,lineThickness],5],{None,None}],FrameStyle->Black,Prolog->{},PlotRange->{{-0.06,1+0.06},{-0.075,1.275}},Epilog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Text[Style["f(q) = (1/2)(q^2)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.9,0.925}],ImageScaled[{1,1}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{5->{{4},Directive[ColorData[97][2]]},2->{{5},Directive[ColorData[97][3]]},3->{{2},Directive[ColorData[97][4]]},7->{{6},Directive[Black,Opacity[0.25]]}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/3+25,AspectRatio->1,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}}]

phasesPlot3=Plot[Evaluate[{-Vsh[f,α],Vsh[f,α],VSAT[f][α],-Von[f,α],Von[f,α]}/(α^(-1/2))/.f->Function[q,(1/2)((q^3))]],{α,0,1},Frame->True,PlotStyle->Directive[Black,lineThickness],FrameStyle->Black,Prolog->{},PlotRange->{{-0.06,1+0.06},{-0.075,1.275}},Epilog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Line[{{0.305,1.1716747792652888`},{-0.0,1.1716747792652888`}}],Line[{{0.425,(Sqrt[4/3])-0.06},{0.3,(Sqrt[4/3])-0.06},{0.3,(Sqrt[4/3])},{-0.0,(Sqrt[4/3])}}],,Text[Style["(Subscript[E, gs])",{FontFamily->"Bitstream Charter",FontSize->12,Black}],{0.305,(Sqrt[4/3])},ImageScaled[{-0.2,0.45}]],Text[Style["(Subscript[E, th])",{FontFamily->"Bitstream Charter",FontSize->12,Black}],{0.425,(Sqrt[4/3])-0.06},ImageScaled[{-0.2,0.5}]],Text[Style["f(q) = (1/2)(q^3)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.9,0.925}],ImageScaled[{1,1}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{5->{{4},Directive[ColorData[97][2]]},2->{{5},Directive[ColorData[97][3]]},3->{{2},Directive[ColorData[97][4]]}},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];

phasesPlot121=Plot[Evaluate[{-Vtriv[f][α],-Vsh[f,α],Vtriv[f][α],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},VSAT[f][α]],VSAT[f][α],Piecewise[{{Von[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]]}/(α^(-1/2))/.f->Function[q,((1-λ)q+λ(1/2)((q^2)))]/.λ->1/8],{α,0.001,0.999},Frame->True,PlotStyle->Directive[Black,lineThickness],FrameStyle->Black,Prolog->{},PlotRange->{{-0.05,1+0.05},{-0.05,1.05}},Epilog->{Inset[SwatchLegend[Append[ColorData[97]/@Range[4],White],{"I","II","III",IV,"V"},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},LegendFunction->(Framed[#,Background->White,FrameStyle->Thin]&),LegendLayout->{"Column",1}],Scaled[{0.085,0.065}],ImageScaled[{0,0}]],Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Text[Style["λ = (1/8)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.875,0.875}],ImageScaled[{1,0.5}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))"]},Filling->{6->{{1},Directive[ColorData[97][2]]},4->{{3},Directive[ColorData[97][1]]},2->{{1},Directive[ColorData[97][1]]},5->{{4},Directive[ColorData[97][4]]},7->{{6},Directive[ColorData[97][3]]}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/4+25,AspectRatio->5/4,Exclusions->None]

rp18=RegionPlot[Evaluate[0>rsbInstab[Function[q,((1-λ)q+λ(1/2)((q^2)))],α,e (α^(-1/2))]||0<rsbInstab2[Function[q,(1-λ)q+(1/2)λ (q^2)],α,e (α^(-1/2))]/.λ->1/8],{α,0,1},{e,-0.3,0.3},BoundaryStyle->None,PlotStyle->{Black,Opacity[0.25]},PlotPoints->100]

phasesPlot121b=Show[phasesPlot121,rp18]

phasesPlot122=Plot[Evaluate[{-Vtriv[f][α],-Vsh[f,α],Vtriv[f][α],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},VSAT[f][α]],VSAT[f][α],Piecewise[{{Von[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]]}/(α^(-1/2))/.f->Function[q,((1-λ)q+λ(1/2)((q^2)))]/.λ->3/8],{α,0.001,0.999},Frame->True,PlotStyle->Directive[Black,lineThickness],FrameStyle->Black,Prolog->{},PlotRange->{{-0.05,1+0.05},{-0.05,1.05}},Epilog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Text[Style["λ = (3/8)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.875,0.875}],ImageScaled[{1,0.5}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{6->{{1},Directive[ColorData[97][2]]},4->{{3},Directive[ColorData[97][1]]},2->{{1},Directive[ColorData[97][1]]},5->{{4},Directive[ColorData[97][4]]},7->{{6},Directive[ColorData[97][3]]}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/4+25,AspectRatio->5/4,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}},Exclusions->None]

rp38=RegionPlot[Evaluate[0>rsbInstab[Function[q,((1-λ)q+λ(1/2)((q^2)))],α,e (α^(-1/2))]||0<rsbInstab2[Function[q,(1-λ)q+(1/2)λ (q^2)],α,e (α^(-1/2))]/.λ->3/8],{α,0,1},{e,-0.34,0.34},BoundaryStyle->None,PlotStyle->{Black,Opacity[0.25]},PlotPoints->100]

phasesPlot122b=Show[phasesPlot122,rp38]

phasesPlot123=Plot[Evaluate[{-Vtriv[f][α],-Vsh[f,α],Vtriv[f][α],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},VSAT[f][α]],VSAT[f][α],Piecewise[{{Von[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]]}/(α^(-1/2))/.f->Function[q,((1-λ)q+λ(1/2)((q^2)))]/.λ->5/8],{α,0.001,0.999},Frame->True,PlotStyle->Directive[Black,lineThickness],FrameStyle->Black,Prolog->{},PlotRange->{{-0.05,1+0.05},{-0.05,1.05}},Epilog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Text[Style["λ = (5/8)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.875,0.875}],ImageScaled[{1,0.5}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{6->{{1},Directive[ColorData[97][2]]},4->{{3},Directive[ColorData[97][1]]},2->{{1},Directive[ColorData[97][1]]},5->{{4},Directive[ColorData[97][4]]},7->{{6},Directive[ColorData[97][3]]}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/4+25,AspectRatio->5/4,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}},Exclusions->None]

rp58=RegionPlot[Evaluate[0>rsbInstab[Function[q,((1-λ)q+λ(1/2)((q^2)))],α,e (α^(-1/2))]||0<rsbInstab2[Function[q,(1-λ)q+(1/2)λ (q^2)],α,e (α^(-1/2))]/.λ->5/8],{α,0,1},{e,-0.4,0.4},BoundaryStyle->None,PlotStyle->{Black,Opacity[0.25]},PlotPoints->100]

phasesPlot123b=Show[phasesPlot123,rp58]

phasesPlot124=Plot[Evaluate[{-Vtriv[f][α],-Vsh[f,α],Vtriv[f][α],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},VSAT[f][α]],VSAT[f][α],Piecewise[{{Von[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]],Piecewise[{{Vsh[f,α],Re[𝒮χ[f,α,Vsh[f,α]][0]]>0}},Vtriv[f][α]]}/(α^(-1/2))/.f->Function[q,((1-λ)q+λ(1/2)((q^2)))]/.λ->7/8],{α,0.001,0.999},Frame->True,PlotStyle->Directive[Black,lineThickness],FrameStyle->Black,Prolog->{},PlotRange->{{-0.05,1+0.05},{-0.05,1.05}},Epilog->{Line[{{0,-1},{0,2}}],Line[{{1,-1},{1,2}}],Line[{{-1,0},{2,0}}],Text[Style["λ = (7/8)",{FontFamily->"Bitstream Charter",FontSize->12,Black,ScriptLevel->2}],Scaled[{0.875,0.875}],ImageScaled[{1,0.5}]]},FrameLabel->{α,Style["(Subscript[V, 0]) (α^(1/2))",FontOpacity->0]},Filling->{6->{{1},Directive[ColorData[97][2]]},4->{{3},Directive[ColorData[97][1]]},2->{{1},Directive[ColorData[97][1]]},5->{{4},Directive[ColorData[97][4]]},7->{{6},Directive[ColorData[97][3]]}},LabelStyle->{FontFamily->"Bitstream Charter",FontSize->12,Black},ImageSize->590/4+25,AspectRatio->5/4,FrameTicksStyle->{{FontOpacity->0,Automatic},{Automatic,Automatic}},Exclusions->None]

rp78=RegionPlot[Evaluate[0>rsbInstab[Function[q,((1-λ)q+λ(1/2)((q^2)))],α,e (α^(-1/2))]||0<rsbInstab2[Function[q,(1-λ)q+(1/2)λ (q^2)],α,e (α^(-1/2))]/.λ->7/8],{α,0,1},{e,-0.5,0.5},BoundaryStyle->None,PlotStyle->{Black,Opacity[0.25]},PlotPoints->100]

phasesPlot124b=Show[phasesPlot124,rp78]

SetDirectory[NotebookDirectory[]];
Export["figs/phases_12_1.pdf",phasesPlot121b];
Export["figs/phases_12_2.pdf",phasesPlot122b];
Export["figs/phases_12_3.pdf",phasesPlot123b];
Export["figs/phases_12_4.pdf",phasesPlot124b];

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[7];

conF=0+0.07testf+(((Cos[θ])^2))-0.3;

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->Black,PlotStyle->{Black,Opacity[0.4]}],AspectRatio->2,Background->White]

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

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

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->None,PlotStyle->{Black,Opacity[0.4]}],ListPlot[{θ,ϕ}/.cPointsSpotsC,PlotMarkers->{Automatic,PointSize[0.02]},PlotStyle->Black],AspectRatio->2,Background->ColorData[97][1]]

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->{Black,Thickness[0.007]},PlotStyle->{Black,Opacity[0.4]}](*,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[35];

conF=0+0.15testf(((1-((Cos[θ])^2)))^4)+(3((Cos[θ])^2)+((Cos[2θ])^2))-1+0 0.05Sin[17ϕ](((1-((Cos[θ])^2)))^4);

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->Black,PlotStyle->{Black,Opacity[0.4]}],AspectRatio->2,Background->White]

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

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

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->None,PlotStyle->{Black,Opacity[0.4]},PlotPoints->100],ListPlot[{θ,ϕ}/.cPointsSpotsC,PlotMarkers->{Automatic,PointSize[0.02]},PlotStyle->Black],AspectRatio->2,Background->ColorData[97][2]]

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->{Black,Thickness[0.007]},PlotStyle->{Black,Opacity[0.4]},PlotPoints->100](*,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])};

middleManifold=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[30];

conF=0+1.25testf+(7((Cos[θ])^4))-0.15;

cPlot2=Show[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->Black,PlotStyle->{Black,Opacity[0.4]}],AspectRatio->2,Background->White]

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[RegionPlot[0>conF,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->{Black,Thickness[0.007]},PlotStyle->{Black,Opacity[0.4]},PlotPoints->100](*,ListPlot[{θ,ϕ}/.cPointsSpotsC,PlotMarkers->{Automatic,PointSize[0.02]},PlotStyle->Red]*),AspectRatio->2,Background->ColorData[97][3]]

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])};

complexManifold=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[40];

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

rPlot=RegionPlot[0>fConst,{θ,0,π},{ϕ,0,2π},PlotRange->{{0,π},{0,2π}},BoundaryStyle->{Black,Thickness[0.007]},PlotStyle->{Black,Opacity[0.4]},PlotPoints->150,AspectRatio->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][4]]

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/middle.pdf",middleManifold];
Export["figs/complex.pdf",complexManifold];
Export["figs/gone.pdf",noManifold];

FRSB shattering

χ0Eq[f_][z_,β_][q_]:=(1/β)(((f''[q])^(-1/2))-z)

χEq[f_][z_,β_,q0_][q_]:=Piecewise[{{χ0Eq[f][z,β][q],q<q0}},1-q]

contEqEq[f_][z_,β_,q0_]:={χ0Eq[f][z,β][q0]-(1-q0)}

𝒮cont[f_,e_][z_,β_,q0_]:=-β e+(1/2)z β f'[1]+(1/2)Integrate[(β^2)f''[q]χEq[f][z,β,q0][q]+(1/(χEq[f][z,β,q0][q]+z/β)),{q,0,1},Assumptions->{q0>0,q0<1,z>0,β>0}]

𝒮contEq[f_][z_,β_,q0_]:=(1/β)(((-1)/2)z β f'[1]-(1/2)Integrate[(β^2)f''[q]χEq[f][z,β,q0][q]+(1/(χEq[f][z,β,q0][q]+z/β)),{q,0,1},Assumptions->{q0>0,q0<1,z>0,β>0}])

q1mEqEq[f_][z_,β_,q0_]:=D[𝒮contEq[f][z,β,q0],{{β,z}}]

allEqsEq[f_][z_,β_,q0_]:=Join[contEqEq[f][z,β,q0],q1mEqEq[f][z,β,q0]]

q1mEq[f_,e_][z_,β_,q0_]:=D[𝒮cont[f,e][z,β,q0],{{β,z}}]

allEqs[f_,e_][z_,β_,q0_]:=Join[contEqEq[f][z,β,q0],q1mEq[f,e][z,β,q0]]

ΔEF[f_]:=(-f[1]((1/(χ f'[1]))-χ)-χ f'[1]/.χ->((Sqrt[f[1]])/(Sqrt[((f'[1])^2)-f[1]f'[1]])))-(-f[1]((1/(χ f'[1]))-χ)-χ f'[1]/.χ->(1/(Sqrt[f''[1]])))

fDat3 = Import["~/doc/research/frsb_kac-rice/ENgd3.txt", "Table"];
fDat2=Import["~/doc/research/frsb_kac-rice/ENgd2.txt","Table"];

gpFunc=Interpolation[Rationalize[fDat2[[All,{1,2}]],(10^(-15))]]

λsol=Table[{s,λλ/.FindMaximum[ΔEF[Function[q,(1/2)(λλ (q^2)+(1-λλ)(q^s))]],{λλ,0.5,0,0.95}][[2]]},{s,2,9}];

Show[ListPlot[{fDat2[[All,{1,2}]],λsol}],Plot[gpFunc[x],{x,2,9.5}]]

λ=Rationalize[fDat2[[8,2]],(10^(-12))];
ppp=Round@fDat2[[8,1]];
f25=Function[q,(1/2)(λ (q^2)+(1-λ)(q^ppp))];

eqs25=allEqs[f25,e][z,β,q0];

eqs25Eq=allEqsEq[f25][z,β,q0];

𝒮25=𝒮contEq[f25][z,β,q0];

𝒮25c=𝒮cont[f25,e][z,β,q0];

Ealg25=Ealg[f25]

testsolEq=untilSuccess@FindRoot[Re@eqs25Eq,{{z,RandomVariate[NormalDistribution[]]},{β,RandomVariate[NormalDistribution[]]},{q0,RandomReal[],0,0.99}},WorkingPrecision->25]

testsolEq2=FindRoot[eqs25Eq,testsolEq/.Rule->List,WorkingPrecision->40]

Eground=𝒮25/.testsolEq2

testsol5=FindRoot[eqs25/.e->-Eground,testsolEq/.Rule->List,WorkingPrecision->30,MaxIterations->500]

testsol6=Prepend[Most[testsol5],e->-Re@Eground]

testsol5s=Rest@FoldList[Function[{sol,qq},Prepend[FindRoot[eqs25/.q0->qq,Rest[sol]/.Rule->List,WorkingPrecision->25],q0->qq]],Prepend[testsol6,0],(q0/.testsol5)Range[1,0,-(10^(-2))]];

iniGuess=MinimalBy[testsol5s,e/.#&][[1]]

numFunc[q_?NumericQ]:=e/.FindRoot[eqs25/.q0->q,Rest[iniGuess]/.Rule->List,WorkingPrecision->20]

max9=FindMinimum[numFunc[q0],{q0,q0/.iniGuess,0,1},WorkingPrecision->40]

ListPlot[{{e,q0}/.testsol5s},Joined->True]

𝒮contN1[f_,e_][z_,β_,q0_]:=(1/2)((β^2)f''[q]χEq[f][z,β,q0][q]+(1/(χEq[f][z,β,q0][q]+z/β)))

𝒮contN2[f_,e_][z_,β_,q0_]:=-β e+(1/2)z β f'[1]

eqsContN[f_,e_][z_,β_,q0_]:={Derivative[1,0,0][𝒮contN2[f,e]][z,β,q0]+Inactive[NIntegrate][Derivative[1,0,0][𝒮contN1[f,e]][z,β,q0],{q,0,1},Exclusions->{q0},WorkingPrecision->20],Derivative[0,1,0][𝒮contN2[f,e]][z,β,q0]+Inactive[NIntegrate][Derivative[0,1,0][𝒮contN1[f,e]][z,β,q0],{q,0,1},Exclusions->{q0},WorkingPrecision->20]}

numEqs[f_][e_?NumericQ,z_?NumericQ,β_?NumericQ,q0_?NumericQ]:=Join[Activate[eqsContN[f,e][z,β,q0]],contEqEq[f][z,β,q0]]

num𝒮[f_][e_?NumericQ,z_?NumericQ,β_?NumericQ,q0_?NumericQ]:=𝒮contN2[f,e][z,β,q0]+NIntegrate[𝒮contN1[f,e][z,β,q0],{q,0,1},Exclusions->{q0},WorkingPrecision->20]

ListPlot[{{e,num𝒮[f25][e,z,β,q0]}/.testsol5s},Joined->True]

grounds1RSB=FoldWhileList[Function[{sol,ss},Prepend[FindRoot[{numEqs[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]][e,z,β,q0],num𝒮[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]][e,z,β,q0]},Rest[sol]/.Rule->List,WorkingPrecision->25],s->ss]],Join[{s->9,e->-Eground},testsol5],Range[9,3+1/2,-1/100],(e/.#)<=Egs[Function[q,Evaluate[(1/2)(gpFunc[s] (q^2)+(1-gpFunc[s])(q^s)/.#)]]]&];

groundsRS=Table[{ss,Egs[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]]},{ss,201/100,9,1/100}];

ListPlot[{{s,e}/.Select[grounds1RSB,s>=3.560/.#&],Abs@groundsRS},Joined->True]

numFuncN[ss_,ini_][q0_?NumericQ]:=e/.FindRoot[numEqs[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]][e,z,β,q0],Thread[{{e,z,β},{e,z,β}/.ini}],WorkingPrecision->25]

FindMinimum[numFuncN[9,Prepend[iniGuess,s->9]][q0],{q0,q0/.iniGuess,0,1},WorkingPrecision->30]

Prepend[iniGuess,s->9]

gpFunc=Interpolation[Rationalize[fDat2[[All,{1,2}]],(10^(-15))]]

max1FRSB=Rest@FoldList[Function[{sol,ss},With[{maxsol=FindMinimum[numFuncN[ss,sol][q0],{q0,q0/.sol,0,1},WorkingPrecision->30]},
Join[{s->ss},maxsol[[2]],FindRoot[numEqs[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]][e,z,β,q0]/.maxsol[[2]],Rest[Rest[sol]]/.Rule->List,WorkingPrecision->25]]
]],Prepend[iniGuess,s->9],Range[9,5,-1/10]];

Select[max1FRSB,q0>(10^(-7))/.#&][[-1]]

maxRS=Table[{ss,(Sqrt[4f[1](1-((f[1])/(f'[1])))])/.f->Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]},{ss,201/100,9,1/100}];

ListPlot[{{s,e}/.Select[grounds1RSB,s>=3.560/.#&],Abs@groundsRS,{s,e}/.Select[max1FRSB,q0>(10^(-7))/.#&],maxRS},Joined->True]

goodGrounds=Sort[(d|->MinimalBy[d,#[[2]]&][[1]])/@GatherBy[Join[{s,e}/.grounds1RSB,Abs@groundsRS],First]];

rescaledMax1FRSB={#1,1-#2/SelectFirst[goodGrounds,d|->First[d]==#1][[2]]}&@@@({s,e}/.Select[max1FRSB,q0>(10^(-7))/.#&]);

rescaledMaxRS={#1,1-#2/SelectFirst[goodGrounds,d|->First[d]==#1][[2]]}&@@@maxRS;

thresRS=Table[{ss,Eth[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]]},{ss,201/100,9,1/100}];

rescaledThRS={#1,1-#2/SelectFirst[goodGrounds,d|->First[d]==#1][[2]]}&@@@thresRS;

goodMax=Join[Select[rescaledMaxRS,#[[1]]<rescaledMax1FRSB[[-1,1]]&],Reverse@rescaledMax1FRSB];

gpComp2=Show[ListPlot[{rescaledThRS,Select[rescaledMaxRS,#[[1]]>rescaledMax1FRSB[[-1,1]]&],goodMax},Joined->True,PlotStyle->{GrayLevel[0.75],{Black,Dashed},Black}],ListPlot[MapIndexed[{#2[[1]]+1,#1}&,#]&/@MapThread[-((-#2/fDat2[[1,3]]-#1)/(#1 ))&,{{Prepend[Select[goodGrounds,IntegerQ@*First],{2,1}][[All,2]],Prepend[Select[goodGrounds,IntegerQ@*First],{2,1}][[All,2]]},(Join[-Transpose[fDat2[[All,{3,4}]]]])}],PlotStyle->Black,PlotMarkers->{Automatic,Small}],PlotRange->{{1.75,9.25},{-0.00125,0.02125}},Frame->True,FrameStyle->Black,FrameLabel->{s,"E / (Subscript[E, gs]) - 1"},Prolog->{Thin,Line[{{-1,0},{14,0}}],Line[{{2,-0.01},{2,0.07}}]},LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12},Epilog->{Text[Style["f(q) =(1/2)(λ (q^2)+ (1-λ) (q^s))",Directive[Black,FontFamily->"Bitstream Charter",FontSize->12,ScriptLevel->1]],Scaled[{0.35,0.85}]],Inset[LineLegend[{Black,GrayLevel[0.75]},{"(Subscript[E, sh])","(Subscript[E, th])"},LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12},LegendLayout->"Row"],Scaled[{0.3,0.71}]]},ImageSize->590/2]

gpFunc3=Interpolation[Rationalize[fDat3[[All,{1,2}]],(10^(-15))]]

maxRS3=Table[{ss,(Sqrt[4f[1](1-((f[1])/(f'[1])))])/.f->Function[q,Evaluate[(1/2)(gpFunc3[ss] (q^3)+(1-gpFunc3[ss])(q^ss))]]},{ss,301/100,13,1/100}];

goodGrounds3=Table[{ss,Egs[Function[q,Evaluate[(1/2)(gpFunc3[ss] (q^3)+(1-gpFunc3[ss])(q^ss))]]]},{ss,301/100,13,1/100}];

rescaledMaxRS3={#1,1-#2/SelectFirst[goodGrounds3,d|->First[d]==#1][[2]]}&@@@maxRS3;

thresRS3=Table[{ss,Eth[Function[q,Evaluate[(1/2)(gpFunc3[ss] (q^3)+(1-gpFunc3[ss])(q^ss))]]]},{ss,301/100,13,1/100}];

rescaledThRS3={#1,1-#2/SelectFirst[goodGrounds3,d|->First[d]==#1][[2]]}&@@@thresRS3;

gs3=Egs[fp[3]]

gpComp3=Show[ListPlot[{rescaledThRS3,rescaledMaxRS3},Joined->True,PlotStyle->{GrayLevel[0.75],Black}],ListPlot[MapIndexed[{#2[[1]]+2,#1}&,#]&/@MapThread[-((#2/(Sqrt[2])-#1)/(#1))&,{{Prepend[Select[goodGrounds3,IntegerQ@*First],{3,gs3}][[All,2]],Prepend[Select[goodGrounds3,IntegerQ@*First],{3,gs3}][[All,2]]},(Join[-Transpose[fDat3[[All,{4,3}]]]])}],PlotStyle->Black,PlotMarkers->{Automatic,Small}],Frame->True,FrameStyle->Black,FrameLabel->{s,Style["E / (Subscript[E, gs])-1",FontOpacity->0]},PlotRange->{{2.5,13.5},{-0.00375,0.05375}},Prolog->{Thin,Line[{{-1,0},{14,0}}],Line[{{3,-0.01},{3,0.07}}]},LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12},Epilog->{Text[Style["f(q) =(1/2)(λ (q^3)+ (1-λ) (q^s))",Black,FontFamily->"Bitstream Charter",FontSize->12,ScriptLevel->1],Scaled[{0.35,0.85}]]},ImageSize->590/2-5,AspectRatio->1/GoldenRatio-0.005]

SetDirectory[NotebookDirectory[]];
Export["~/doc/research/least_squares/papers/topology/figs/dynamics_2.pdf",gpComp2];
Export["~/doc/research/least_squares/papers/topology/figs/dynamics_3.pdf",gpComp3];

RSB instability versus FRSB calculation

max1FRSBBetter1=SelectFirst[max1FRSB,q0<(10^(-2))/.#&]

max1FRSBBetter=Rest@FoldList[Function[{sol,ss},With[{maxsol=FindMinimum[numFuncN[ss,sol][q0],{q0,q0/.sol,0,1},WorkingPrecision->30]},
Join[{s->ss},maxsol[[2]],FindRoot[numEqs[Function[q,Evaluate[(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]][e,z,β,q0]/.maxsol[[2]],Rest[Rest[sol]]/.Rule->List,WorkingPrecision->25]]
]],max1FRSBBetter1,s-Range[0,5/100,(10^(-3))]/.max1FRSBBetter1];

plotRSB=Show[Plot[Evaluate[Det[eqs12cSSG/.f->Function[q,(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]/.e->Esh[Function[q,(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]]],{ss,2,9},PlotStyle->ColorData[97][2]],ListPlot[{s,q0}/.Join[Select[max1FRSB,q0>(10^(-2))/.#&],max1FRSBBetter,{{s->2,q0->0}}],Joined->True],PlotRange->{{2,9},{-0.04,0.34}},Frame->True,FrameLabel->{s,""},Epilog->Inset[LineLegend[ColorData[97]/@Range[2],{(Subscript[q, 0]),"det ∂∂(Subscript[𝒮, (χ^2)])"},LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12}],Scaled[{0.075,0.925}],ImageScaled[{0,1}]],LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12}]

Export["~/doc/research/least_squares/papers/topology/figs/rsb_comp.pdf",plotRSB];

Show[Plot[Evaluate[Det[eqs12cSSG/.f->Function[q,(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]/.e->Esh[Function[q,(1/2)(gpFunc[ss] (q^2)+(1-gpFunc[ss])(q^ss))]]]],{ss,2,9},PlotStyle->ColorData[97][2]],ListPlot[{s,q0}/.Join[Select[max1FRSB,q0>(10^(-2))/.#&],max1FRSBBetter,{{s->2,q0->0}}],Joined->True],PlotRange->{{5.54,5.57},{-0.002,0.002}},Frame->True,FrameLabel->{s,""},Epilog->Inset[LineLegend[ColorData[97]/@Range[2],{(Subscript[q, 0]),"det ∂∂(Subscript[𝒮, (χ^2)])"},LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12}],Scaled[{0.05,0.95}],ImageScaled[{0,1}]],LabelStyle->{Black,FontFamily->"Bitstream Charter",FontSize->12}]