Settings

fontSize=11;

labelStyle=LabelStyle->{FontFamily->"Times",Black,FontSize->fontSize};

SetOptions[Plot,labelStyle,Frame->True,FrameStyle->Black];
SetOptions[ListPlot,labelStyle,Frame->True,FrameStyle->Black];
SetOptions[LineLegend,labelStyle];

Large deviation function

G[σ_][ω_]:=-(ω/(2σ))(Sqrt[((ω^2)/(((2σ))^2))-1])+Log[(ω/(2σ))+(Sqrt[((ω^2)/(((2σ))^2))-1])]

pG=Plot[Evaluate[ReIm[G[1][ω]]],{ω,0,4},FrameLabel->{"μ / σ",(Subscript[G, 0])[μ]},Epilog->Inset[LineLegend[ColorData[97]/@Range[2],{"Real part","Imaginary part"}],Scaled[{0.23,0.15}]],PlotRange->{{0,4},{-1.7,1.7}},ImageSize->340]

Export["~/doc/research/frsb_kac-rice/papers/marginal/figs/large_deviation.pdf",pG]

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

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

ρ[f_,μ_][λ_]:=(2/(π μm[f]))(Sqrt[1-((((λ-μ))^2)/((μm[f])^2))])

340/3.

plotSpec[μ_,lab_]:=Plot[ρ[f34,μ][λ],{λ,-3,15},AspectRatio->2/3,PlotRange->{{-3,15},{0,4(4/10)(2/(π μm[f34]))}},FrameStyle->Black,ImageSize->118,PlotRangeClipping->False,Frame->True,FrameTicks->{{None,None},{None,{0}}},ImagePadding->{{Automatic,Automatic},{2,Automatic}}]

plotSpecWithμArrow[μ_,lab_,lab2_:None]:=Show[plotSpec[μ,lab],Prolog->{Arrow[{{0,(2/(π μm[f34]))(1/8)},{μ,(2/(π μm[f34]))(1/8)}}],{Dashed,Line[{{μ,0},{μ,(2/(π μm[f34]))}}],Text[Style["μ",SingleLetterItalics->False,Directive[FontFamily->"Helvetica",Black,FontSize->10]],{μ/2,(2/(π μm[f34]))(5/16)}]},{Arrowheads[{-Automatic,Automatic}],Arrow[{{μ+μm[f34],(2/(π μm[f34]))(1/8)},{μ,(2/(π μm[f34]))(1/8)}}]},Text[Style["2σ",SingleLetterItalics->False,Directive[FontFamily->"Helvetica",Black,FontSize->10]],{μ+μm[f34]/2,(2/(π μm[f34]))(5/16)}]}(*Epilog->Text[Style["("<>lab<>")",SingleLetterItalics->False,Directive[Bold,FontFamily->Times,Black,FontSize->10]],{15.5,(2/(π μm[f34]))(11.25/8)}]*),FrameLabel->{None,lab2},RotateLabel->False]

plotSpecWithIso[μ_,λi_,lab_,lab2_:None]:=Show[
plotSpec[μ,lab],
Prolog->{(*Line[{{λi,(2/(π μm[f34]))(1/8)},{λi,(2/(π μm[f34]))(5/8)}}],Text[Style["(Subscript[λ, 0])",SingleLetterItalics->False,Directive[FontFamily->"Helvetica",Black,FontSize->10]],{λi+0.1,(2/(π μm[f34]))(6.25/8)}],*)Arrow[{{0,(2/(π μm[f34]))(1/8)},{μ,(2/(π μm[f34]))(1/8)}}],{Dashed,Line[{{μ,0},{μ,(2/(π μm[f34]))}}],Text[Style["μ",SingleLetterItalics->False,Directive[FontFamily->"Helvetica",Black,FontSize->10]],{μ/2,(2/(π μm[f34]))(5/16)}]},{Arrowheads[{-Automatic,Automatic}],Arrow[{{μ+μm[f34],(2/(π μm[f34]))(1/8)},{μ,(2/(π μm[f34]))(1/8)}}]},Text[Style["2σ",SingleLetterItalics->False,Directive[FontFamily->"Helvetica",Black,FontSize->10]],{μ+μm[f34]/2,(2/(π μm[f34]))(5/16)}]},
Epilog->{{ColorData[97][1],PointSize[0.035],Point[{λi,0}]}(*,Text[Style["("<>lab<>")",SingleLetterItalics->False,Directive[Bold,FontFamily->"Helvetica",Black,FontSize->10]],{15.5,(2/(π μm[f34]))(11.25/8)}]*)},PlotRangeClipping->False,FrameLabel->{None,lab2},RotateLabel->False
]

pS1=plotSpecWithμArrow[4,"a",ρ[λ]]

pS2=plotSpecWithμArrow[6,"b",Style[ρ[λ],Opacity[0]]]

ps6=plotSpecWithIso[8,0,"f",Style[ρ[λ],Opacity[0]]]

Export["~/doc/research/frsb_kac-rice/papers/marginal/figs/spectrum_less.pdf",pS1];
Export["~/doc/research/frsb_kac-rice/papers/marginal/figs/spectrum_eq.pdf",pS2];
Export["~/doc/research/frsb_kac-rice/papers/marginal/figs/spectrum_more.pdf",ps6];

Two-sphere

p0RSBrules={
p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}].p0RSBmat[n_,{bdt_,b0tu_,b0tl_,bd_,b0_}]:>p0RSBmat[n,{
adt bdt+(n-1)a0tu b0tl,
a0tu bd+adt b0tu+(n-2)a0tu b0,
a0tl bdt+ad b0tl+(n-2)b0tl a0,
ad bd+a0tl b0tu+(n-2)a0 b0,
a0 bd+ad b0+a0tl b0tu+(n-3)a0 b0
}],
p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]+p0RSBmat[n_,{bdt_,b0tu_,b0tl_,bd_,b0_}]:>p0RSBmat[n,{
adt+bdt,
a0tu+b0tu,
a0tl+b0tl,
ad+bd,
a0+b0
}],
-p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]:>p0RSBmat[n,{-adt,-a0tu,-a0tl,-ad,-a0}],
logDet[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>(n-2)Log[ad-a0]+Log[adt ad+(n-2)adt a0-(n-1)a0tu a0tl],
((p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}])^2):>p0RSBmat[n,{(adt^2),(a0tu^2),(a0tl^2),(ad^2),(a0^2)}],
sumDiag[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>adt+(n-1)ad,
sum[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>adt+(n-1)(ad+a0tu+a0tl)+((n^2)-1-3(n-1))a0
};

matForm[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:=With[{a=Unique[a]},Array[a,{n,n}]/.{a[1,1]:>adt,a[i_,i_]:>ad,a[i_,j_]:>a0tu/;(i==1&&j!=1),a[i_,j_]:>a0tl/;(i!=1&&j==1),a[_,_]:>a0}]

A=p0RSBmat[7,{adt,a0tu,a0tl,ad,a0}];
B=p0RSBmat[7,{bdt,b0tu,b0tl,bd,b0}];

matForm[A]//MatrixForm

matForm[A].matForm[B]-matForm[A.B/.p0RSBrules]//MatrixForm

logDet[A]-Log[Det[matForm[A]]]/.p0RSBrules//FullSimplify[#,Assumptions->{ad>a0,a0>0,ad>0,ad>0}]&

𝒮twin=With[{Q11=p0RSBmat[n,{q11d1,q111,q111,q11d0,q110}],Q22=p0RSBmat[n,{q22d1,q221,q221,q22d0,q220}],Q12=p0RSBmat[n,{q12d1,q121,q121,q12d0,q120}]},
-β(ω1 sumDiag[Q11]+ω2 sumDiag[Q22]+2 ϵ sumDiag[Q12])+λ(ω1 q11d1+ω2 q22d1+2 ϵ q12d1)+((σ1)^2)((β^2)sum[(Q11^2)]+(λ^2)(q11d1^2)-2 β λ((q11d1^2)+(n-1)(q111^2)))+((σ2)^2)((β^2)sum[(Q22^2)]+(λ^2)(q22d1^2)-2 β λ((q22d1^2)+(n-1)(q221^2)))+(1/2)logDet[Q11.Q22-Q12.Q12]//.p0RSBrules
];

e1=FullSimplify[Limit[𝒮twin,n->0],Assumptions->{0<q11d0<1,0<q11d1<1,0<q110<1,0<q220<1}]/.{q22d0->1-q11d0,q22d1->1-q11d1}

e2=FullSimplify[e1/.{ϵ->0,q120->0,q121->0,q12d0->0,q12d1->0},Assumptions->{(q111^2)+(-2 q110+q11d0) q11d1>0}]

e3=FullSimplify[D[e2,{{λ,q110,q111,q11d0,q11d1,q220,q221}}]];

rules={q110->q11d-y11/β-z110/(β^2),q111->q11d-y11/β-z111/(β^2),q11d0->q11d- y11d/β- z11d0/(β^2),q11d1->q11d- y11d/β- z11d1/(β^2),q220->q22d-y22/β-z220/(β^2),q221->q22d-y22/β-z221/(β^2),q22d->1-q11d};

e4=SeriesCoefficient[e3//.rules,{β,∞,-2}]

e5=SeriesCoefficient[e3//.rules,{β,∞,-1}]//Simplify

e6=SeriesCoefficient[e3[[1]]//.rules,{β,∞,0}]//Simplify

s6=Simplify[Solve[0==Join[e4,e5,{e6}],{λ,y11,y11d,y22,q11d,z110,z111,z11d0,z11d1,z220,z221}]];

testparams={σ1->1,σ2->1,ω1->3+1/10,ω2->200005/100000,ϵ->1/100};

rules2={q110->q11d-y110/β-z110/(β^2),q111->q11d-y111/β-z111/(β^2),q11d0->q11d- y11d0/β-z11d0/(β^2),q11d1->q11d-y11d1/β-z11d1/(β^2),q220->q22d-y220/β-z220/(β^2),q221->q22d-y221/β-z221/(β^2),q12d1->q12-y12d1/β-z12d1/(β^2),q12d0->q12-y12d0/β-z12d0/(β^2),q121->q12-y121/β-z121/(β^2),q120->q12-y120/β-z120/(β^2),q22d->1-q11d,λ->λ0-λ1/β-λ2/(β^2)};

stest2=Solve[0=={2 y120-2 y121-y12d0+y12d1,2 y110-2 y111-y11d0+y11d1,y11d0-y11d1+2 y220-2 y221},{y110,y120,y220}]

e9=Simplify[e1/.-2Log[x_]+Log[y_]:>Log[y (x^(-2))]//.rules2/.stest2[[1]],TimeConstraint->600];

e10=Simplify[Limit[e9,β->∞]];

e11=Simplify[D[e10,{{q11d,q12,y111,y221,y12d1,y11d0,y11d1,y121,y12d0,z110,z111,z11d0,z11d1,z220,z221,z120,z121,z12d0,z12d1,λ0}}]];

iniTest=Thread[{{q11d,q12,y111,y221,y12d1,y11d0,y11d1,y121,y12d0,z110,z111,z11d0,z11d1,z220,z221,z120,z121,z12d0,z12d1,λ0},
{q11d,q12,y111,y221,y12d1,y11d0,y11d1,y121,y12d0,z110,z111,z11d0,z11d1,z220,z221,z120,z121,z12d0,z12d1,λ0}/.{
λ0-> λ,y110->y11,y111->y11,y220->y22,y221->y22,y11d0->y11d,y11d1->y11d
}/.s6[[3]]/.{z111->0,z110->0,z11d0->0,z220->0,z221->0,z11d1->0,q12->0,y12d1->0,y121->0,y12d0->0,z120->0,z121->0,z12d0->0,z12d1->0}/.Append[Most[testparams],ϵ->(10^(-2))]/. 0:>RandomReal[](10^(-5))
}];
newsol=FindRoot[e11/.Append[Most[testparams],ϵ->(10^(-2))],iniTest,WorkingPrecision->20,MaxIterations->1000]

e12=FoldList[Function[{sol,ω22},Join[Append[Delete[testparams,{4}],ω2->ω22],FindRoot[e11/.Append[Delete[testparams,{4}],ω2->ω22],Drop[sol,5]/.Rule->List,WorkingPrecision->20]]],Join[Append[Most[testparams],ϵ->(10^(-2))],newsol],Range[200005/100000,200003/100000,-(10^(-6))]];

testzero=SelectFirst[e12,Abs[λ0]<(10^(-2))/.#&];
solzero=Join[{λ0->0},Delete[Take[testzero,5],{4}],FindRoot[e11/.Delete[Take[testzero,5],{4}]/.λ0->0,Prepend[Delete[Drop[testzero,5],{-1}],ω2->(ω2/.testzero)]/.Rule->List,WorkingPrecision->30]]

solzeros=FoldList[Function[{sol,ϵϵ},Join[Append[Take[sol,4],ϵ->ϵϵ],FindRoot[e11/.Append[Take[sol,4],ϵ->ϵϵ],Drop[sol,5]/.Rule->List,WorkingPrecision->20,MaxIterations->500]]],solzero,Range[1/100,1.6,(10^(-3))]];

ListPlot[{ϵ,ω2}/.solzeros]

e13=(inisol|->FoldWhileList[Function[{sol,ω22},Join[Append[Take[sol,4],ω2->ω22],FindRoot[e11/.Append[Take[sol,4],ω2->ω22],Drop[sol,5]/.Rule->List,WorkingPrecision->20,MaxIterations->500]]],Join[inisol[[{1,2,3,5,6,4}]],inisol[[7;;]]],Range[Rationalize[ω2/.inisol,(10^(-6))],3+1/10,(10^(-4))],ω2<ω1/.#&])/@((ϵϵ|->SelectFirst[solzeros,ϵ==ϵϵ/.#&])/@Range[0.2,1.6,0.2]);

ListPlot[Evaluate[Prepend[Join[{ω1,ω2}/.Most[#],{ω2,ω1}/.Reverse[Most[#]]]&/@e13,{{3.1,2},{2,2},{2,3.1}}]],PlotRange->{{1.9,3.1},{1.9,3.1}},AspectRatio->1,Joined->True,FrameLabel->{(Subscript[ω, 1]),(Subscript[ω, 2])},PlotLegends->LineLegend[Range[0,1.4,0.2],LegendLabel->ϵ]]

Two-sphere

p0RSBrules={
p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]p0RSBmat[n_,{bdt_,b0tu_,b0tl_,bd_,b0_}]:>p0RSBmat[n,{
adt bdt,
a0tu b0tu,
a0tl b0tl,
ad bd,
a0 b0
}],
p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}].p0RSBmat[n_,{bdt_,b0tu_,b0tl_,bd_,b0_}]:>p0RSBmat[n,{
adt bdt+(n-1)a0tu b0tl,
a0tu bd+adt b0tu+(n-2)a0tu b0,
a0tl bdt+ad b0tl+(n-2)b0tl a0,
ad bd+a0tl b0tu+(n-2)a0 b0,
a0 bd+ad b0+a0tl b0tu+(n-3)a0 b0
}],
p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]+p0RSBmat[n_,{bdt_,b0tu_,b0tl_,bd_,b0_}]:>p0RSBmat[n,{
adt+bdt,
a0tu+b0tu,
a0tl+b0tl,
ad+bd,
a0+b0
}],
const_ p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]:>p0RSBmat[n,const{
adt,
a0tu,
a0tl,
ad,
a0
}],
-p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]:>p0RSBmat[n,{-adt,-a0tu,-a0tl,-ad,-a0}],
logDet[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>(n-2)Log[ad-a0]+Log[adt ad+(n-2)adt a0-(n-1)a0tu a0tl],
((p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}])^2):>p0RSBmat[n,{(adt^2),(a0tu^2),(a0tl^2),(ad^2),(a0^2)}],
sumDiag[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>adt+(n-1)ad,
sum[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>adt+(n-1)(ad+a0tu+a0tl)+((n^2)-1-3(n-1))a0
};

sum[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:>adt+(n-1)(ad+a0tu+a0tl)+((n^2)-1-3(n-1))a0

matForm[p0RSBmat[n_,{adt_,a0tu_,a0tl_,ad_,a0_}]]:=With[{a=Unique[a]},Array[a,{n,n}]/.{a[1,1]:>adt,a[i_,i_]:>ad,a[i_,j_]:>a0tu/;(i==1&&j!=1),a[i_,j_]:>a0tl/;(i!=1&&j==1),a[_,_]:>a0}]

A=p0RSBmat[7,{adt,a0tu,a0tl,ad,a0}];
B=p0RSBmat[7,{bdt,b0tu,b0tl,bd,b0}];

id[n_]:=p0RSBmat[n,{1,0,0,1,0}]

corner[n_]:=p0RSBmat[n,{1,0,0,0,0}]

lineTop[n_]:=p0RSBmat[n,{1,1,0,0,0}]

lineBottom[n_]:=p0RSBmat[n,{1,0,1,0,0}]

lineTop[4]//matForm

corner[4]//matForm

matForm[A]//MatrixForm

matForm[A].matForm[B]-matForm[A.B/.p0RSBrules]//MatrixForm

logDet[A]-Log[Det[matForm[A]]]/.p0RSBrules//FullSimplify[#,Assumptions->{ad>a0,a0>0,ad>0,ad>0}]&

𝒮twin=With[{Q11=p0RSBmat[n,{q11d1,q111,q111,q11d0,q110}],Q22=p0RSBmat[n,{q22d1,q221,q221,q22d0,q220}],Q12=p0RSBmat[n,{q12d1,q121,q121,q12d0,q120}]},
-β(ω1 sumDiag[Q11]+ω2 sumDiag[Q22])+λ(ω1 q11d1+ω2 q22d1)+((σ1)^2)((β^2)sum[(Q11^2)]+(λ^2)(q11d1^2)-2 β λ((q11d1^2)+(n-1)(q111^2)))+((σ2)^2)((β^2)sum[(Q22^2)]+(λ^2)(q22d1^2)-2 β λ((q22d1^2)+(n-1)(q221^2)))+((σ12)^2)((β^2)sum[Q11 Q22]+(λ^2)q11d1 q22d1-2 β λ(q11d1 q22d1+(n-1)q111 q221))+(1/2)logDet[Q11.Q22]//.p0RSBrules
];

𝒮twin2/.n->0

𝒮twin2=With[{Q11=p0RSBmat[n,{q11d1,q111,q111,q11d0,q110}],Q22=p0RSBmat[n,{q22d1,q221,q221,q22d0,q220}],Q12=p0RSBmat[n,{q12d1,q121,q121,q12d0,q120}]},
-β(ω1 sum[id[n] Q11]+ω2 sum[id[n] Q22])+λ(ω1 sum[corner[n]Q11]+ω2 sum[corner[n]Q22])+((σ1)^2)((β^2)sum[(Q11^2)]+(λ^2)sum[corner[n](Q11^2)]-β λ (sum[lineTop[n](Q11^2)]+sum[lineBottom[n](Q11^2)]))+((σ2)^2)((β^2)sum[(Q22^2)]+(λ^2)sum[corner[n](Q22^2)]-β λ (sum[lineTop[n](Q22^2)]+sum[lineBottom[n](Q22^2)]))+((σ12)^2)((β^2)sum[Q11 Q22]+(λ^2)sum[corner[n]Q11 Q22]-β λ(sum[lineTop[n]Q11 Q22]+sum[lineBottom[n]Q11 Q22]))+(1/2)logDet[Q11]+(1/2)logDet[Q22]
];

𝒮twin2

eqs=With[{Q11=p0RSBmat[n,{q11d1,q111,q111,q11d0,q110}],Q22=p0RSBmat[n,{q22d1,q221,q221,q22d0,q220}],Q12=p0RSBmat[n,{q12d1,q121,q121,q12d0,q120}]},
{
(-β(ω1 id[n])+λ(ω1 corner[n])+((σ1)^2)((β^2)2 Q11+(λ^2)2corner[n]Q11-β λ (2lineTop[n]Q11+2lineBottom[n]Q11))+((σ12)^2)((β^2)Q22+(λ^2)corner[n]Q22-β λ(lineTop[n]Q22+lineBottom[n] Q22))).Q11+(1/2)id[n],
(-β(ω2 id[n])+λ(ω2 corner[n])+((σ2)^2)((β^2)2 Q22+(λ^2)2corner[n]Q22-β λ (2lineTop[n]Q22+2lineBottom[n]Q22))+((σ12)^2)((β^2)Q11+(λ^2)corner[n]Q11-β λ(lineTop[n]Q11+lineBottom[n] Q11))).Q22+(1/2)id[n]
}//.p0RSBrules
]//Simplify

eqs2=Flatten[Limit[eqs[[All,2]],n->0]]

𝒮twin

e1=FullSimplify[Limit[𝒮twin,n->0],Assumptions->{0<q11d0<1,0<q11d1<1,0<q110<1,0<q220<1}]/.{q22d0->1-q11d0,q22d1->1-q11d1}

e2=FullSimplify[e1/.{ϵ->0,q120->0,q121->0,q12d0->0,q12d1->0},Assumptions->{(q111^2)+(-2 q110+q11d0) q11d1>0}]

rules2={q110->q11d-y110/β-z110/(β^2),q111->q11d-y111/β-z111/(β^2),q11d0->q11d- y11d0/β-z11d0/(β^2),q11d1->q11d-y11d1/β-z11d1/(β^2),q220->q22d-y220/β-z220/(β^2),q221->q22d-y221/β-z221/(β^2),q12d1->q12-y12d1/β-z12d1/(β^2),q12d0->q12-y12d0/β-z12d0/(β^2),q121->q12-y121/β-z121/(β^2),q120->q12-y120/β-z120/(β^2),q22d->1-q11d,λ->λ0-λ1/β-λ2/(β^2)};

stest2=Solve[0=={2 y120-2 y121-y12d0+y12d1,2 y110-2 y111-y11d0+y11d1,y11d0-y11d1+2 y220-2 y221},{y110,y120,y220}]

e3=Limit[e2//.rules2/.stest2[[1]],β->∞]

e4=Simplify[e3,Assumptions->{2 y111-y11d0-y11d1>0,y11d0+y11d1+2 y221>0}]//.{a_ Log[x_]+b_ Log[y_]:>Log[(x^a)(y^b)],Log[x_]+Log[y_]:>Log[x y]}//FullSimplify

e5=Solve[0==D[e4/.σ12->0,{{λ0,y111,y11d1,y221,q11d,z110,z111,z11d0,z11d1,z220,z221}}],{λ0,y111,y11d1,y221,q11d,z110,z111,z11d0,z11d1,z220,z221}];

rules={q110->q11d-y11/β-z110/(β^2),q111->q11d-y11/β-z111/(β^2),q11d0->q11d- y11d/β- z11d0/(β^2),q11d1->q11d- y11d/β- z11d1/(β^2),q220->q22d-y22/β-z220/(β^2),q221->q22d-y22/β-z221/(β^2),q22d->1-q11d};

e3=Limit[e2/.{q22d0->1-q11d0,q22d1->1-q11d1}//.rules,β->∞]//Simplify

e4=Simplify[Normal@e3,Assumptions->{2 y111-y11d0-y11d1>0,y11d0+y11d1+2 y221>0}]//.{a_ Log[x_]+b_ Log[y_]:>Log[(x^a)(y^b)],Log[x_]+Log[y_]:>Log[x y],a_ Log[x_]+Log[y_]:>Log[(x^a)y]}//FullSimplify

e4b=Simplify[Expand[e4/.{z221->Δz22+z220,z111->Δz11+z110,z11d1->Δz11d+z11d0}]]

vars=DeleteCases[DeleteDuplicates[Cases[e4b,_Symbol,∞]],σ1|σ2|σ12|ω1|ω2]

e5=FullSimplify[D[e4b,{vars}]]

e6=Solve[0==e5,vars];

e6

Length[e6]

e6

e4=SeriesCoefficient[e3//.rules,{β,∞,-2}]

e5=SeriesCoefficient[e3//.rules,{β,∞,-1}]//Simplify

e6=SeriesCoefficient[e3[[1]]//.rules,{β,∞,0}]//Simplify

s6=Simplify[Solve[0==Join[e4,e5,{e6}],{λ,y11,y11d,y22,q11d,z110,z111,z11d0,z11d1,z220,z221}]];

testparams={σ1->1,σ2->1,ω1->3,ω2->200005/100000,ϵ->1/100};

rules2={q110->q11d-y110/β-z110/(β^2),q111->q11d-y111/β-z111/(β^2),q11d0->q11d- y11d0/β-z11d0/(β^2),q11d1->q11d-y11d1/β-z11d1/(β^2),q220->q22d-y220/β-z220/(β^2),q221->q22d-y221/β-z221/(β^2),q12d1->q12-y12d1/β-z12d1/(β^2),q12d0->q12-y12d0/β-z12d0/(β^2),q121->q12-y121/β-z121/(β^2),q120->q12-y120/β-z120/(β^2),q22d->1-q11d,λ->λ0-λ1/β-λ2/(β^2)};

stest2=Solve[0=={2 y120-2 y121-y12d0+y12d1,2 y110-2 y111-y11d0+y11d1,y11d0-y11d1+2 y220-2 y221},{y110,y120,y220}]

e9=Simplify[e1/.-2Log[x_]+Log[y_]:>Log[y (x^(-2))]//.rules2/.stest2[[1]],TimeConstraint->600];

e10=Simplify[Limit[e9,β->∞]];

e11=Simplify[D[e10,{{q11d,q12,y111,y221,y12d1,y11d0,y11d1,y121,y12d0,z110,z111,z11d0,z11d1,z220,z221,z120,z121,z12d0,z12d1,λ0}}]];

iniTest=Thread[{{q11d,q12,y111,y221,y12d1,y11d0,y11d1,y121,y12d0,z110,z111,z11d0,z11d1,z220,z221,z120,z121,z12d0,z12d1,λ0},
{q11d,q12,y111,y221,y12d1,y11d0,y11d1,y121,y12d0,z110,z111,z11d0,z11d1,z220,z221,z120,z121,z12d0,z12d1,λ0}/.{
λ0-> λ,y110->y11,y111->y11,y220->y22,y221->y22,y11d0->y11d,y11d1->y11d
}/.s6[[3]]/.{z111->0,z110->0,z11d0->0,z220->0,z221->0,z11d1->0,q12->0,y12d1->0,y121->0,y12d0->0,z120->0,z121->0,z12d0->0,z12d1->0}/.Append[Most[testparams],ϵ->(10^(-2))]/. 0:>RandomReal[](10^(-5))
}];
newsol=FindRoot[e11/.Append[Most[testparams],ϵ->(10^(-2))],iniTest,WorkingPrecision->20,MaxIterations->1000]

e12=FoldList[Function[{sol,ω22},Join[Append[Delete[testparams,{4}],ω2->ω22],FindRoot[e11/.Append[Delete[testparams,{4}],ω2->ω22],Drop[sol,5]/.Rule->List,WorkingPrecision->20]]],Join[Append[Most[testparams],ϵ->(10^(-2))],newsol],Range[200005/100000,200003/100000,-(10^(-6))]];

testzero=SelectFirst[e12,Abs[λ0]<(10^(-2))/.#&];
solzero=Join[{λ0->0},Delete[Take[testzero,5],{4}],FindRoot[e11/.Delete[Take[testzero,5],{4}]/.λ0->0,Prepend[Delete[Drop[testzero,5],{-1}],ω2->(ω2/.testzero)]/.Rule->List,WorkingPrecision->30]]

solzeros=FoldList[Function[{sol,ϵϵ},Join[Append[Take[sol,4],ϵ->ϵϵ],FindRoot[e11/.Append[Take[sol,4],ϵ->ϵϵ],Drop[sol,5]/.Rule->List,WorkingPrecision->20,MaxIterations->500]]],solzero,Range[1/100,1.6,(10^(-3))]];

ListPlot[{ϵ,ω2}/.solzeros]

e13=(inisol|->FoldWhileList[Function[{sol,ω22},Join[Append[Take[sol,4],ω2->ω22],FindRoot[e11/.Append[Take[sol,4],ω2->ω22],Drop[sol,5]/.Rule->List,WorkingPrecision->20,MaxIterations->500]]],Join[inisol[[{1,2,3,5,6,4}]],inisol[[7;;]]],Range[Rationalize[ω2/.inisol,(10^(-6))],3,(10^(-4))],ω2<ω1/.#&])/@((ϵϵ|->SelectFirst[solzeros,ϵ==ϵϵ/.#&])/@Range[0.2,1.6,0.2]);

ListPlot[Evaluate[Prepend[Join[{ω1,ω2}/.Most[#],{ω2,ω1}/.Reverse[Most[#]]]&/@e13,{{3,2},{2,2},{2,3}}]],PlotRange->{{1.9,3},{1.9,3}},AspectRatio->1,Joined->True,FrameLabel->{(Subscript[ω, 1]),(Subscript[ω, 2])},PlotLegends->LineLegend[Range[0,1.4,0.2],LegendLabel->ϵ]]