1
$\begingroup$

I have the following problem: Wolfram calculates the product incorrectly. In addition, lots of errors appears. Is it possible to improve the code? Thanks in advance!

Define functions:

    M = 100; 
    delt[s_] := 0.5 Sin[s]; 
    U[s_] := 0.5 Cos[s]; 
    p1[s_, k_] := -1 - U[s] - (1 - U[s]) Cos[k]; 
    p2[s_, k_] := (1 - U[s]) Sin[k]; 
    p3[s_] := 0.5 Sin[s]; 
    p[s_, k_] := Sqrt[2 + 2 U[s]^2 + delt[s]^2 + 2 (1 - U[s]^2) Cos[k]]; 

Solve the system of diff.equations in terms of x1, x2, x3:

    sol = ParametricNDSolve[
    {0.5 G D[x1[s, k], s] == x3[s, k] p2[s, k] - x2[s, k] p3[s], 
    0.5 G D[x2[s, k], s] == -x3[s, k] p1[s, k] + x1[s, k] p3[s], 
    0.5 G D[x3[s, k], s] == x2[s, k] p1[s, k] - x1[s, k] p2[s, k], 
    x1[0, k] == -p1[0, k]/p[0, k],
    x2[0, k] == -p2[0, k]/p[0, k], 
    x3[0, k] == -p3[0]/p[0, k]},
    {x1, x2, x3}, {s, 0, 2 Pi}, {k, -Pi, Pi},{G},WorkingPrecision -> 100, 
    PrecisionGoal -> 80]

Calculate the product:

    With[{G = 0.2, s = 2 Pi}, 
    NProduct[ 
    2/(1 - (x1[G][s, k] p1[s, k] + x2[G][s, k] p2[s, k] + 
    x3[G][s, k] p3[s] )/p[s, k]) /. sol, {k, -Pi + 2 Pi/M, Pi, 2 Pi/M}]]
$\endgroup$
4
$\begingroup$

Well, you request high WorkingPrecision and PrecisionGoal, but you submit machine precision numbers to ParametricNDSolve. That's why ParametricNDSolve complains. Turn 0.5 and 0.2 into 1/2 and 1/5 should resolve the error messages.

Towards the long computation time: The way you wrote the product enforces to resolve the parametric PDE over and over again. Here is a slightly different setup; all computations are performed within 20 seconds on my machine.

M = 100;
delt[s_] := 1/2 Sin[s];
U[s_] := 1/2 Cos[s];
p1[s_, k_] := -1 - U[s] - (1 - U[s]) Cos[k];
p2[s_, k_] := (1 - U[s]) Sin[k];
p3[s_] := 1/2 Sin[s];
p[s_, k_] := Sqrt[2 + 2 U[s]^2 + delt[s]^2 + 2 (1 - U[s]^2) Cos[k]];
M = 100;
delt[s_] := 1/2 Sin[s];
U[s_] := 1/2 Cos[s];
p1[s_, k_] := -1 - U[s] - (1 - U[s]) Cos[k];
p2[s_, k_] := (1 - U[s]) Sin[k];
p3[s_] := 1/2 Sin[s];
p[s_, k_] := Sqrt[2 + 2 U[s]^2 + delt[s]^2 + 2 (1 - U[s]^2) Cos[k]];
S = ParametricNDSolveValue[{
    1/2 G D[x1[s, k], s] == x3[s, k] p2[s, k] - x2[s, k] p3[s], 
    1/2 G D[x2[s, k], s] == -x3[s, k] p1[s, k] + x1[s, k] p3[s], 
    1/2 G D[x3[s, k], s] == x2[s, k] p1[s, k] - x1[s, k] p2[s, k],
    x1[0, k] == -p1[0, k]/p[0, k],
    x2[0, k] == -p2[0, k]/p[0, k],
    x3[0, k] == -p3[0]/p[0, k]
    },
   {x1, x2, x3},
   {s, 0, 2 Pi},
   {k, -Pi, Pi},
   {G}, PrecisionGoal -> 80, WorkingPrecision -> 100
   ];

{x1G, x2G, x3G} = S[2/10]; // AbsoluteTiming // First
With[{s = 2 Pi},
    result = 
     Product[2/(1 - (x1G[s, k] p1[s, k] + x2G[s, k] p2[s, k] + 
            x3G[s, k] p3[s])/p[s, k]), {k, -Pi + 2 Pi/M, Pi, 2 Pi/M}]
    ]; // AbsoluteTiming // First
result

19.3725

0.04723

1.3446334922726275480380043972804098138548668623845080152261505778472469571251844959885896003599042

$\endgroup$
  • $\begingroup$ Thank you, Henrik Schumacher! It was me who wrote down the question. $\endgroup$ – Chipa-Chipa Nov 23 '18 at 7:28
  • $\begingroup$ @Chipa-Chipa please take a look at mathematica.stackexchange.com/help/merging-accounts $\endgroup$ – Kuba Nov 23 '18 at 9:27
  • $\begingroup$ Ok, kuba. But I have only one acc. I did not signed up when posted "Calculate the product" $\endgroup$ – Chipa-Chipa Nov 23 '18 at 9:46
  • $\begingroup$ @Chipa-Chipa quest accounts apply too. And please do not use answers to post comments. Once you merge with user you will be able to comment under this topic. $\endgroup$ – Kuba Nov 23 '18 at 10:01

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.