q-Clebsch-Gordan coefficients for su(2)_k

E. Ardonne & J.K. Slingerland
Based on: V.A.Groza, I.I.Kachurik, A.U.Klimyk, J.Math.Phys.31, 2769 (1990).

Display of qCG - coefficients

Manipulate[
If[j1>k1/2,j1=k1/2];
If[j2>k1/2,j2=k1/2];If[Not[MemberQ[fusion[j1,j2,k1],j3]],j3=fusion[j1,j2,k1][[1]]];If[show<-j3||show>j3||Mod[show,1]≠Mod[j3,1],show=all];
If[Not[MemberQ[Prepend[Cases[Table[i,{i,1,(k1+2)/2}],x_/;GCD[x,k1+2]==1],0],p1]],p1=1];Column[{Row[{Style["Rows labeled by m1, columns by m2; m3=m1+m2"]}],
If[show===all,
MatrixForm[Table[If[-j3≤m1+m2≤j3,Chop[qcg[j1,m1,j2,m2,j3,m1+m2,If[p1==0,1,Exp[2. p1 Pi I/(k1+2)]]]],"."],{m1,-j1,j1},{m2,-j2,j2}],TableHeadings->{Table[m1,{m1,-j1,j1}],Table[m2,{m2,-j2,j2}]}],
MatrixForm[Table[If[m1+m2==show,Chop[qcg[j1,m1,j2,m2,j3,m1+m2,If[p1==0,1,Exp[2.p1  Pi I/(k1+2)]]]],"."],{m1,-j1,j1},{m2,-j2,j2}],TableHeadings->{Table[m1,{m1,-j1,j1}],Table[m2,{m2,-j2,j2}]}]
]}],
{{k1,8,"k"},1,12,1,SetterBar},
{{j1,2},values[k1]},
{{j2,2},values[k1]},
{{j3,2},fusion[j1,j2,k1]},{{p1,1,"q"},Table[j->Exp[2 j I Pi/(k1+2)],{j,Prepend[Cases[Table[i,{i,1,(k1+2)/2}],x_/;GCD[x,k1+2]==1],0]}]},Style["Display the following m3 value(s)"],{{show,all,""},Prepend[Table[m33,{m33,-j3,j3,1}],all->Style["All"]]},
ControlType->SetterBar,SaveDefinitions->True]

Initialization

qn[n_,q_]:=Sum[q^(((n+1)/2-i)),{i,1,n}]
qnf[n_,q_]:=Product[qn[i,q],{i,1,n}]
fusion[i_,j_,k_]:=Table[l,{l,Abs[i-j],Min[i+j,k-i-j]}]
delta[a_,b_,c_,q_]:=If[Abs[a-b]≤c≤a+b&&Mod[a+b+c,1]==0,Sqrt[qnf[a+b-c,q]qnf[a-b+c,q]qnf[-a+b+c,q]/qnf[a+b+c+1,q]],0]
qcg[a_,j_,b_,k_,c_,m_,q_]:=q^(((a+b-c)(a+b+c+1)+2(a k-b j))/4)delta[a,b,c,q]Sqrt[qnf[a-j,q]qnf[a+j,q]qnf[b-k,q]qnf[b+k,q]qnf[c-m,q]qnf[c+m,q]qn[2c+1,q]]Sum[(-1)^n q^(-n(a+b+c+1)/2)1/(qnf[n,q]qnf[a+b-c-n,q]qnf[a-j-n,q]qnf[b+k-n,q]qnf[c-b+j+n,q]qnf[c-a-k+n,q]),{n,Max[0,-(c-b+j),-(c-a-k)],Min[a+b-c,a-j,b+k]}]
qrw[i_,j_,l_,m_,k_,n_,q_]:=delta[i,j,k,q]delta[i,m,n,q]delta[j,l,n,q]delta[k,l,m,q]Sum[(-1)^z qnf[z+1,q]/(qnf[z-i-j-k,q]qnf[z-i-m-n,q]qnf[z-j-l-n,q]qnf[z-k-l-m,q]qnf[i+j+l+m-z,q]qnf[i+k+l+n-z,q]qnf[j+k+m+n-z,q]),{z,Max[i+j+k,i+m+n,j+l+n,k+l+m],Min[i+j+l+m,i+k+l+n,j+k+m+n]}]
q6j[i_,j_,l_,m_,k_,n_,q_]:=qrw[i,j,l,m,k,n,q]Sqrt[qn[2k+1,q]]Sqrt[qn[2n+1,q]]Exp[Pi I(i+j+l+m)]
values[k_]:=Table[i,{i,0,k/2,1/2}]
dvalues[a_,b_,c_,k_]:=Union[Flatten[Table[fusion[c,i,k],{i,fusion[a,b,k]}]]]
evalues[a_,b_,c_,d_,k_]:=Cases[fusion[a,b,k],x_/;MemberQ[fusion[x,c,k],d]]
fvalues[a_,b_,c_,d_,k_]:=Cases[fusion[b,c,k],x_/;MemberQ[fusion[a,x,k],d]]