SetDirectory["C:/drorbn/AcademicPensieve/Projects/Arrow_Diagrams_and_gl(N)"];
<< "Arrow_Diagrams_and_gl(N).m"

se[1,i,j] stands for Aij;
se[2,i,j] stands for Bij;
se[3,i,j] stands for Dij.
Commutation relations come from http://katlas.math.toronto.edu/drorbn/bbs/show?shot=Leung-090227-132523.jpg

sbase=10;
sij[salpha_Integer] := IntegerDigits[salpha, sbase, 3];
salpha[{t_, i_, j_}] := sbase^2*t+sbase*i+j;
salpha[t_, i_, j_] := sbase^2*t+sbase*i+j;
b[se[salpha1_], se[salpha2_]] := b[se[salpha1], se[salpha2]]= Module[
{d,t1,t2,i,j,k,l, s=1},
d[i_,j_] := If[i==j, 1, 0];
{t1, i,j} = sij[salpha1];
{t2, k,l} = sij[salpha2];
If[t2<t1, s=-1; {{t1, i,j}, {t2, k,l}} = {{t2, k,l}, {t1, i,j}}];
{
{
d[j,k]se[1,i,l]-d[i,l]se[1,k,j],
d[j,k]se[2,i,l]-d[j,l]se[2,i,k],
d[i,k]se[3,l,j]+d[l,i]se[3,j,k]
},
{
Null,
0,
d[j,l]se[1,i,k]+d[i,k]se[1,j,l]-d[j,k]se[1,i,l]-d[i,l]se[1,j,k]
},
{
Null,
Null,
0
}
}[[t1,t2]] /. {
se[2|3,i_,i_] -> 0,
se[2, i_, j_] /; i>j :> -se[2,j,i],
se[3, i_, j_] /; i>j :> -se[3,j,i]
} /. se[tij__] :> s*se[salpha[tij]]
];
(a_Plus)**w_RSW := (#**w)& /@ a;
se[alpha_] ** (a_Plus) := (se[alpha]**#)& /@ a;
(c_*se[alpha_])**w_RSW := Expand[c*(se[alpha]**w)];
se[alpha_] ** (c_*w_RSW) := Expand[c*(se[alpha]**w)];
se[alpha_]**RSW[] := RSW[alpha];
se[alpha_]**RSW[beta_, rest___] /; alpha≤ beta := RSW[alpha, beta, rest];
se[alpha_]**RSW[beta_, rest___] /; alpha> beta := Plus[
se[beta]**(se[alpha]**RSW[rest]),
b[se[alpha], se[beta]]**RSW[rest]
];

Clear[USO];
USO[diag_Diag] := Module[
{allterms, s, LTAt, BDAt, EQAt, CAt, m1, m2, dirs, coeff, k, ltpairs, w, allots},
allterms= List@@Expand[(Times @@ diag) /. ar[p_,q_] :> 
LTAt[p,q] + BDAt[p,q]+1/2(EQAt[p,q] - CAt[p]+CAt[q]-CAt[])
];
s=Sum[
dirs=allterms[[m1]]; (* "dirs" is "directions" *)
coeff= dirs /. (_CAt|_EQAt|_LTAt|_BDAt)-> 1;
k=0;
w= Table[1, {2Length[diag]}];
ltpairs = {};
dirs /. {
LTAt[p_,q_] :> (
w[[p]] = se[1, i=++k, j=++k];
w[[q]] = se[1, j,i];
AppendTo[ltpairs, {i,j}];
),
BDAt[p_,q_] :> (
w[[p]] = se[2, i=++k, j=++k];
w[[q]] = se[3, i,j];
AppendTo[ltpairs, {i,j}];
),
EQAt[p_, q_] :> (w[[p]] = w[[q]] = se[1,i=++k, i];),
CAt[p_] :> (
w[[p]] = se[1, i=++k, i];
coeff *= h[i];
),
CAt[] :> (coeff *= h[++k]^2;)
};
w = DeleteCases[w, 1];
allots = OrderTypes[k, ltpairs];
Sum[
ot=allots[[m2]];
Times[
n^Max[ot],
coeff /. h[i_] :> h[ot[[i]]],
SW@@w /. se[t_, i_, j_] :> salpha[t, ot[[i]], ot[[j]]]
],
{m2, Length[allots]}
], {m1, Length[allterms]}
];
If[Length[diag]≤3,
USO[diag] = CanonicalForm[Expand[s]],
CanonicalForm[Expand[s]]
]
];
USO[expr_] := Expand[expr /. diag_Diag :> USO[diag]];

Testing

bb[spe1_,spe2_,spe3_] := Expand[b[spe1, spe2] /. spe0_spe :> b[spe0, spe3]];
Jac[spe1_,spe2_,spe3_] := bb[spe1, spe2, spe3] + bb[spe2, spe3, spe1] + bb[spe3, spe1, spe2]

b[spe[111], spe[112]]

bb[spe[111], spe[112], spe[112]]

Jac[spe[111], spe[114], spe[214]]

Jac[spe[213],spe[321],spe[113]]

Union[Flatten[Outer[
(Jac[
spe[spalpha[#1[[1]], #2[[1]], #2[[2]]]],
spe[spalpha[#1[[2]], #2[[3]], #2[[4]]]],
spe[spalpha[#1[[3]], #2[[5]], #2[[6]]]]
]*
J[
spe[spalpha[#1[[1]], #2[[1]], #2[[2]]]],
spe[spalpha[#1[[2]], #2[[3]], #2[[4]]]],
spe[spalpha[#1[[3]], #2[[5]], #2[[6]]]]
])&,
 OrderTypes[3], OrderTypes[6], 1
]]]

{s1,s2,s3}={se[111],se[313],se[223]}

Jac[s1,s2,s3]

b[s1,s2]

Diagrams[2ar]

USp[Diag[ar[1,2]]]

lc=R[Diag[ R6T[1,2,3]]]

USp[lc]

USp[Take[R/@ Diagrams[1ar+ R6T], 2]]

USp[R[Diagrams[2ar+R6T][[23]]]]

l=Length[rels=R/@ Diagrams[1ar+ R6T]]

USO[List @@ rels[[1]]]

Total[USO[List @@ rels[[1]]]]

Table[
Print[{ind,rels[[ind]], usp=USp[rels[[ind]]]}];
usp,
{ind,l}
]

SetDirectory["/scratch/leung"]

SaveUSp[diag_Diag] := Module[
{fname},
fname= StringJoin[
"USpFor",
ToString[FromDigits[Cases[diag, _Integer, Infinity], spbase]],
".m"
];
Print["Saving ", fname, " ..."];
Put[{diag, USp[diag]},fname];
]

basis=BasisAArrow[4]

Timing[USO[Diag[ar[2,5],ar[6,3],ar[4,1]]]]
Timing[USp[Diag[ar[2,5],ar[6,3],ar[4,1]]]]

diag=Diag[ar[2,5],ar[6,3],ar[7,1],ar[8,4]]

Timing[USO[diag]]
MaxMemoryUsed[]
Timing[USp[diag]]
MaxMemoryUsed[]

16236/60.

SetDirectory["/scratch/leung"]

Directory[]

For[index=2,index≤Length[basis],index++,
Print[index," ",basis[[index]]];
Timing[SaveUSp[basis[[index]]]]
];

Table[
Print[{ind,rels[[ind]], usp=USp[rels[[ind]]]}];
usp,
{ind,l}
]

Directory[]

basis=BasisAArrow[4];

For[index=19,index≤Length[basis],index++,
Print[index," ",basis[[index]]];
Timing[SaveUSp[basis[[index]]]]
];

basis[[67]]

basis[[66]]

For[index=67,index≤Length[basis],index++,
Print[index," ",basis[[index]]];
Timing[SaveUSp[basis[[index]]]]
];

basis[[19]]

basis

SetDirectory["/scratch/leung"]

Directory[]

SaveUSp[Diag[ar[5,1],ar[6,4],ar[7,3],ar[8,2]]];
SaveUSp[Diag[ar[5,3],ar[6,2],ar[7,1],ar[8,4]]];
For[index=71,index≤Length[basis],index++,
Print[index," ",basis[[index]]];
Timing[SaveUSp[basis[[index]]]]
];

SetDirectory["/scratch/leung"]

Directory[]

For[index=115,index≤Length[basis],index++,
Print[index," ",basis[[index]]];
Timing[SaveUSp[basis[[index]]]]
];