0
$\begingroup$

I have this function and I want to see where it is zero. $$\frac{1}{16} \left(\sinh (\pi x) \left(64 \left(x^2-4\right) \cosh \left(\frac{2 \pi x}{3}\right) \cos (y)+\left(x^2+4\right)^2+256 x \sinh \left(\frac{2 \pi x}{3}\right) \sin (y)\right)+\left(x^2-12\right)^2 \sinh \left(\frac{7 \pi x}{3}\right)-2 \left(x^2+4\right)^2 \sinh \left(\frac{5 \pi x}{3}\right)\right)+2 \left(x^2-4\right) \sinh \left(\frac{\pi x}{3}\right)$$ I use ContourPlot

f[x_, y_] := 
  2 (-4 + x^2) Sinh[(π x)/3] + 
   1/16 (((4 + x^2)^2 + 64 (-4 + x^2) Cos[y] Cosh[(2 π x)/3] + 
         256 x Sin[y] Sinh[(2 π x)/3]) Sinh[π x] - 
      2 (4 + x^2)^2 Sinh[(5 π x)/3] + (-12 + x^2)^2 Sinh[(
        7 π x)/3]);

ContourPlot[
 f[x, y] == 0, {x, 3.465728, 3.465729}, {y, 1.046786, 1.046795}, 
 PlotPoints -> 500]

and I obtain this plot

Now, my question is that can I trust this plot and conclude that the curves do not cross?

Or, I should increase the precision of the plot? And if so, how can I ask Mathematica to give higher precision for the axis in ContourPlot?

$\endgroup$
0
$\begingroup$

Not a complete answer but one direction to go in:

cp = ContourPlot[f[x, y] == 0, {x, 3.465728, 3.465729}, {y, 1.046786, 1.046795}, PlotPoints -> 500]

{l1, l2} = Cases[Normal[cp], _Line, Infinity];
{{x1, y1}} = MinimalBy[First@l1, RegionDistance[l2]];
{{x2, y2}} = MinimalBy[First@l2, RegionDistance[l1]];
Show[
 cp,
 ListPlot[{{x1, y1}, {x2, y2},}, 
  PlotStyle -> {PointSize[Large], Red}]
 ]

Output

sol1 = r /. FindRoot[f[r, y], {r, x1}];
sol2 = r /. FindRoot[f[r, y], {r, x2}];
sol1 - sol2

3.11929*10^-8

At least FindRoot also finds that there are two distinct solutions at that y. However, FindRoot also warns about its ability to find roots with the desired accuracy, so it is still not conclusive. Also, perhaps it should be looking for the root by also adjusting y.

The idea here is that we can extract values from the plot and then try to verify our conclusions about the plot using other functions.

| improve this answer | |
$\endgroup$
0
$\begingroup$

The following shows that f[x, y] is negative (not zero) along the vertical line x == 3.4657284... through the saddle point between the two branches, and therefore the line separates the two branches where f[x, y] == 0 in the OP's graph:

yAssum = 1.046786`32 < y < 1.046795`32;
FindRoot[D[f[x, y], {{x, y}}], {{x, 3.465728}, {y, 1.04679}}, 
 WorkingPrecision -> 32]
Simplify[
 Reduce[f[x, y] < 0 && yAssum /. First@%, y],
 yAssum]
(* Saddle point:
    {x -> 3.4657284034593587205275273903929, 
     y -> 1.0467905677870295818695381998660}
*)

Reduce::ratnz: Reduce was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result.

(*  True  *)
| improve this answer | |
$\endgroup$

Your Answer

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