The fastest way of raising indices of high rank tensor

Question

I have some high dimensional high rank tensors, let's say $$F_{ijkl}$$ and I need to find $$F^{abcd}=g^{ai}g^{bj}g^{ck}g^{dl}F_{ijkl}.$$ Here $g^{ij}$ is the contravariant metric.

Simple summation in Mathematica takes way to much time

Do[Fup[[a,b,c,d]]=Sum[F[[j,j,k,l]]g[[a,i]]g[[b,j]]g[[c,k]]g[[d,l]],{i,1,dim},{j,1,dim},{k,1,dim},{l,1,dim}],{a,1,dim},{b,1,dim},{c,1,dim},{d,1,dim}]

But I can sum over first and last index using matrix multiplication, so first I calculate $F^a{}_{ij}{}^d$ and the do summation over last two indices:

Fuddu=g.F.g; Do[F^{abcd}=Sum[Fuddu[[a,j,k,d]]g[[b,j]]g[[c,k]],{j,1,dim},{k,1,dim}],{a,1,dim},{b,1,dim},{c,1,dim},{d,1,dim}]

This way is much faster but still takes a lot of time, I need smth even faster, any ideas guys?

Edit: I cannot give you my info, but you can choose some big dim like 10, fill square matrix g of dimension dim and rank-4 tensor F of dimension dim with some random functions/numbers:

dim=10;g=RandomReal[{0, 1}, {dim, dim}];F=RandomReal[{0, 1}, {dim, dim,dim,dim}];

Answer 1

My keyboard is broken. So here is fast answer (on Mathematica 9); more later...

Here is your input:

dim = 3; g = RandomReal[{0, 1}, {dim, dim}];
F = RandomReal[{0, 1}, {dim, dim, dim, dim}];

Now multiply four g's and the F. Use TensorProduct[g, g, g, g, F] (don't run this yet--it's slow) to generate the rank 12 tensor (unrepeated indices).

Now contract the 2nd and 9th indices, 4th and 10th indices, 6th and 11th indices, and also the 8th and 12th indices:

TensorContract[TensorProduct[g, g, g, g, F], {{2, 9}, {4, 10}, {6, 11}, {8, 12}}]

This is fastest I can get (0.3 sec on my machine).

Answer 2

Edit

My solution is faster than the accepted one, even with the Activate/Inactive trick suggested in the comments.

Original answer

You can define your tensor contraction routine using the builtins Dot and Transpose. Here is an example:

DotAt[T_?TensorQ, U_?TensorQ, m_Integer?Positive, n_Integer?Positive] := 
    With[{dimT = ArrayDepth@T, dimU = ArrayDepth@U},
       Dot[Transpose[T, Insert[Range[dimT - 1], dimT, m]], 
           Transpose[U, Insert[Range[2, dimU], 1, n]]]]

DotAt[T, U, m, n] contracts the $m$-th index of $T$ with the $n$-th index of $U$. With this definition you have for example that Dot[T, U] is equivalent to DotAt[T, U, Length@Dimensions@T, 1].

From this, you can go on and define the equivalent of TensorContract, with an easier syntax for multiple contractions, but I'm leaving that to you :)

Your problem can now be solved by

myFup = DotAt[g, DotAt[g, DotAt[g, DotAt[g, F, 2, 4], 2, 4], 2, 4], 2, 4];