ΓCollect[Γ[ω_, λ_]] := Γ[Simplify[ω],
Collect[λ, (Subscript[h, _]), Collect[#,(Subscript[t, _]), Factor]&]];
Format[Γ[ω_,λ_]] := Module[{S, M},
S = Union@Cases[Γ[ω,λ], (Subscript[(h|t), a_]) :> a, ∞];
M = Outer[Factor[(∂_((Subscript[h, #1]),(Subscript[t, #2])))λ]&, S, S];
M = Prepend[M, (Subscript[t, #])& /@ S] // Transpose;
M = Prepend[M, Prepend[(Subscript[h, #])& /@ S, ω]];
M // MatrixForm];

Γ /: Γ[ω1_, λ1_]Γ[ω2_, λ2_] := Γ[ω1*ω2, λ1+λ2];
(Subscript[m, a_,b_->c_])[Γ[ω_, λ_]] := Module[{α,β,γ,δ,θ,ϵ,ϕ,ψ,Ξ,μ},
(({{α, β, θ}, {γ, δ, ϵ}, {ϕ, ψ, Ξ}}))=(({{(∂_((Subscript[t, a]),(Subscript[h, a])))λ, (∂_((Subscript[t, a]),(Subscript[h, b])))λ, (∂_(Subscript[t, a]))λ}, {(∂_((Subscript[t, b]),(Subscript[h, a])))λ, (∂_((Subscript[t, b]),(Subscript[h, b])))λ, (∂_(Subscript[t, b]))λ}, {(∂_(Subscript[h, a]))λ, (∂_(Subscript[h, b]))λ, λ}}))/.(Subscript[(t|h), a|b])->0;
Γ[(μ=1-β)ω, {(Subscript[t, c]),1}.(({{γ+α δ/μ, ϵ+δ θ/μ}, {ϕ+α ψ/μ, Ξ+ψ θ/μ}})).{(Subscript[h, c]),1}]
/. {(Subscript[T, a])->(Subscript[T, c]), (Subscript[T, b])->(Subscript[T, c])} // ΓCollect];
(Subscript[Rp, a_,b_]) := Γ[1, {(Subscript[t, a]),(Subscript[t, b])}.(({{(Subscript[T, a]), 0}, {1-(Subscript[T, a]), 1}})).{(Subscript[h, a]),(Subscript[h, b])}];
(Subscript[Rm, a_,b_]) := (Subscript[Rp, a,b]) /. (Subscript[T, a])->1/(Subscript[T, a]);

ζ=Γ[ω, {(Subscript[t, 1]),(Subscript[t, 2]),(Subscript[t, 3]),(Subscript[t, S])}.(({{(Subscript[α, 11]), (Subscript[α, 12]), (Subscript[α, 13]), (Subscript[θ, 1])}, {(Subscript[α, 21]), (Subscript[α, 22]), (Subscript[α, 23]), (Subscript[θ, 2])}, {(Subscript[α, 31]), (Subscript[α, 32]), (Subscript[α, 33]), (Subscript[θ, 3])}, {(Subscript[ϕ, 1]), (Subscript[ϕ, 2]), (Subscript[ϕ, 3]), Ξ}})).{(Subscript[h, 1]),(Subscript[h, 2]),(Subscript[h, 3]),(Subscript[h, S])}]

(ζ//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))==(ζ//(Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

{(Subscript[Rm, 5,1])(Subscript[Rm, 6,2])(Subscript[Rp, 3,4])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]),
 (Subscript[Rp, 6,1])(Subscript[Rm, 2,4])(Subscript[Rm, 3,5])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3])}

z=(Subscript[Rm, 12,1])(Subscript[Rm, 2,7])(Subscript[Rm, 8,3])(Subscript[Rm, 4,11])(Subscript[Rp, 16,5])(Subscript[Rp, 6,13])(Subscript[Rp, 14,9])(Subscript[Rp, 10,15]);
Do[z= z // (Subscript[m, 1,k->1]), {k,2,16}];z

(Subscript[tr, c_])[Γ[ω_,λ_]] := Module[{α,θ,ψ,Ξ},
(({{α, θ}, {ψ, Ξ}}))=(({{(∂_((Subscript[t, c]),(Subscript[h, c])))λ, (∂_(Subscript[t, c]))λ}, {(∂_(Subscript[h, c]))λ, λ}}))/.(Subscript[(t|h), c])->0;
Γ[ω(1-α),Ξ+ψ*θ/(1-α)]// ΓCollect];
(ζ//(Subscript[m, 1,2->1])//(Subscript[tr, 1]))==(ζ//(Subscript[m, 2,1->1])//(Subscript[tr, 1]))

((Subscript[Rp, 1,2])(Subscript[Rp, 4,5])(Subscript[Rp, 6,3])(Subscript[Rp, 7,8])(Subscript[Rm, 10,9])//(Subscript[m, 2,4->2])//(Subscript[m, 2,6-> 2])//(Subscript[m, 2,8-> 2])//(Subscript[m, 2,9-> 2])//(Subscript[m, 10,2-> 2])//(Subscript[m, 3,7-> 3])//(Subscript[m, 5,1-> 1]))/.{(Subscript[T, 1])->T,(Subscript[T, 2])-> T,(Subscript[T, 3])-> T}

UnitaryQ[Γ_,Ep_]:=Module[{n,P,B,F,Tp,Bs,Tps,JB,JT,τ,Id,Blist,Tplist},
n=Length[Ep]/2;
Id=IdentityMatrix[n];
P=Partition[Ep,n];
B=P[[1]];Tp=Reverse[P[[2]]];
Bs=B/.{(Subscript[x, _])-> 1,(Subscript[y, _])-> -1};
Tps=Tp/.{(Subscript[x, _])-> -1,(Subscript[y, _])-> 1};
Bi[l_]:=Which[l[[1]]<l[[2]],2-(T+(T^(-1))),l[[1]]>l[[2]],-2+(T+(T^(-1))),True,1];
BiF[l_]:=(F=Map[Bi,Table[{i,j},{i,1,n},{j,1,n}],{2}];
Do[If[l[[i]]>0,F[[i,i]]=T-(T^(-1)),F[[i,i]]=(T^(-1))-T],{i,1,n}];F);
JB=BiF[Bs];JT=BiF[Tps];
Blist=B/.{(Subscript[x, i_])-> {x,i},(Subscript[y, j_])-> {y,j}};
Do[If[Blist[[i,1]]===x,Blist[[i]]=Id[[Blist[[i,2]]]],Blist[[i]]=-Γ[[Blist[[i,2]]]]],{i,1,Length[Blist]}];
Tplist=Tp/.{(Subscript[x, i_])-> {x,i},(Subscript[y, j_])-> {y,j}};
Do[If[Tplist[[i,1]]===x,Tplist[[i]]=-Id[[Tplist[[i,2]]]],Tplist[[i]]=Γ[[Tplist[[i,2]]]]],{i,1,Length[Tplist]}];
τ=Join[Blist,Tplist];
ContainsOnly[Flatten[Transpose[τ].ArrayFlatten[{{-JB,0},{0,JT}}].(τ/.T-> (T^(-1)))//Simplify],{0}]
]

P=(({{-(1/(-2+T)), ((-1+T)/((-2+T) T)), 0}, {(((-1+T) (1-T+(T^2)))/(-2+T)), -((-1+2 T)/((-2+T) T)), 1-T}, {-(((((-1+T))^2) T)/(-2+T)), ((-1+T)/(-2+T)), T}}))

UnitaryQ[P,{(Subscript[y, 1]),(Subscript[x, 1]),(Subscript[x, 3]),(Subscript[y, 3]),(Subscript[x, 2]),(Subscript[y, 2])}]

UnitaryQ[P,{(Subscript[y, 2]),(Subscript[y, 1]),(Subscript[x, 1]),(Subscript[x, 3]),(Subscript[y, 3]),(Subscript[x, 2])}]

UnitaryQ[P,{(Subscript[x, 2]),(Subscript[y, 2]),(Subscript[y, 1]),(Subscript[x, 1]),(Subscript[x, 3]),(Subscript[y, 3])}]

((Subscript[Rp, 9,1])(Subscript[Rp, 3,8])(Subscript[Rp, 4,11])(Subscript[Rp, 12,5])(Subscript[Rp, 6,13])(Subscript[Rp, 10,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,4-> 1])//(Subscript[m, 1,5-> 1])//(Subscript[m, 1,6-> 1])//(Subscript[m, 2,8-> 2])//(Subscript[m, 2,9->2])//(Subscript[m, 2,10->2])//(Subscript[m, 2,11->2])//(Subscript[m, 2,12-> 2])//(Subscript[m, 2,13->2]))/.{(Subscript[T, i_])-> T}//Simplify

Q=(({{T (1-T+(T^2)-(T^3)+(T^4)), -(-1+T) T (1+(T^2))}, {-(-1+T) (1-T+(T^2)) (1+T+(T^2)), 1-T+(T^2)-(T^3)+(T^4)}}));

UnitaryQ[Q,{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[y, 1]),(Subscript[y, 2])}]