(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
Print["Copyright(C)2010 Yoshifumi Hyakutake"]
Print["All rights are reserved."];


(* ::Input::Initialization:: *)
Vielbein /: Vielbein:=
Module[{T,tvb,iv,tiv,lvb,gd,gu,\[Mu],a},

tvb=Transpose[vb];                             (* tvb=Subscript[e, \[Mu]]^a *)
iv=Inverse[vb];                                    (* iv=Subscript[e^\[Mu], a] *)
tiv=Transpose[iv];                             (* tiv=Subscript[e, a]^\[Mu] *)
lvb=eta.vb;                                             (* lvb=Subscript[e, a\[Mu]] *)
gd=tvb.eta.vb;                                      (* gd=Subscript[g, \[Mu]\[Nu]] *)
gu=Inverse[gd];                                    (* gu=g^\[Mu]\[Nu] *)
{tvb,iv,tiv,lvb,gd,gu}=Expand[{tvb,iv,tiv,lvb,gd,gu}];

Do[T=Sum[vb[[a,\[Mu]]]dX[[\[Mu]]],{\[Mu],1,dim}];
     Print[ee[[a]]," = ",T];
,{a,1,dim}];                                       (* Subscript[e^a, \[Mu]]dx^\[Mu] *)

{tvb,iv,tiv,lvb,gd,gu}
];


(* ::Input::Initialization:: *)
Connection /: Connection:=
Module[{de,T,Sd,Sl,\[Mu],a,b,c},

de=Table[D[lvb,cd[[\[Mu]]]],{\[Mu],1,dim}];                                                                                                                (* de=\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Mu]\)]
\*SubscriptBox[\(e\), \(a\[Nu]\)]\) *)
Sd=1/2Transpose[de.iv,{1,3,2}]-1/2Transpose[tiv.de,{2,3,1}]-1/2de.iv+1/2Transpose[tiv.de,{3,2,1}]-1/2tvb.(Transpose[tiv.de.iv,{2,1,3}])+1/2tvb.(Transpose[tiv.de.iv,{3,1,2}]);      (* Sd=Subscript[\[Omega], \[Mu]ab] *)
Sl=tiv.Sd;                                                                                                                                                                                 (* Sl=Subscript[\[Omega], cab] *)
{Sd,Sl}=Expand[{Sd,Sl}];

Do[T=Sum[Sl[[c,a,b]]ee[[c]],{c,1,dim}];
     If[T=!=0,Print[Subscript[\[Omega],StringJoin[id[[a]],id[[b]]]]," = ",T] ];
,{a,1,dim},{b,a+1,dim}];                                          (* Subscript[\[Omega], cab]e^c *)

{Sd,Sl}
];


(* ::Input::Initialization:: *)
Riemann /: Riemann:=
Module[{T,domg,omg2,Rd,Rl,Rc,Rs,Eg1,\[Mu],\[Nu],a,b,c,d},

T=Table[D[Sd,cd[[\[Mu]]]],{\[Mu],1,dim}];                                                                          (* T=\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Mu]\)]
\*SubscriptBox[\(\[Omega]\), \(\[Nu]ab\)]\) *)
domg=Transpose[T,{3,4,1,2}]-Transpose[T,{4,3,1,2}];                         (* domg=part of Subscript[R, ab\[Mu]\[Nu]]=\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Mu]\)]
\*SubscriptBox[\(\[Omega]\), \(\[Nu]ab\)]\)-\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Nu]\)]
\*SubscriptBox[\(\[Omega]\), \(\[Mu]ab\)]\) *)
T=Transpose[Sd,{2,1,3}];(* Subscript[T, a\[Mu]b]=Subscript[\[Omega], \[Mu]ab] *)
omg2=Transpose[Sd.eta.T,{3,1,4,2}]-Transpose[Sd.eta.T,{4,1,3,2}];                       (* omg2=part of Subscript[R, ab\[Mu]\[Nu]]=Subscript[\[Omega], \[Mu]a]^cSubscript[T, c\[Nu]b]-Subscript[\[Omega], \[Nu]a]^cSubscript[T, c\[Mu]b] *)

Rd=domg+omg2;                                                                                                                             (* Rd=Subscript[R, ab\[Mu]\[Nu]] *)
Rl=Transpose[tiv.Transpose[Rd,{2,3,1,4}].iv,{3,1,2,4}];                 (* Rl=Subscript[R, abcd] *)
T=Rl.eta;
Rc=Table[Sum[T[[a,c,b,c]],{c,1,dim}],{a,1,dim},{b,1,dim}];   (* Rc=Subscript[R, ab] *)
T=Rc.eta;
Rs=Sum[T[[a,a]],{a,1,dim}];                                                                                        (* Rs=R *)
{Rd,Rl,Rc,Rs,Eg1}=Expand[{Rd,Rl,Rc,Rs,Eg1}];

Do[If[Rl[[a,b,c,d]]=!=0,
Print[Subscript[R,StringJoin[id[[a]],id[[b]],id[[c]],id[[d]]]]," = ",Rl[[a,b,c,d]] ]];
,{a,1,dim},{b,a+1,dim},{c,1,dim},{d,c+1,dim}];
Do[If[Rc[[a,b]]=!=0,Print[Subscript[R,StringJoin[id[[a]],id[[b]]]]," = ",Rc[[a,b]] ]];
,{a,1,dim},{b,a,dim}];
Print[R," = ",Rs];

{Rd,Rl,Rc,Rs}
];


(* ::Input::Initialization:: *)
GaugeField /: GaugeField[Fl_]:=
Module[{n,P1,P2,cnt,T,Fd,Fu,Fc,Fs,Eg2,EA1,a,b,c1,c2,c3,c4,c5,c6,c7,c8,c9},

(* Fl=Subscript[F, Subscript[a, 1]Subscript[a, 2]...Subscript[a, n]] *)
n=TensorRank[Fl];
Fd=Fl;Fu=Fl;
Do[P1=Table[v,{v,1,n}] /. {1->u,u->1};
     Fd=Transpose[tvb.Transpose[Fd,P1],P1];                                                                             (* Fd=Subscript[F, Subscript[\[Mu], 1]...Subscript[\[Mu], n]] *)
     Fu=Transpose[iv.eta.Transpose[Fu,P1],P1];                                                                       (* Fu=F^(Subscript[\[Mu], 1]...Subscript[\[Mu], n]) *)
,{u,1,n}];
cnt={c1,c2,c3,c4,c5,c6,c7,c8,c9};
P1=Join[{a},Take[cnt,n-1]];P2=Join[{b},Take[cnt,n-1]];
Fc=TensorProd[{{Fl,P1},{Fl,P2}},eta][[1]];                                                                 (* Fc=Subscript[F, Subscript[ac, 2]...Subscript[c, n]]Subscript[F, b]^(Subscript[c, 2]...Subscript[c, n]) *)
T=Fc.eta;
Fs=Sum[T[[a,a]],{a,1,dim}];                                                                                                          (* Fs=Subscript[F, Subscript[c, 1]...Subscript[c, n]]F^(Subscript[c, 1]...Subscript[c, n]) *)
{Fd,Fu,Fc,Fs}=Expand[{Fd,Fu,Fc,Fs}];

{Fd,Fu,Fc,Fs}
];


(* ::Input::Initialization:: *)
Hfield /: Hfield[CS_]:=
Module[{T,Hd,Hu,Hg,Hl,Hc,Hs,\[Mu],\[Nu],\[Rho],a,b,c},

Hd=Table[D[Bg[[\[Nu],\[Rho]]],cd[[\[Mu]]]]+D[Bg[[\[Rho],\[Mu]]],cd[[\[Nu]]]]+D[Bg[[\[Mu],\[Nu]]],cd[[\[Rho]]]]
,{\[Mu],1,dim},{\[Nu],1,dim},{\[Rho],1,dim}];                                                                                           (* Subscript[H, \[Mu]\[Nu]\[Rho]] *)
Hd=Hd+CS;
Hu=gu.Transpose[gu.Transpose[Hd,{2,1,3}].gu,{2,1,3}];(* H^\[Mu]\[Nu]\[Rho]=g^\[Mu]\[Alpha]Subscript[Y, \[Alpha]]^\[Nu]\[Rho]=g^\[Mu]\[Alpha]g^\[Nu]\[Beta]Subscript[X, \[Beta]\[Alpha]\[Gamma]]g^\[Gamma]\[Rho]=g^\[Mu]\[Alpha]g^\[Nu]\[Beta]Subscript[H, \[Alpha]\[Beta]\[Gamma]]g^\[Gamma]\[Rho] *)
Hg=Transpose[tiv.Transpose[Hd,{2,1,3}].iv,{2,1,3}];(* Subscript[H, \[Mu]ab] *)
Hl=tiv.Hg;                                                                                                                                                              (* Subscript[H, cab] *)
T=Hl.eta.Hl.eta;
Hc=Table[Sum[T[[a,c,b,c]],{c,1,dim}],{a,1,dim},{b,1,dim}];                           (* Subscript[H, acd]Subscript[H, b]^cd *)
T=Hc.eta;
Hs=Sum[T[[a,a]],{a,1,dim}];                                                                                                                (* Subscript[H, abc]H^abc *)
{Hd,Hu,Hg,Hl,Hc,Hs}=Expand[{Hd,Hu,Hg,Hl,Hc,Hs}];

Do[T=Sum[Hl[[c,a,b]]ee[[c]],{c,1,dim}];
     If[T=!=0,Print[Subscript[H,StringJoin[id[[a]],id[[b]]]]," = ",T] ];
,{a,1,dim},{b,a+1,dim}];                                                                                                                  (* Subscript[Subscript[H, c], ab]e^c *)

{Hd,Hu,Hc,Hs}
];


(* ::Input::Initialization:: *)
Dilaton /: Dilaton:=
Module[{T,S,Pc,Ps,Kc,Ks,\[Mu],a,b},

T=Table[D[Exp[-2 Phi],cd[[\[Mu]]]],{\[Mu],1,dim}];T=tiv.T;
S=Table[D[T[[b]],cd[[\[Mu]]]] ,{\[Mu],1,dim},{b,1,dim}];
Pc=Exp[2 Phi](tiv.S+ Sl.eta.T);                                                                          (* e^(2\[CapitalPhi])Subscript[D, a]\!\(
\*SubscriptBox[\(\[PartialD]\), \(b\)]
\*SuperscriptBox[\(e\), \(\(-2\)\[CapitalPhi]\)]\) *)
T=Pc.eta;
Ps=Sum[T[[a,a]],{a,1,dim}];                                                                              (* e^(2\[CapitalPhi])Subscript[D, c]\[PartialD]^ce^(-2\[CapitalPhi]) *)
T=Table[D[Phi,cd[[\[Mu]]]],{\[Mu],1,dim}];T=tiv.T;
Kc=Table[T[[a]]T[[b]],{a,1,dim},{b,1,dim}];                                      (* \!\(
\*SubscriptBox[\(\[PartialD]\), \(a\)]\[CapitalPhi]\)\!\(
\*SubscriptBox[\(\[PartialD]\), \(b\)]\[CapitalPhi]\) *)
T=Kc.eta;
Ks=Sum[T[[a,a]],{a,1,dim}];                                                                              (* \!\(
\*SubscriptBox[\(\[PartialD]\), \(c\)]\[CapitalPhi]\)\[PartialD]^c\[CapitalPhi] *)
T=Table[D[Phi,cd[[\[Mu]]]],{\[Mu],1,dim}];T=gu.T;
{Pc,Ps,Kc,Ks}=Expand[{Pc,Ps,Kc,Ks}];

Do[If[Kc[[a,b]]=!=0,Print[Subscript[K,StringJoin[id[[a]],id[[b]]]]," = ",Kc[[a,b]] ]];
,{a,1,dim},{b,a,dim}];

{Pc,Ps,Kc,Ks}
];


(* ::Input::Initialization:: *)
CovD /: CovD[T_,id_]:=
Module[{len,T1,T2,res,nb,P1,rot,Om},

len=Length[id];
T1=Table[D[T,cd[[\[Mu]]]],{\[Mu],1,dim}];                                   (* T1=\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Mu]\)]
\*SubscriptBox[
SuperscriptBox[\(T\), 
SubscriptBox[\(b\), \(1\)]], \(\(
\*SubscriptBox[\(b\), \(2\)]
\*SubscriptBox[\(b\), \(3\)] ... \)
\*SubscriptBox[\(b\), \(n\)]\)]\) *)
res=tiv.T1;                                                                                          (* res=\!\(
\*SubscriptBox[\(\[PartialD]\), \(a\)]
\*SubscriptBox[
SuperscriptBox[\(T\), 
SubscriptBox[\(b\), \(1\)]], \(\(
\*SubscriptBox[\(b\), \(2\)]
\*SubscriptBox[\(b\), \(3\)] ... \)
\*SubscriptBox[\(b\), \(n\)]\)]\) *)

nb=Table[u,{u,1,len}];
(* part of Subscript[D, a]Subscript[T^Subscript[b, 1], Subscript[b, 2]Subscript[b, 3]...Subscript[b, n]]=Subscript[Subscript[\[Omega], a]^Subscript[b, 1], c]Subscript[T^c, Subscript[b, 2]Subscript[b, 3]...Subscript[b, n]]+Subscript[\[Omega], Subscript[ab, 2]]^cSubscript[T^Subscript[b, 1], Subscript[cb, 3]...Subscript[b, n]]+... *)
Do[P1=Table[v,{v,1,len}] /. {1->u,u->1};
    T1=Transpose[T,P1];
    If[id[[u]]==1,
         Om=Transpose[Transpose[Sl,{1,3,2}].eta,{1,3,2}];T2=Om.T1;,(*  Subscript[Subscript[\[Omega], a]^Subscript[b, 1], c]=Subscript[X, acd]\[Eta]^Subscript[db, 1]=Subscript[Subscript[\[Omega], a], dc]\[Eta]^Subscript[db, 1] *)
         T2=Sl.eta.T1;
  ];
    P1=Table[v,{v,1,len+1}] /. {2->u+1,u+1->2};
    T2=Transpose[T2,P1];
    res=res+T2;
,{u,1,len}];

Expand[res]
];


(* ::Input::Initialization:: *)
EOM /: EOM[{n1_,n2_},Char_]:=
Module[{leF,Cf,Eg,E\[CapitalPhi],EA,\[Mu],a},
                                                                                                                                                                     (* n1=#of RR fields, n2=# of NS field *)
leF=Table[TensorRank[Fl[a]],{a,1,n1}];
Cf=Table[If[leF[[a]]==5,1/2,1],{a,1,n1}];                                                                            (* Cf=1/2 for D3(selfdual) *)
If[Phi==0,Pc=Ps=Kc=Ks=0];

If[Char==Str,
Eg=Rc-Rs/2 eta+Sum[Cf[[a]]Exp[2 Phi](-(1/(2 (leF[[a]]-1)!)) Fc[a]+1/(4 leF[[a]]!) Fs[a] eta),{a,1,n1}]+Sum[-(1/(2 2!)) Hc+1/(4 3!) Hs eta,{a,1,n2}]-Pc+eta Ps+4 Kc-2 eta Ks;
E\[CapitalPhi]=Rs+Sum[-(1/(2 3!)) Hs,{a,1,n2}]+4 Ks-2 Ps;
EA=Join[Table[Sum[D[Det[vb] Fu[a][[\[Mu]]],cd[[\[Mu]]]],{\[Mu],1,dim}],{a,1,n1}],Table[Sum[D[Det[vb]Exp[-2 Phi] Hu[[\[Mu]]],cd[[\[Mu]]]],{\[Mu],1,dim}],{a,1,n2}]];
];

If[Char==Ein,
Eg=Rc-Rs/2 eta+Sum[Cf[[a]](-(1/(2 (leF[[a]]-1)!)) Fc[a]+1/(4 leF[[a]]!) Fs[a] eta),{a,1,n1}]+Sum[-(1/(2 2!)) Hc+1/(4 3!) Hs eta,{a,1,n2}]-1/2 Kc+1/4 eta Ks;
E\[CapitalPhi]=-(1/2)Ps+2 Ks+Sum[-((5-leF[[a]])/(4 leF[[a]]!))Exp[(5-leF[[a]])/2 Phi]Fs[a],{a,1,n1}]+Sum[1/(2 3!) Exp[-Phi]Hs[a],{a,1,n2}];
EA=Join[Table[Sum[D[Det[vb]Fu[a][[\[Mu]]],cd[[\[Mu]]]],{\[Mu],1,dim}],{a,1,n1}],Table[Sum[D[Det[vb] Hu[[\[Mu]]],cd[[\[Mu]]]],{\[Mu],1,dim}],{a,1,n2}]];
];

{Eg,E\[CapitalPhi],EA}=Expand[{Eg,E\[CapitalPhi],EA}];
Expand[{Eg,E\[CapitalPhi],EA}]
];


(* ::Input::Initialization:: *)
SurfaceGravity /: SurfaceGravity:=
Module[{Xi,S,DXi,\[Kappa]},

Xi=Join[{1},Table[0,{a,1,dim-1}]];Xi=lvb.Xi;                                                         (* Xi=Subscript[\[Xi], a] *)
S=Table[D[Xi[[b]],cd[[\[Mu]]]] ,{\[Mu],1,dim},{b,1,dim}];
DXi=tiv.S+ Sl.eta.Xi;                                                                                           (* DXi=Subscript[D, a]Subscript[\[Xi], b] *)
\[Kappa]=Sqrt[-(1/2)TensorProd[{{DXi,{a,b}},{DXi,{a,b}}},eta][[1]]];                                  (* \[Kappa]^2=-(1/2)Subscript[D, a]Subscript[\[Xi], b]D^a\[Xi]^b *)

 Expand[\[Kappa]]
];


(* ::Input::Initialization:: *)
Weyl /: Weyl[Tl_]:=
Module[{Tc,Ts,Wl,a,b,c,d},

Tc=TensorProd[{{Tl,{a,c,b,d}},{eta,{c,d}}},eta][[1]];   (* Subscript[T, ab] *)
Ts=TensorProd[{{Tc,{a,b}},{eta,{a,b}}},eta][[1]];   (* T *)

Wl=Table[Tl[[a,b,c,d]]-(eta[[a,c]]Tc[[b,d]]-eta[[a,d]]Tc[[b,c]]-eta[[b,c]]Tc[[a,d]]+eta[[b,d]]Tc[[a,c]])/(dim-2)+(eta[[a,c]]eta[[b,d]]-eta[[a,d]]eta[[b,c]])Ts/((dim-1)(dim-2)),{a,1,dim},{b,1,dim},{c,1,dim},{d,1,dim}];                                                                       (* Subscript[W, abcd] *)
Wl=Expand[Wl];

(* Do[If[Wl[[a,b,c,d]]=!=0,
Print[Subscript[W,StringJoin[id[[a]],id[[b]],id[[c]],id[[d]]]]," = ",Wl[[a,b,c,d]] ]];
,{a,1,dim},{b,a+1,dim},{c,1,dim},{d,c+1,dim}]; *)

Wl
];


(* ::Input::Initialization:: *)
BarWeyl /: BarWeyl:=
Module[{Wl,DP,dDP,DDP,etaDDP,barWl,a,b,c,d},

Wl=Table[Rl[[a,b,c,d]]-(eta[[a,c]]Rc[[b,d]]-eta[[a,d]]Rc[[b,c]]-eta[[b,c]]Rc[[a,d]]+eta[[b,d]]Rc[[a,c]])/(dim-2)+(eta[[a,c]]eta[[b,d]]-eta[[a,d]]eta[[b,c]])Rs/((dim-1)(dim-2))
,{a,1,dim},{b,1,dim},{c,1,dim},{d,1,dim}];                                                                       (* Subscript[W, abcd] *)
Wl=Expand[Wl];

DP=Table[D[Phi,cd[[a]]],{a,1,dim}];
dDP=Table[D[DP[[b]],cd[[a]]],{a,1,dim},{b,1,dim}];
DDP=dDP-Sl.eta.DP;
etaDDP=Table[eta[[a,c]]DDP[[b,d]]-eta[[b,c]]DDP[[a,d]]-eta[[a,d]]DDP[[b,c]]+eta[[b,d]]DDP[[a,c]],{a,1,dim},{b,1,dim},{c,1,dim},{d,1,dim}];

barWl=Expand[Wl-etaDDP];

Do[If[barWl[[a,b,c,d]]=!=0,
Print[Subscript[\!\(\*OverscriptBox[\(W\), \(_\)]\),StringJoin[id[[a]],id[[b]],id[[c]],id[[d]]]]," = ",barWl[[a,b,c,d]] ]];
,{a,1,dim},{b,a+1,dim},{c,1,dim},{d,c+1,dim}];
(* Do[If[etaDDP[[a,b,c,d]]=!=0,
Print[Subscript[\[Eta]DDP,StringJoin[id[[a]],id[[b]],id[[c]],id[[d]]]]," = ",etaDDP[[a,b,c,d]] ]];
,{a,1,dim},{b,a+1,dim},{c,1,dim},{d,c+1,dim}]; *)

barWl
];


(* ::Input::Initialization:: *)
Integrability /: Integrability[TRl_,THl_]:=
Module[{IC},

Do[IC=Factor[Sum[TRl[[a,b,c,d]]Superscript[\[Gamma],StringJoin[id[[a]],id[[b]]]],{a,1,dim},{b,a+1,dim}]];
     If[IC=!=0,Print[IC,\[Epsilon],ee[[c]]\[Wedge]ee[[d]]," = 0" ];];
,{c,1,dim},{d,c+1,dim}];

IC=Factor[Sum[2iv[[\[Mu],a]]D[Phi,cd[[\[Mu]]]]Superscript[\[Gamma],id[[a]]],{\[Mu],1,dim},{a,1,dim}]
+Sum[THl[[a,b,c]]Superscript[\[Gamma],StringJoin[id[[a]],id[[b]],id[[c]]]],{a,1,dim},{b,a+1,dim},{c,b+1,dim}]];
If[IC=!=0,Print[IC,\[Epsilon]," = 0" ];];
];


(* ::Input::Initialization:: *)
TensorProd /: TensorProd[{T1_,T2_},Met_]:=
Module[{Tsr,Isv,les,Iall,led,S,Ict,leI,jd,Ps,leP,Rt,tensor,u},

Tsr={T1,T2};(* {{X,{a,c,d}},{Y,{b,e,c}}} *)
{Isv,Iall,S}=Table[{0,0},{u,1,3}];
Ict=Intersection[T1[[2]],T2[[2]]];(* {c} *)
leI=Length[Ict];(* 1 *)
jd=Length[T1[[2]]]Length[T2[[2]]];                   (* 9; note jd=0 for a scalar *)

If[leI==0&&jd==0,
     tensor=T1[[1]]T2[[1]];
     Isv=Join[T1[[2]],T2[[2]]];
];

If[leI==0&&jd=!=0,
     tensor=Outer[Times,T1[[1]],T2[[1]]];
     Isv=Join[T1[[2]],T2[[2]]];
];

If[leI=!=0,
Do[Ps={};Do[Ps=Join[Ps,Position[Tsr[[u,2]],Ict[[v]]]],{v,1,leI}];(* {2} *)
     Isv[[u]]=Delete[Tsr[[u,2]],Ps];(* {a,d} *)
     Iall[[u]]=Join[Ict,Isv[[u]]];(* {c,a,d} *)
     Rt={};Do[Rt=Join[Rt,Position[Iall[[u]],Tsr[[u,2,v]]]],{v,1,Length[Iall[[u]]]}];
     Rt=Flatten[Rt,1];(* {2,1,3} *)
     S[[u]]=Transpose[Tsr[[u,1]],Rt]; (* exchange indices. contracted ones are front *)
,{u,1,2}];(* Subscript[X', cad]=Subscript[X, acd] *)

Do[Rt=Table[v,{v,1,Length[Iall[[2]]]}] /. {1->u,u->1};
     S[[2]]=Met.Transpose[S[[2]],Rt];
     S[[2]]=Transpose[S[[2]],Rt];(* lift contracted indices in the second tensor *)
,{u,1,leI}];

Do[S[[u]]=Flatten[S[[u]],leI-1];,{u,1,2}];
Rt=RotateRight[Table[u,{u,1,Length[Isv[[1]]]+1}],1];(* {2,1} *)
S[[1]]=Transpose[S[[1]],Rt];
tensor=Expand[S[[1]].S[[2]]];                               (* contract indices *)
Isv=Flatten[Isv,1];
];

{tensor,Isv}
];


(* ::Input::Initialization:: *)
TensorProd /: TensorProd[{T1_,T2_,T3_},Met_]:=
Module[{T,len=0,nb={1,2},lentmp,od},

T={T1,T2,T3};
Do[lentmp=Length[Intersection[T[[u,2]],T[[v,2]]]];
    If[len<lentmp,len=lentmp;nb={u,v};];
,{u,1,2},{v,u+1,3}];

od=Join[nb,Complement[{1,2,3},nb]];
T={T[[od[[1]]]],T[[od[[2]]]],T[[od[[3]]]]};

TensorProd[Join[{TensorProd[{T[[1]],T[[2]]},Met]},{T[[3]]}],Met]
];


(* ::Input::Initialization:: *)
TensorProd /: TensorProd[{T1_,T2_,T3_,T4_},Met_]:=
Module[{T,len=0,nb={1,2},lentmp,od},

T={T1,T2,T3,T4};
Do[lentmp=Length[Intersection[T[[u,2]],T[[v,2]]]];
    If[len<lentmp,len=lentmp;nb={u,v};];
,{u,1,3},{v,u+1,4}];

od=Join[nb,Complement[{1,2,3,4},nb]];
T={T[[od[[1]]]],T[[od[[2]]]],T[[od[[3]]]],T[[od[[4]]]]};

TensorProd[Join[{TensorProd[{T[[1]],T[[2]]},Met]},{T[[3]],T[[4]]}],Met]
];


(* ::Input::Initialization:: *)
TensorProd /: TensorProd[{T1_,T2_,T3_,T4_,T5_},Met_]:=
Module[{T,len=0,nb={1,2},lentmp,od},

T={T1,T2,T3,T4,T5};
Do[lentmp=Length[Intersection[T[[u,2]],T[[v,2]]]];
    If[len<lentmp,len=lentmp;nb={u,v};];
,{u,1,4},{v,u+1,5}];

od=Join[nb,Complement[{1,2,3,4,5},nb]];
T={T[[od[[1]]]],T[[od[[2]]]],T[[od[[3]]]],T[[od[[4]]]],T[[od[[5]]]]};

TensorProd[Join[{TensorProd[{T[[1]],T[[2]]},Met]},{T[[3]],T[[4]],T[[5]]}],Met]
];


(* ::Input::Initialization:: *)
TensorProd /: TensorProd[{T1_,T2_,T3_,T4_,T5_,T6_},Met_]:=
Module[{T,len=0,nb={1,2},lentmp,od},

T={T1,T2,T3,T4,T5,T6};
Do[lentmp=Length[Intersection[T[[u,2]],T[[v,2]]]];
    If[len<lentmp,len=lentmp;nb={u,v};];
,{u,1,5},{v,u+1,6}];

od=Join[nb,Complement[{1,2,3,4,5,6},nb]];
T={T[[od[[1]]]],T[[od[[2]]]],T[[od[[3]]]],T[[od[[4]]]],T[[od[[5]]]],T[[od[[6]]]]};

TensorProd[Join[{TensorProd[{T[[1]],T[[2]]},Met]},{T[[3]],T[[4]],T[[5]],T[[6]]}],Met]
];


(* ::Input::Initialization:: *)
TensorProd /: TensorProd[{T1_,T2_,T3_,T4_,T5_,T6_,T7_},Met_]:=
Module[{T,len=0,nb={1,2},lentmp,od},

T={T1,T2,T3,T4,T5,T6,T7};
Do[lentmp=Length[Intersection[T[[u,2]],T[[v,2]]]];
    If[len<lentmp,len=lentmp;nb={u,v};];
,{u,1,6},{v,u+1,7}];

od=Join[nb,Complement[{1,2,3,4,5,6,7},nb]];
T={T[[od[[1]]]],T[[od[[2]]]],T[[od[[3]]]],T[[od[[4]]]],T[[od[[5]]]],T[[od[[6]]]],T[[od[[7]]]]};

TensorProd[Join[{TensorProd[{T[[1]],T[[2]]},Met]},{T[[3]],T[[4]],T[[5]],T[[6]],T[[7]]}],Met]
];


(* ::Input::Initialization:: *)
ChernSimon /: ChernSimon[T_]:=
Module[{S1,S2},

S1=Table[D[T[[\[Rho],b,a]],cd[[\[Nu]]]],{\[Nu],1,dim},{\[Rho],1,dim},{b,1,dim},{a,1,dim}];
S1=T.eta.Transpose[S1,{2,3,1,4}].eta;
S1=Table[Sum[(S1[[\[Mu],a,\[Nu],\[Rho],a]]-S1[[\[Mu],a,\[Rho],\[Nu],a]]+S1[[\[Nu],a,\[Rho],\[Mu],a]]-S1[[\[Nu],a,\[Mu],\[Rho],a]]
                 +S1[[\[Rho],a,\[Mu],\[Nu],a]]-S1[[\[Rho],a,\[Nu],\[Mu],a]])/6,{a,1,dim}]
,{\[Mu],1,dim},{\[Nu],1,dim},{\[Rho],1,dim}];
S2=Transpose[T,{2,1,3}].eta.Transpose[T,{2,1,3}].eta.Transpose[T,{2,1,3}].eta;
S2=Table[Sum[(S2[[a,\[Mu],\[Nu],\[Rho],a]]-S2[[a,\[Mu],\[Rho],\[Nu],a]]+S2[[a,\[Nu],\[Rho],\[Mu],a]]-S2[[a,\[Nu],\[Mu],\[Rho],a]]
                 +S2[[a,\[Rho],\[Mu],\[Nu],a]]-S2[[a,\[Rho],\[Nu],\[Mu],a]])/6,{a,1,dim}]
,{\[Mu],1,dim},{\[Nu],1,dim},{\[Rho],1,dim}];

Expand[S1+2/3 S2]
];


(* ::Input::Initialization:: *)
R2Tensor /: R2Tensor[TRl_]:=
Module[{T,R2c,R2s,HM2},

R2c=TensorProd[{{TRl,{c,d,e,a}},{TRl,{c,d,e,b}}},eta][[1]];             (* Subscript[R, cdea]Subscript[R^cde, b] *)
T=R2c.eta;
R2s=Sum[T[[a,a]],{a,1,dim}];                                                                                                    (* Subscript[R, abcd]R^abcd *)
HM2=-R2c+R2s/4 eta;                                                                                                                            (* -Subscript[R, cdea]Subscript[R^cde, b]+1/4Subscript[\[Eta], ab]Subscript[R, cdef]R^cdef *)
{R2c,R2s,HM2}=Expand[{R2c,R2s,HM2}];

Do[If[R2c[[a,b]]=!=0,Print[Subscript[R2,StringJoin[id[[a]],id[[b]]]]," = ",R2c[[a,b]] ]];
,{a,1,dim},{b,a,dim}];
Print[R2," = ",R2s];

{R2c,R2s,HM2}
];


(* ::Input::Initialization:: *)
TTensor /: TTensor:=
Module[{S1,S2,T1,T2,T3,T,Tu,Tg,Tl,Td,Tc,HM3,HH2},

S2=eta.Transpose[Rd2,{2,1,3,4}];
S2=eta.Transpose[S2,{2,1,3,4}];
T1=S2.Hu2;
T1=Table[Sum[T1[[a,b,\[Nu],\[Mu],\[Nu]]],{\[Nu],1,dim}],{\[Mu],1,dim},{a,1,dim},{b,1,dim}];

S1=eta.Transpose[Sd2,{2,1,3}].eta;
S1=Transpose[S1,{2,1,3}];
S2=Table[Sum[D[Det[vb]Exp[-2 Phi]Hu2[[\[Mu],\[Nu],\[Rho]]],cd[[\[Rho]]]],{\[Rho],1,dim}],{\[Mu],1,dim},{\[Nu],1,dim}];
T2=Det[vb]^(-1)Exp[2 Phi]*S2.S1;

S2=eta.Transpose[Rd2,{2,1,4,3}].gu;
S2=eta.Transpose[S2,{2,1,4,3}].gu;
S1=eta.Transpose[Sd2,{2,1,3}];
S1=Transpose[S1,{2,1,3}];
T3=S1.S2;
T3=Table[Sum[T3[[\[Nu],a,b,\[Mu],\[Nu]]]-T3[[\[Nu],b,a,\[Mu],\[Nu]]],{\[Nu],1,dim}],{\[Mu],1,dim},{a,1,dim},{b,1,dim}];
T3=T3+Det[vb]^(-1)Exp[2 Phi]*Table[Sum[D[Det[vb]Exp[-2 Phi]S2[[a,b,\[Mu],\[Nu]]],cd[[\[Nu]]]],{\[Nu],1,dim}]
,{\[Mu],1,dim},{a,1,dim},{b,1,dim}];

Tu=Expand[-T1+T2-2 T3];                                      (* T^\[Mu]ab *)
T=iv.Transpose[Tu,{2,1,3}].tiv;
Tg=Transpose[T,{2,1,3}];                                              (* T^\[Mu]\[Nu]\[Rho] *)
T=eta.Transpose[Tu,{2,1,3}].eta;
Tl=Transpose[T,{2,1,3}];                                              (* Subscript[T^\[Mu], ab] *)
T=eta.vb.Tu.eta;
Td=iv.Transpose[T,{2,1,3}];                                       (* Subscript[Subscript[T, a]^\[Mu], b] *)
Tc=Expand[Tl+Td+Transpose[Td,{1,3,2}]];       (* Subscript[T^\[Mu], ab]+Subscript[Subscript[T, a]^\[Mu], b]+Subscript[Subscript[T, b]^\[Mu], a] *)  
T1=Sd.eta.Transpose[Tc,{2,1,3}];
T2=Sd.eta.Transpose[Tc,{2,3,1}];
T=Table[Sum[T1[[\[Mu],a,\[Mu],b]]+T2[[\[Mu],b,\[Mu],a]],{\[Mu],1,dim}],{a,1,dim},{b,1,dim}];
S1=T+Table[Expand[Det[vb]^(-1)Exp[2 Phi]Sum[D[Det[vb] Exp[-2 Phi] Tc[[\[Mu],a,b]],cd[[\[Mu]]]],{\[Mu],1,dim}]]
,{a,1,dim},{b,1,dim}];                                                                                             (* e^-1e^(2\[CapitalPhi])Subscript[D, \[Mu]](ee^(-2\[CapitalPhi])(Subscript[T^\[Mu], ab]+Subscript[Subscript[T, a]^\[Mu], b]+Subscript[Subscript[T, b]^\[Mu], a])) *)
T=Transpose[Hg,{3,1,2}].Tu.eta;
S2=Table[Sum[T[[c,a,c,b]],{c,1,dim}],{a,1,dim},{b,1,dim}];    (* Subscript[H, \[Mu]ca]Subscript[T^\[Mu]c, b] *)
HM3=-S1/2-S2/2;                                                                (* -(1/2)e^-1e^(2\[CapitalPhi])Subscript[D, \[Mu]](ee^(-2\[CapitalPhi])(Subscript[T^\[Mu], ab]+Subscript[Subscript[T, a]^\[Mu], b]+Subscript[Subscript[T, b]^\[Mu], a]))-1/2Subscript[H, \[Mu]ca]Subscript[T^\[Mu]c, b] *)
HH2=Table[Sum[D[Det[vb] Exp[-2 Phi] (Tg[[\[Mu],\[Nu],\[Rho]]]+Tg[[\[Nu],\[Rho],\[Mu]]]+Tg[[\[Rho],\[Mu],\[Nu]]]),cd[[\[Mu]]]],{\[Mu],1,dim}]
,{\[Nu],1,dim},{\[Rho],1,dim}];                                             (* \!\(\*
StyleBox[
SubscriptBox["\[PartialD]", "\[Mu]"], "Subsubtitle"]\(\*
StyleBox["(", "Subsubtitle"]\*
StyleBox["e", "Subsubtitle"]\*
StyleBox[" ", "Subsubtitle"]
\*SuperscriptBox[\(e\), \(\(-2\)\[CapitalPhi]\)]\*
StyleBox[
SuperscriptBox["T", "\[Mu]\[Nu]\[Rho]"], "Subsubtitle"]\*
StyleBox[")", "Subsubtitle"]\)\) *)
{Tu,Tg,Tl,Td,Tc,HM3,HH2}=Expand[{Tu,Tg,Tl,Td,Tc,HM3,HH2}];

{Tu,Tg,Tl,Td,Tc,HM3,HH2}
];


(* ::Input::Initialization:: *)
Xtensors /: Xtensors[{T1_,T2_},S_]:=
Module[{Tg,T,Rt={},X,DX,DDX,res,\[Mu],aa,bb,cc,dd,ii,jj,vv,ww,xx,yy},

Do[Switch[Length[T1[[u]]],
    4,Tg[u]={S,T1[[u]]};,
    2,Tg[u]={Rc,T1[[u]]};,
    0,Tg[u]={Rs,T1[[u]]};
 ];
,{u,1,3}];
T=TensorProd[{Tg[1],Tg[2],Tg[3]},eta];

Switch[Length[T2],
4,Tg[4]=T2;,
2,Tg[4]={T2[[1]],xx,T2[[2]],yy};
      T[[1]]=Outer[Times,T[[1]],eta];
      T[[2]]=Join[T[[2]],{xx,yy}];,
0,Tg[4]={vv,xx,ww,yy};
      T[[1]]=T[[1]]*Outer[Times,eta,eta];
      T[[2]]={vv,ww,xx,yy};
];

Do[Rt=Join[Rt,Position[Tg[4],T[[2,u]]]],{u,1,Length[T[[2]]]}];Rt=Flatten[Rt,1];
T=Transpose[T[[1]],Rt];
X=Expand[(Transpose[T,{1,2,3,4}]-Transpose[T,{2,1,3,4}]-Transpose[T,{1,2,4,3}]
           +Transpose[T,{2,1,4,3}]+Transpose[T,{3,4,1,2}]-Transpose[T,{3,4,2,1}]
           -Transpose[T,{4,3,1,2}]+Transpose[T,{4,3,2,1}])/8];
If[S==Wl,X=Weyl[X];];

T=CovD[X,{-1,-1,-1,-1}];
DX=TensorProd[{{T,{aa,cc,ii,jj,bb}},{eta,{aa,bb}}},eta][[1]];     (* Subscript[D, a]Subscript[X, cij]^a *)

T=CovD[DX,{-1,-1,-1}];
DDX=TensorProd[{{T,{aa,cc,ii,jj}},{eta,{aa,cc}}},eta][[1]];         (* Subscript[D, a]Subscript[D, b]Subscript[X^a, ij]^b *)

res=Expand[{X,DX,DDX}];
res
];


(* ::Input::Initialization:: *)
W4EOM /: W4EOM[S_,T_]:=
Module[{Tg,R4part,X,DX,DDX,RXpart=0,DDXpart=0,res,a,b,c,i,j,u},

Do[Switch[Length[S[[u]]],
    4,Tg[u]={T,S[[u]]};,
    2,Tg[u]={Rc,S[[u]]};,
    0,Tg[u]={Rs,S[[u]]};
 ];
,{u,1,4}];

R4part=TensorProd[{Tg[1],Tg[2],Tg[3],Tg[4]},eta][[1]];
Do[{X,DX,DDX}=Xtensors[{Delete[S,u],S[[u]]},T];
     RXpart=RXpart+3TensorProd[{{Rl,{i,a,b,c}},{X,{j,a,b,c}}},eta][[1]]-TensorProd[{{X,{i,a,b,c}},{Rl,{j,a,b,c}}},eta][[1]];
     DDXpart=DDXpart-2DDX-2Transpose[DDX];
,{u,1,4}];

res=Expand[-(R4part/2)eta+1/2 RXpart+1/2 DDXpart];
res
];
