Message Boards Message Boards

Finding all solutions of the system of equations

Sinval Santos
Posted 1 year ago

Hello guys.

I want to determine the set of solutions (zeros), for the interval of -8 < x < 8 and -8 < y < 8, of the following system of equations:

eq1 = x^4 - 1999/1000 x^2 y^2 + y^4 == 1;
eq2 = Tan[x + y] - y Sin[x] == 0;

pp1 = ContourPlot[{eq1, eq2} // Evaluate, {x, -8, 8}, {y, -8, 8}, Axes -> True, AxesLabel -> Automatic]

I tried using the FindInstance function, but after a long wait with no response, I aborted the operation.

FindInstance[eq1 && eq2 && -8 < x < 8 && -8 < y < 8, {x, y}]
$Aborted

Then I collected points near all intersection locations with the Get Coordinates and Copy Graphics Selection options. Then I applied the FindRoot function.

cor = {{3.066, -3.276}, {3.192, -3.038}, {2.209, 1.909}, {3.161, 2.987}, {4.144, 3.986}, {4.017, 4.128}, {3.097, 3.24}, {1.988, 2.257}, {-3.165, 3.304}, {-3.118, 2.907}, {-1.168, 0.6402}, {-1.405, -0.977}, {-3.768, -3.625}, {-5.401, -5.369}, {-3.625, -3.657}, {-3.245, -3.371}, {-2.563, -2.753}, {-0.9774, -1.373}, {0.5923, -1.151}};

ta1 = {x, y} /. Table[FindRoot[{eq1, eq2}, {{x, cor[[i, 1]]}, {y, cor[[i, 2]]}}, AccuracyGoal -> 10, MaxIterations -> 1000], {i, Length[cor]}] // Quiet

{{3.09513, -3.2447}, {3.19226, -3.03953}, {2.1945, 1.95578}, {3.17233,3.01838}, {4.12451, 4.01996}, {4.02646, 4.13072}, {3.11331, 3.26186}, {2.01099, 2.24363}, {-3.18533, 3.32993}, {-3.08667, 2.92732}, {-1.19219, 0.649321}, {-1.39791, -0.977282}, {-3.76936, -3.64795}, {-5.39826, -5.36078}, {-3.58339, -3.70785}, {-3.25573, -3.39657}, {-2.55589, -2.74003}, {-0.936877, -1.37001}, {0.58816, -1.16004}}

points = Graphics[{Green, PointSize[0.015], Point[ta1]}];
Show[pp1, points, PlotRange -> All]

Is there a more practical way to accomplish this task?

Regards,
Sinval
POSTED BY: Sinval Santos
6 Replies
Sort By:
Sinval Santos
Sinval Santos
Posted 1 year ago

Yes, now it's perfect. Thanks again for the tip, Gianluca.
POSTED BY: Sinval Santos

Just increase the precision, for example PlotPoints->100, or zoom in this way:

ContourPlot[Evaluate@{eq1, eq2}, {x, -5.7, -5.3}, {y, -5.7, -5.3}, 
 Axes -> True, Epilog -> {Red, PointSize[Large], Point[solPts]}]
POSTED BY: Gianluca Gorni
Sinval Santos
Sinval Santos
Posted 1 year ago

Henrik and Gianluca, when I zoomed in on the bottom left edge of the graph, I noticed that the two points do not coincide with the intersections of the curves. This is normal?

eq1 = x^4 - 1999/1000 x^2 y^2 + y^4 == 1;
eq2 = Tan[x + y] - y Sin[x] == 0;
solPts = NSolveValues[eq1 && eq2, {x, y}, Reals];
ContourPlot @@ {{eq1, eq2}, {x, -8, 8}, {y, -8, 8}, Axes -> True, Epilog -> {Red, PointSize[Large], Point[solPts]}, PlotRange -> {{-5.7, -5.3}, {-5.7, -5.3}}}
POSTED BY: Sinval Santos
Sinval Santos
Sinval Santos
Posted 1 year ago

Indeed, using these functions, the evaluation is faster. Thank you for your attention Henrik and Gianluca.
POSTED BY: Sinval Santos

The second equation is singular in you region. You can eliminate the singularity by multiplying eq2 by Cos[x+y] and then use Solve:

eq1 = x^4 - 1999/1000 x^2 y^2 + y^4 == 1;
eq2 = Sin[x + y] - y Sin[x] Cos[x + y] == 0;
sol0 = Solve[eq1 && eq2 && -8 < x < 8 && -8 < y < 8, {x, y}]

All 20 solutions are genuine, as we can check this way:

Sort[Abs[Cos[x + y] /. sol0] // N]
POSTED BY: Gianluca Gorni

Sinval,

using NSolve and friends seems to be more "practical":

eq1 = x^4 - 1999/1000 x^2 y^2 + y^4 == 1;
eq2 = Tan[x + y] - y Sin[x] == 0;
solPts = NSolveValues[eq1 && eq2, {x, y}, Reals];
ContourPlot @@ {{eq1, eq2}, {x, -8, 8}, {y, -8, 8}, Axes -> True, Epilog -> {Red, PointSize[Large], Point[solPts]}, ImageSize -> Large}

enter image description here
POSTED BY: Henrik Schachner
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract