Pensieve header: Solving the KV equations ($k=0).

Follows code in Projects/SL2Portfolio/SL2PortfolioProgram.nb.

Startup

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Portfolio2"];
Once[<< KnotTheory`];
Once[<<"../Profile/Profile.m";];
<<"Engine-Speedy.m";
<<"Objects.m";
$k=0;
HL[ℰ_] := Style[ℰ, Background -> Green];

CCF[ℰ_] := (Subscript[PP, CCF])@ExpandDenominator@ExpandNumerator@(Subscript[PP, Together])@Together[(Subscript[PP, Exp])[
Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CCF[x]))]];
CF[ℰ_List]:=CF/@ℰ;
CF[sd_SeriesData] := MapAt[CF,sd,3];
CF[ℰ_] := (Subscript[PP, CF])@Module[
{vs=Cases[ℰ,(Subscript[(y|a|x|η|β|τ|α|ξ), _]),∞]⋃{y,a,x,η,β,τ,α,ξ}},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))]
];
CF[ℰ_𝔼]:=CF/@ℰ; CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];

(Subscript[R, i,j])

Timing@HL[((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[dm, 1,4->1])//(Subscript[dm, 2,5->2])//(Subscript[dm, 3,6->3]) )≡((Subscript[R, 1,6])(Subscript[R, 2,3])(Subscript[R, 4,5])//(Subscript[dm, 1,4->1])//(Subscript[dm, 2,5->2])//(Subscript[dm, 3,6->3]))]

Timing@HL[((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[cm, 1,4->1])//(Subscript[cm, 2,5->2])//(Subscript[cm, 3,6->3]) )≡((Subscript[R, 1,6])(Subscript[R, 2,3])(Subscript[R, 4,5])//(Subscript[cm, 1,4->1])//(Subscript[cm, 2,5->2])//(Subscript[cm, 3,6->3]))]

(Subscript[cR, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[ℏ (Subscript[a, j]) (Subscript[b, i]),((1-(Subscript[B, i]))/(γ (Subscript[b, i]))) (Subscript[x, j]) (Subscript[y, i]),1];
(Subscript[cR, i,j])

HL@Simplify[((Subscript[cR, 1,2])(Subscript[cR, 4,3])(Subscript[cR, 5,6])//(Subscript[cm, 1,4->1])//(Subscript[cm, 2,5->2])//(Subscript[cm, 3,6->3]) )≡((Subscript[cR, 1,6])(Subscript[cR, 2,3])(Subscript[cR, 4,5])//(Subscript[cm, 1,4->1])//(Subscript[cm, 2,5->2])//(Subscript[cm, 3,6->3]))]

According to IntegrationWithGamma.nb, δ=1 below.

(Subscript[V0, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[(δ/2) ℏ (Subscript[a, j]) (Subscript[b, i]),0,1];
(Subscript[V0, i,j])

R4l=((Subscript[V0, -1,-2])((Subscript[cR, 1,3])//(Subscript[cΔ, 1->1,2])))//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

R4r=((Subscript[cR, -2,-3])(Subscript[cR, -1,3]) // (Subscript[cm, -3,3->3]))(Subscript[V0, 1,2])//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

(Subscript[V1, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[(ℏ/2) (Subscript[a, j]) (Subscript[b, i]),ℏ Fij  (Subscript[y, i])(Subscript[x, j])+ℏ Fji (Subscript[x, i]) (Subscript[y, j])+ℏ Fii (Subscript[x, i]) (Subscript[y, i])+ℏ Fjj (Subscript[x, j]) (Subscript[y, j]),ω[(Subscript[B, i]),(Subscript[B, j])]];
(Subscript[V1, i,j])

R4l=((Subscript[V1, -1,-2])((Subscript[cR, 1,3])//(Subscript[cΔ, 1->1,2])))//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

R4r=((Subscript[cR, -2,-3])(Subscript[cR, -1,3]) // (Subscript[cm, -3,3->3]))(Subscript[V1, 1,2])//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

eqs=Simplify@Coefficient[Numerator@Simplify[R4l[[2]]-R4r[[2]]]/(Subscript[x, 3]),#]&/@{(Subscript[y, 1]),(Subscript[y, 2])}

Simplify[{Fii, Fjj}/.Solve[(#==0)& /@ eqs, {Fii, Fjj}]]

(Subscript[V2, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[(ℏ/2) (Subscript[a, j]) (Subscript[b, i]),ℏ Fij  (Subscript[y, i])(Subscript[x, j])+ℏ Fji (Subscript[x, i]) (Subscript[y, j])+ℏ ((-(Subscript[b, i]) (Subscript[B, i]) (-1+(Subscript[B, j]))+(Subscript[b, 2]) (-1+(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (1-(Subscript[B, i]) (Subscript[B, j]))))/(γ ℏ (Subscript[b, i]^2) (-1+(Subscript[B, i]) (Subscript[B, j]))))(Subscript[x, i])(Subscript[y, i])+ℏ ((-(Subscript[b, j]) (-1+(Sqrt[(Subscript[B, i])])) (Sqrt[(Subscript[B, i])]) (1+(Sqrt[(Subscript[B, i])]) (Subscript[B, j]))+(Subscript[b, i]) ((Subscript[B, i]) (-1+(Subscript[B, j]))+Fji γ ℏ (Subscript[b, j]) (1-(Subscript[B, i]) (Subscript[B, j]))))/(γ ℏ (Subscript[b, j]^2) (-1+(Subscript[B, i]) (Subscript[B, j]))))(Subscript[x, j]) (Subscript[y, j]),ω[(Subscript[B, i]),(Subscript[B, j])]];
(Subscript[V2, i,j])

R4l=((Subscript[V2, -1,-2])((Subscript[cR, 1,3])//(Subscript[cΔ, 1->1,2])))//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

R4r=((Subscript[cR, -2,-3])(Subscript[cR, -1,3]) // (Subscript[cm, -3,3->3]))(Subscript[V2, 1,2])//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

HL@Simplify[R4l≡R4r]

R4l=((Subscript[V0, -1,-2])((Subscript[cR, 3,1])//(Subscript[cΔ, 1->1,2])))//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

R4r=((Subscript[cR, -3,-2])(Subscript[cR, 3,-1]) // (Subscript[cm, -3,3->3]))(Subscript[V0, 1,2])//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

CF/@Simplify[R4l≡R4r]

Numerator@CF@First@Simplify[R4l≡R4r]

eqs=(Last[#]==0)&/@CoefficientRules[Numerator@CF@First@Simplify[R4l≡R4r],{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[y, 3])}]

Solve[eqs, {Fij, Fji}]

Simplify/@CF@((Subscript[𝔼, {}->{i,j}])[(1/2) ℏ (Subscript[a, j]) (Subscript[b, i]),(((-(Subscript[b, i]) (Subscript[B, i]) (-1+(Subscript[B, j]))+(Subscript[b, 2]) (-1+(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (1-(Subscript[B, i]) (Subscript[B, j])))) (Subscript[x, i]) (Subscript[y, i]))/(γ (Subscript[b, i]^2) (-1+(Subscript[B, i]) (Subscript[B, j]))))+Fij ℏ (Subscript[x, j]) (Subscript[y, i])+Fji ℏ (Subscript[x, i]) (Subscript[y, j])+(((-(Subscript[b, j]) (-1+(Sqrt[(Subscript[B, i])])) (Sqrt[(Subscript[B, i])]) (1+(Sqrt[(Subscript[B, i])]) (Subscript[B, j]))+(Subscript[b, i]) ((Subscript[B, i]) (-1+(Subscript[B, j]))+Fji γ ℏ (Subscript[b, j]) (1-(Subscript[B, i]) (Subscript[B, j])))) (Subscript[x, j]) (Subscript[y, j]))/(γ (Subscript[b, j]^2) (-1+(Subscript[B, i]) (Subscript[B, j])))),ω[(Subscript[B, i]),(Subscript[B, j])]] /.Fji->Fij-((-(Subscript[b, j])+(Subscript[b, i]) (Subscript[B, i])+(Subscript[b, j]) (Subscript[B, i])-(Subscript[b, i]) (Subscript[B, i]) (Subscript[B, j]))/(γ ℏ (Subscript[b, i]) (Subscript[b, j]) (-1+(Subscript[B, i]) (Subscript[B, j])))))

(Subscript[V0, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[(1/2) ℏ (Subscript[a, j]) (Subscript[b, i]),(1/(γ (Subscript[b, i]^2) (Subscript[b, j]) (-1+(Subscript[B, i]) (Subscript[B, j]))))((Subscript[b, 2]) (Subscript[b, j]) (-1+(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (1-(Subscript[B, i]) (Subscript[B, j]))) (Subscript[x, i]) (Subscript[y, i])+(Subscript[b, i]) ((Subscript[b, i]) ((-1+Fij γ ℏ (Subscript[b, i])) (Subscript[x, j])+(Sqrt[(Subscript[B, i])]) (Subscript[x, j])-(Subscript[B, i]^(3/2)) (Subscript[B, j]) (Subscript[x, j])+(Subscript[B, i]) ((-1+(Subscript[B, j])) (Subscript[x, i])+(1-Fij γ ℏ (Subscript[b, i])) (Subscript[B, j]) (Subscript[x, j]))) (Subscript[y, j])+(Subscript[b, j]) ((Subscript[x, i]) (Subscript[y, j])-Fij γ ℏ (Subscript[b, i]) ((Subscript[x, j]) (Subscript[y, i])+(Subscript[x, i]) (Subscript[y, j]))+(Subscript[B, i]) (Fij γ ℏ (Subscript[b, i]) (Subscript[B, j]) (Subscript[x, j]) (Subscript[y, i])+(Subscript[x, i]) (-(-1+(Subscript[B, j])) (Subscript[y, i])+(-1+Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[y, j])))))),ω[(Subscript[B, i]),(Subscript[B, j])]] /. Fij->Fij[(Subscript[B, i]),(Subscript[B, j])]

R4l=((Subscript[V0, -1,-2])((Subscript[cR, 3,1])//(Subscript[cΔ, 1->1,2])))//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

R4r=((Subscript[cR, -3,-2])(Subscript[cR, 3,-1]) // (Subscript[cm, -3,3->3]))(Subscript[V0, 1,2])//(Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

HL[CF/@Simplify[R4l≡R4r]]

(Subscript[(OverBar[V0]), i_,j_]):=(Subscript[𝔼, {}->{i,j}])[-(ℏ/2) (Subscript[a, j]) (Subscript[b, i]),ℏ  Gij  (Subscript[y, i])(Subscript[x, j])+ℏ Gji (Subscript[x, i]) (Subscript[y, j])+ℏ Gii (Subscript[x, i]) (Subscript[y, i])+ℏ Gjj (Subscript[x, j]) (Subscript[y, j]),(OverBar[ω])[(Subscript[B, i]),(Subscript[B, j])]];
(Subscript[(OverBar[V0]), i,j])

Simplify@((Subscript[(OverBar[V0]), -1,-2])(Subscript[V0, 1,2])// (Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2]))

eqs=(Last[#]==0)& /@ CoefficientRules[Numerator@Simplify@((Subscript[(OverBar[V0]), -1,-2])(Subscript[V0, 1,2])// (Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2]))[[2]], {(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[y, 1]),(Subscript[y, 2])}]

Simplify/@((Subscript[(OverBar[V0]), i,j])/.(Solve[eqs,{Gii,Gij,Gji,Gjj}][[1]] /. {(Subscript[v_, 1]):>(Subscript[v, i]), (Subscript[v_, 2]):>(Subscript[v, j])}))

(Subscript[(OverBar[V0]), i_,j_]):=(Subscript[𝔼, {}->{i,j}])[-(1/2) ℏ (Subscript[a, j]) (Subscript[b, i]),((Subscript[b, j]^2) (Sqrt[(Subscript[B, i])]) (-1+(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (1-(Subscript[B, i]) (Subscript[B, j]))) (Subscript[x, i]) (Subscript[y, i])+(Subscript[b, i]^2) ((Subscript[B, i]^(3/2)) ((-1+(Subscript[B, j])) (Subscript[x, i])-(Subscript[x, j]))+(-1+Fij γ ℏ (Subscript[b, i])) (Subscript[x, j])+(Sqrt[(Subscript[B, i])]) (Subscript[x, j])+(Subscript[B, i]) (1-Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[x, j])) (Subscript[y, j])+(Subscript[b, i]) (Subscript[b, j]) ((-1+Fij γ ℏ (Subscript[b, i])) (Subscript[x, j]) (Subscript[y, j])+(Subscript[B, i]) (1-Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[x, j]) (Subscript[y, j])+(Subscript[B, i]^(3/2)) ((Subscript[x, i]) (-(-1+(Subscript[B, j])) (Subscript[y, i])+(-1+Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[y, j]))+(Subscript[x, j]) (-(Subscript[y, j])+Fij γ ℏ (Subscript[b, i]) (Subscript[B, j]) ((Subscript[y, i])+(Subscript[y, j]))))+(Sqrt[(Subscript[B, i])]) (((Subscript[x, i])+(Subscript[x, j])) (Subscript[y, j])-Fij γ ℏ (Subscript[b, i]) ((Subscript[x, i]) (Subscript[y, j])+(Subscript[x, j]) ((Subscript[y, i])+(Subscript[y, j]))))))/(γ (Subscript[b, i]) (Subscript[b, j]) ((Subscript[b, i])+(Subscript[b, j])) (Sqrt[(Subscript[B, i])]) (1-(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (-1+(Subscript[B, i]) (Subscript[B, j])))),((ω[(Subscript[B, i]),(Subscript[B, j])])^(-1))] /. Fij->Fij[(Subscript[B, i]),(Subscript[B, j])];
(Subscript[(OverBar[V0]), i,j])

(Subscript[(OverBar[V0]), -1,-2])(Subscript[V0, 1,2])// (Subscript[cm, -1,1->1])//(Subscript[cm, -2,2->2])

Define[(Subscript[V0, i,j])=CF@(Subscript[𝔼, {}->{i,j}])[(1/2) ℏ (Subscript[a, j]) (Subscript[b, i]),(1/(γ (Subscript[b, i]^2) (Subscript[b, j]) (-1+(Subscript[B, i]) (Subscript[B, j]))))((Subscript[b, 2]) (Subscript[b, j]) (-1+(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (1-(Subscript[B, i]) (Subscript[B, j]))) (Subscript[x, i]) (Subscript[y, i])+(Subscript[b, i]) ((Subscript[b, i]) ((-1+Fij γ ℏ (Subscript[b, i])) (Subscript[x, j])+(Sqrt[(Subscript[B, i])]) (Subscript[x, j])-(Subscript[B, i]^(3/2)) (Subscript[B, j]) (Subscript[x, j])+(Subscript[B, i]) ((-1+(Subscript[B, j])) (Subscript[x, i])+(1-Fij γ ℏ (Subscript[b, i])) (Subscript[B, j]) (Subscript[x, j]))) (Subscript[y, j])+(Subscript[b, j]) ((Subscript[x, i]) (Subscript[y, j])-Fij γ ℏ (Subscript[b, i]) ((Subscript[x, j]) (Subscript[y, i])+(Subscript[x, i]) (Subscript[y, j]))+(Subscript[B, i]) (Fij γ ℏ (Subscript[b, i]) (Subscript[B, j]) (Subscript[x, j]) (Subscript[y, i])+(Subscript[x, i]) (-(-1+(Subscript[B, j])) (Subscript[y, i])+(-1+Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[y, j])))))),ω[(Subscript[B, i]),(Subscript[B, j])]] /. Fij->0];
(Subscript[V0, i,j])

Define[(Subscript[(OverBar[V0]), i,j])=CF@(Subscript[𝔼, {}->{i,j}])[-(1/2) ℏ (Subscript[a, j]) (Subscript[b, i]),((Subscript[b, j]^2) (Sqrt[(Subscript[B, i])]) (-1+(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (1-(Subscript[B, i]) (Subscript[B, j]))) (Subscript[x, i]) (Subscript[y, i])+(Subscript[b, i]^2) ((Subscript[B, i]^(3/2)) ((-1+(Subscript[B, j])) (Subscript[x, i])-(Subscript[x, j]))+(-1+Fij γ ℏ (Subscript[b, i])) (Subscript[x, j])+(Sqrt[(Subscript[B, i])]) (Subscript[x, j])+(Subscript[B, i]) (1-Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[x, j])) (Subscript[y, j])+(Subscript[b, i]) (Subscript[b, j]) ((-1+Fij γ ℏ (Subscript[b, i])) (Subscript[x, j]) (Subscript[y, j])+(Subscript[B, i]) (1-Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[x, j]) (Subscript[y, j])+(Subscript[B, i]^(3/2)) ((Subscript[x, i]) (-(-1+(Subscript[B, j])) (Subscript[y, i])+(-1+Fij γ ℏ (Subscript[b, i]) (Subscript[B, j])) (Subscript[y, j]))+(Subscript[x, j]) (-(Subscript[y, j])+Fij γ ℏ (Subscript[b, i]) (Subscript[B, j]) ((Subscript[y, i])+(Subscript[y, j]))))+(Sqrt[(Subscript[B, i])]) (((Subscript[x, i])+(Subscript[x, j])) (Subscript[y, j])-Fij γ ℏ (Subscript[b, i]) ((Subscript[x, i]) (Subscript[y, j])+(Subscript[x, j]) ((Subscript[y, i])+(Subscript[y, j]))))))/(γ (Subscript[b, i]) (Subscript[b, j]) ((Subscript[b, i])+(Subscript[b, j])) (Sqrt[(Subscript[B, i])]) (1-(Subscript[B, i])+Fij γ ℏ (Subscript[b, i]) (-1+(Subscript[B, i]) (Subscript[B, j])))),((ω[(Subscript[B, i]),(Subscript[B, j])])^(-1))] /. Fij->0];
(Subscript[(OverBar[V0]), i,j])

Define[(Subscript[Φ0, i,j,k])=Module[{s1,s2,s3},
((((Subscript[(OverBar[V0]), i,k])//(Subscript[cΔ, i->i,j]))(Subscript[(OverBar[V0]), s1,s2])//(Subscript[cm, i,s1->i])//(Subscript[cm, j,s2->j]))(Subscript[V0, s2,s3])//(Subscript[cm, j,s2->j])//(Subscript[cm, k,s3->k]))((Subscript[V0, s1,s2])//(Subscript[cΔ, s2->s2,s3]))//(Subscript[cm, i,s1->i])//(Subscript[cm, j,s2->j])//(Subscript[cm, k,s3->k])
]];
(Subscript[Φ0, i,j,k])

lhs=((Subscript[Φ0, 1,2,3])((Subscript[Φ0, -1,-2,4])//(Subscript[cΔ, -2->-2,-3]))//(Subscript[cm, 1,-1->1])//(Subscript[cm, 2,-2->2])//(Subscript[cm, 3,-3->3]))(Subscript[Φ0, -2,-3,-4])//(Subscript[cm, 2,-2->2])//(Subscript[cm, 3,-3->3])//(Subscript[cm, 4,-4->4])

rhs=((Subscript[Φ0, 1,3,4])//(Subscript[cΔ, 1->1,2]))((Subscript[Φ0, -1,-2,-3])//(Subscript[cΔ, -3->-3,-4]))//(Subscript[cm, 1,-1->1])//(Subscript[cm, 2,-2->2])//(Subscript[cm, 3,-3->3])//(Subscript[cm, 4,-4->4])

Simplify[lhs≡rhs]

(Subscript[cΔ, 1->1,2])