5
$\begingroup$

I have a system of two 3-variable equations $SysEqs=\{f(x,y,z)=0\;,\;g(x,y,z)=0\}$ where the domain of variables are $$6 < x < 2 \pi \\ - \frac{15}{100} < y < 0\\ 0 < z < \frac 32$$

I want by changing the variable $z$ by step $0.01$, i.e. for all the values $z=\{0,\;0.01,...,1.49,\;1.50\}$, find the points $(x,y)$ which solve this system of equation. Then illustrate these points in a 2D plot of $x,y$ and join these points to get a continuous line. Moreover, I need to see the behaviour of $z$ in this 2D plot by changing the colours if possible, I mean to show that by changing $z$ from $0$ to $\frac 32$, the curve's colour changes from Yellow to Black for example.

f[x_, y_, z_] := 
 9 E^(373 y/50) - 3 E^(4 y) Cos[(173 x)/50] + E^(173 y/50) Cos[4 x] - 
   2 E^(2 y) Cos[(273 x)/50] - 3 Cos[(373 x)/50] + 
   8 E^(2 y) Cos[(273 x)/50] Cos[z] - 
   2 E^(273 y/50) Cos[2 x] (1 + 4 Cos[z]) ;


g[x_, y_, z_] := -2 E^(273 y/50) (1 + 4 Cos[z]) Sin[2 x] - 
   3 E^(4 y) Sin[(173 x)/50] + E^(173 y/50) Sin[4 x] - 
   2 E^(2 y) Sin[(273 x)/50] + 8 E^(2 y) Cos[z] Sin[(273 x)/50] - 
   3 Sin[(373 x)/50] ;


SysEqs:={  f[x,y,z]==0 , g[x,y,z]==0  }


6 < x < 2 \[Pi]
-0.15 < y < 0
0 < z < 3/2

Unfortunately, I am not familiar with programming in Mathematica, I am only able to do some simple calculations like using FindRoot to find the position of $(x,y)$, but I do not know what to do after that. I appreciate any comments and answers.

$\endgroup$

1 Answer 1

6
$\begingroup$

Using a graphical solution

Clear["Global`*"]

f[x_, y_, z_] := 
  9 E^(373 y/50) - 3 E^(4 y) Cos[(173 x)/50] + E^(173 y/50) Cos[4 x] - 
   2 E^(2 y) Cos[(273 x)/50] - 3 Cos[(373 x)/50] + 
   8 E^(2 y) Cos[(273 x)/50] Cos[z] - 2 E^(273 y/50) Cos[2 x] (1 + 4 Cos[z]);

g[x_, y_, z_] := -2 E^(273 y/50) (1 + 4 Cos[z]) Sin[2 x] - 
   3 E^(4 y) Sin[(173 x)/50] + E^(173 y/50) Sin[4 x] - 
   2 E^(2 y) Sin[(273 x)/50] + 8 E^(2 y) Cos[z] Sin[(273 x)/50] - 
   3 Sin[(373 x)/50];

The solution is the intersection of the contour plots for the equations.

EDIT: Range of x changed to {x, 5.6, 2Pi}

reaped = Reap[
   cp3d = Legended[
     ContourPlot3D[{f[x, y, z] == 0, g[x, y, z] == 0},
      {x, 5.6, 2 Pi}, {y, -3/20, 0}, {z, 0, 3/2},
      WorkingPrecision -> 15,
      AxesLabel -> (Style[#, 14, Bold] & /@ {x, y, z}),
      ContourStyle -> Opacity[0.75],
      MeshFunctions ->
       {Function[{x, y, z},
         Sow[{x, y, z}];(* all evaluated points *)
         f[x, y, z] - g[x, y, z]]},
      Mesh -> {{0.}},(* intersection *)
      MeshStyle -> Directive[Red, Thick],
      PlotLegends -> {f, g}],
     LineLegend[{Red}, {"f\[ThinSpace]=\[ThinSpace]g"}]]];

Show[cp3d]

enter image description here

Selecting the reaped points that are at the intersection (and eliminating points with duplicate values of x)

pts = DeleteDuplicates[
   Select[Sort@reaped[[2, 1]],
    Abs[f @@ #] < 10^-4 && Abs[g @@ #] < 10^-4 &], 
   Abs[#1[[1]] - #2[[1]]] < 10^-6 &];

{xmin, xmax} = MinMax@pts[[All, 1]]

(* {5.80816, 6.28319} *)

In the original response, for simplicity the color of the ListLinePlot was determined by the value of x and only loosely on the value of z. To determine the color based on the value of z, define z as a function of x. This is done using a linear Interpolation (the Interpolation is why points with duplicate values of x had to be eliminated).

zfx = Interpolation[pts[[All, {1, 3}]],
   InterpolationOrder -> 1];

{zmin, zmax} = Reverse[zfx /@ {xmin, xmax}]

(* {0.000234482, 1.49426} *)

ListLinePlot[Most /@ pts,
 PlotRange -> {{5.6, 2 Pi}, {-3/20, 0}},
 PlotStyle -> Thick,
 ColorFunction ->
  (ColorData["Rainbow"][Rescale[zfx@#1, {zmin, zmax}]] &),
 ColorFunctionScaling -> False,
 PlotLegends -> BarLegend[{ColorData["Rainbow"],
    {zmin, zmax}},
   LegendLabel -> Style[z, 14, Bold]],
 Frame -> True,
 FrameLabel -> (Style[#, 14, Bold] & /@ {x, y}),
 PlotLabel -> Style[StringForm["`` = ``",
    HoldForm@f[x, y, z], HoldForm@g[x, y, z]], 14, Bold]]

enter image description here

$\endgroup$
5
  • $\begingroup$ Thanks again for the edit, but, I think the problem still persists, I have added the plot I get I mentioned in my previous comment, it seems that again the LegendBar does not match with the curve; the LegendBar is almost red, but the curve is almost blue. $\endgroup$
    – user80187
    Commented May 27, 2021 at 21:34
  • $\begingroup$ Post a new question and include your code. We cannot tell from looking at a plot what exactly you did to produce it. However, what looks suspect is that the legend indicates that z is varying from 0 to about 3 but the plot range is supposed to be restricted to 0 < z < 3/2 $\endgroup$
    – Bob Hanlon
    Commented May 27, 2021 at 21:37
  • $\begingroup$ I do not use a different code to write it again, I have only changed the domain of $z$. I have added the code at the end of the question (it is your code; I have only changed 0<z<\pi). I am sorry, I am not very familiar with Mathematica. $\endgroup$
    – user80187
    Commented May 27, 2021 at 21:53
  • $\begingroup$ If you change the range of z to 0 < z < Pi, the solution does not work since the intersection is essentially vertical, i.e., there are not unique values of z for values of x. I would guess that you would need to find a parametric representation since it cannot be represented as a function. $\endgroup$
    – Bob Hanlon
    Commented May 27, 2021 at 22:41
  • $\begingroup$ Thank you again. In that case, there is a problem at $z=0,\pi$. As I had written in the text, I was looking for a way to find the solution by changing $z$ with the step $0.001$. I will probably ask a new question later. I really appreciate your time and answer. $\endgroup$
    – user80187
    Commented May 27, 2021 at 22:52

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.