Calculate the product

Question

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

Answer 1

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