# An efficient way to merge a pair of 4d arrays of non regular length lists

## Question

I have two 4 dimensional non regular length lists of complex values. I have working code however it seems quite slow and I am not sure how I could improve this.

Mathematically I am trying to achieve a partial trace. totalSpace is the 4 dimensional array of lists, The first two parameters are two position parameters which generally range from 1 to 10, the second two variables have lengths dependent on the position variable. So we have a matrix at each position (specified by two position variables) whose dimensions depend on the position variables.

Then we take two copies of totalSpace, one of which is the complex conjugate of the other. Finally we need to merge (via summation) these two lists together when the second and fourth dimensions have equivalent values.

Sum[Sum[
ArrayFlatten[Table[Table[
Flatten[Table[Table[
totalSpace[[x1a, x2, c1a, c2]]*Conjugate[totalSpace[[x1b, x2, c1b, c2]]],
{c1b, 1, LengthNode[x1b]}], {x1b, MinG, MaxG}]],
{c1a, 1, LengthNode[x1a]}],{x1a, MinG, MaxG}], 1],
{c2, 1, LengthNode[x2]}],{x2, MinG, MaxG}]


I am looking for ways to speed up this code, is there a Mathematica function which more naturally merges these lists? I have looked into Sow and Reap but I am not sure if they work for this as I really want to sum as I reap.

MinG and MaxG are the minimum and maximum number for indexing a position. Normally MinG is just 1, however for some graphs it makes sense to have a negative indies such as for the Number line. LengthNode is a function which takes in a position index and returns the number of connected nodes to that node.

LengthNode[x_] := LengthNode[x] = Length[ConnectedNodes[[x]]]
MinG = Min[ConnectedNodes]
MaxG = Max[ConnectedNodes]


ConnectedNodes is a list storing the graph shape and is probably best explained by an example below.

## Example

To make my question clearer below is a small but concrete example of what I am trying to achieve. The space we will consider has four different positions indexed from 1 to 4 (nothing to do with being 4D). How they are connected to each other is shown pictorially in the below graph. This is given below:

In Mathematica this is encoded as a list of nodes that the position is connected to, the data of above example is shown below.

ConnectedNodes = {{2, 3, 4}, {1}, {1}, {1}}


From this we have two quantum mechanical objects, on the graph. Ignoring the fact this should be normalised, an example of the total state space is given below.

totalSpace =
Table[Table[
Table[Table[
1,
{c2, ConnectedNodes[[x2]]}], {c1, ConnectedNodes[[x1]]}],
{x2, 1, 4}], {x1, 1, 4}]

Out: {{{{1, 1, 1}, {1, 1, 1}, {1, 1, 1}}, {{1}, {1}, {1}}, {{1}, {1}, {1}}, {{1}, {1}, {1}}}, {{{1, 1, 1}}, {{1}}, {{1}}, {{1}}}, {{{1, 1, 1}}, {{1}}, {{1}}, {{1}}}, {{{1, 1, 1}}, {{1}}, {{1}}, {{1}}}}


This means we have a 4 dimensional object called totalSpace, which is indexed as:

totalSpace[[x1,x2,c1,c2]]


Now we consider totalSpace[[x1a,x2,c1a,c2]] and Conjugate[totalSpace[[x1b,x2,c1b,c2]]], I want to output a matrix which has every permutation of x1a, c1a in one direction and every permutation of x1b, c1b in the other direction, where we have summed over every combination of x2, c2. My code for doing this is given below:

Sum[
ArrayFlatten[Table[
Flatten[Table[
totalSpace[[x1a, x2, c1a, c2]]*Conjugate[totalSpace[[x1b, x2, c1b, c2]]],
{x1b, 1, 4}, {c1b, 1, Length[ConnectedNodes[[x1b]]]} ]],
{x1a, 1, 4}, {c1a, 1, Length[ConnectedNodes[[x1a]]]} ], 1],
{x2, 1, 4}, {c2, 1, Length[ConnectedNodes[[x2]]]} ]


When I scale my code up to larger graphs of say 10+ nodes this implementation is found to take several seconds.

## Update 1

Upon the suggestions below I have updated my code to look a bit cleaner.

Sum[
ArrayFlatten[Table[
Flatten[Table[
totalSpace[[x1a, x2, c1a, c2]]*Conjugate[totalSpace[[x1b, x2, c1b, c2]]],
{x1b, MinG, MaxG},{c1b, 1, LengthNode[x1b]}]],
{x1a, MinG, MaxG},{c1a, 1, LengthNode[x1a]}], 1],
{x2, MinG, MaxG},{c2, 1, LengthNode[x2]}]


Unfortunately I couldn't detect any real performace increase.

• Table[Table[i + j, {i, 3}], {j, 3}] is equivalent to Table[i + j, {i, 3}, {j, 3}]. – Apple Aug 25 '14 at 8:55
• It will be better if you give the code of totalSpace,x1a,x2 and so on. – Apple Aug 25 '14 at 8:58
• @Chenminqi Unfortunately in my case the range of i depends on the particular value of j. So Mathematica yells at me when I try. – User Aug 25 '14 at 8:58
• @Chenminqi OK np, I'll try add some more details in as simple a form as possible. – User Aug 25 '14 at 9:00
• @murphc05 The single Table form does work, but the iterators are given outside-first: Table[{i, j}, {j, 3}, {i, j, 3}] – Mr.Wizard Aug 25 '14 at 9:42