Group Abstract Group Abstract

Message Boards Message Boards

Find possible sets of numbers for non-zero coefficients (optimization)

GROUPS:
Hi,

I need to optimize sets search of non-zero coefficients for real functions of the form (with possibly more harmonics):
f = x3^(3/2) (A1 Cos[8 x1] + B1 Cos[9 x1] + C1 Cos[10 x1]) (Cos[x2] + Cos[3 x2]);
f is to be expanded into double Fourier series with respect to x1 and x2, i.e. f = Sum f(nm) exp(i(n x1 + m x2)).
And the values of (nm) for which f(nm)'s are non-zero should be found automaticaly. 

So far I've found 2 ways of extracting (nm). But I'm not sure that they are bug-free and they indeed not optimized.

Method 1:
 f = x3^(3/2) (A1 Cos[8 x1] + B1 Cos[9 x1] + C1 Cos[10 x1]) (Cos[x2] + Cos[3 x2]);
 
 set1 = FourierCoefficient[f, x1, n][[1]];
 set2 = FourierCoefficient[f, x2, m][[1]];
 
 l1 = Length[set1];
 l2 = Length[set2];
 
 ns = Table[set1[[i]][[2]], {i, 1, l1}];
ms = Table[set2[[i]][[2]], {i, 1, l2}];

ns = ToExpression[StringReplace[StringReplace[ToString[ns], "||" -> ","],"n == " -> " "]]
ms = ToExpression[StringReplace[StringReplace[ToString[ms], "||" -> ","],"m == " -> " "]]
Method 2:
 f = x3^(3/2) (A1 Cos[8 x1] + B1 Cos[9 x1] + C1 Cos[10 x1]) (Cos[x2] + Cos[3 x2]);
 f = f // TrigToExp // Expand;
 
 array = Table[0, {i, 1, Length[f]}];
 Do[{array[[i]] = f[[i]];}, {i, 1, Length[f]}];
 
 ToString[array /. i_ E^n_ -> n];
 StringReplace[% , "x1" -> ","];
 StringReplace[% , "I" -> "1"];
StringReplace[% , "x2" -> "1"];
full = ToExpression[%];
ns = Take[full, {1, Length[full], 2}];
ms = Take[full, {2, Length[full], 2}];
ns = DeleteDuplicates[ns]
ms = DeleteDuplicates[ms]

Any suggestions how to optimize (mn) extraction? Or maybe is there a better way to do it?

Thanks,
I.M.
POSTED BY: Ivan Morozov
Answer
10 months ago
[It pays to post code that actually works. There is a definition mismatch between `f` and `f1`.]
f1 = x3^(3/2) (A1 Cos[8 x1] + B1 Cos[9 x1] + C1 Cos[10 x1]) (Cos[x2] +
      Cos[3 x2]);

Timing[
fcoeffs =
   Table[FourierCoefficient[
     Table[FourierCoefficient[f1, x1, n], {n, -12, 12}], x2,
     m], {m, -12, 12}];]
Out[101]= {59.460000, Null}
POSTED BY: Daniel Lichtblau
Answer
10 months ago
Thanks, Daniel. I've fixed the typo.
The point is that function is not known  and range can't be given as the max of  (nm).
Even if we can find max values for n and m, FourierCoefficient with range {n,-nmax,nmax} and {m,-mmax,mmax} is too slow.
Second method looks way faster but is need special treatment for (n,m)=(0,0). f should be modified as f-(constant part. f) first.
f = f//TrigToExp//Expand;
f=f-Coefficient[f/.E^n_->p,p,0];
Also cases when n=0 & m\=0 ||  n\=0 & m=0 are handled incorrectly for now.
FourierCoefficient  gives right answer for all possible combinations.
POSTED BY: Ivan Morozov
Answer
10 months ago
I've upgraded the problem's solution but still not happy with the result. 
Here are the points that bother me:
1) Do I use "Parallelize" correctly?

2) When "Parallelize" is ON, coefficients are not computed, i.e. "?fc" gives nothing. Why does this happen?

3) Double Do loop computes extra coeffs. I need (a,b) to run only  through given pairs.

 FindPairs::usage = "Placeholder";
 
 FindPairs[function_, coeffs_, args_List, test_Integer: 0] := Module[
    {
     FUNCTION,
     ARGS,
     OUTPUT = {__, __},
     a, b, c, d
     },
   {
    (*Parallelize[*) (*<-- UNCOMMENT FOR PARALLEL COMPUTATION *)
    (* PAIRS *)
    ARGS = args;
    FUNCTION = Im[List @@ Expand[TrigToExp[function]] /. {a_ E^b_ -> b}
                                                      /. {a_ ARGS[[1]] + b_ ARGS[[2]] -> {a, b}}
                                                      /. {a_ ARGS[[1]] -> {a, 0}}
                                                      /. {a_ ARGS[[2]] -> {0, a}}]
                                                      /. Im[a_] -> {0, 0};
    OUTPUT[[1]] = DeleteDuplicates[Transpose[FUNCTION][[1]]];
    OUTPUT[[2]] = DeleteDuplicates[Transpose[FUNCTION][[2]]];
    (* COEFFICIENTS *)
    FUNCTION = Expand[TrigToExp[function]];
    Do[
     {
      coeffs[a, b] = Which[
           (a == 0 && b == 0), Coefficient[FUNCTION /. E^a_ -> ARGS[[1]], ARGS[[1]], 0],
           (a == 0 && (b > 0 || b < 0)), Coefficient[FUNCTION /. a_ E^(b_ + c_ ) -> 0, E^(I b ARGS[[2]])],
           ((a > 0 || a < 0) && b == 0), Coefficient[FUNCTION /. a_ E^(b_ + c_ ) -> 0, E^(I a ARGS[[1]])],
           ((a > 0 || a < 0) && (b > 0 || b < 0)), Coefficient[FUNCTION, E^(I a ARGS[[1]] + I b ARGS[[2]])]
         ];
      },
     {a, OUTPUT[[1]]},
     {b, OUTPUT[[2]]}
     ];
    OUTPUT
    (*]*) (*<-- UNCOMMENT FOR PARALLEL COMPUTATION *)
    }];

(* EXAMPLE *)
f=x3^(3/2)(A1 Cos[8 x1] + B1 Cos[9 x1] + C1 Cos[10 x1])(Cos[x2]+
Cos[3 x2])+f00+ D1 Cos[7 x1]+E1 Cos[11 x2]+F1 Cos[x1] Cos[5 x2];
range = FindPairs[f, fc, {x1, x2}][[1]]
f - Sum[fc[i, j] E^(I (i x1 + j x2)), {i, range[[1]]}, {j, range[[2]]}] // Simplify
?fc
Thanks,
I.M.
POSTED BY: Ivan Morozov
Answer
10 months ago