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}]]
Improve this question
$\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

Improve this answer
$\endgroup$
4
  • $\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.