# Calculate the product

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/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}]]


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/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

• Thank you, Henrik Schumacher! It was me who wrote down the question. Nov 23, 2018 at 7:28
• @Chipa-Chipa please take a look at mathematica.stackexchange.com/help/merging-accounts
– Kuba
Nov 23, 2018 at 9:27
• Ok, kuba. But I have only one acc. I did not signed up when posted "Calculate the product" Nov 23, 2018 at 9:46
• @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.
– Kuba
Nov 23, 2018 at 10:01