Mathematica Asked by MsMath on June 14, 2021
Following my previous question
here, I am looking an alternative way to solve this problem (the method was not applicable to more complicated situations). I have a system of two 3-variable equations $Eqs={f(x,y,z)=0;,;g(x,y,z)=0}$ where the domain of variables are
$$5.6 < x < 2 pi
– frac{15}{100} < y < 0
0 < z < pi$$
These are what I need:
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] ;
Eqs:={ f[x,y,z]==0 , g[x,y,z]==0 }
5.66 < x < 2 π
-0.15 < y < 0
0 < z < π
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.
Let's take NMinimize
(very robust solver) to solve these two equations
s[z_?NumericQ] := {x, y, z} /.
NMinimize[ {f[x, y, z]^2 + g[x, y, z]^2,5.66 < x < 2 Pi, -15/100 < y < 0}, {x, y} ][[2]]
Function s[z]
returns the solution {x[z],y[z],z}
Calculate solution for 0<z<Pi
xyz = Table[s[z], {z, 0, Pi , Pi/50}];
Graphics3D[{Red, Point[xyz]}, BoxRatios -> {1, 1, 1},AxesLabel -> {x, y, z}, Axes -> True]
Answered by Ulrich Neumann on June 14, 2021
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];
cp3d = ContourPlot3D[
{f[x, y, z] == 0, g[x, y, z] == 0},
{x, 5.66, 2 π}, {y, -0.15, 0}, {z, 0, π},
WorkingPrecision -> 15,
AxesLabel ->
(Style[#, 14, Bold] & /@ {x, y, z}),
ContourStyle -> Opacity[0.8],
PlotLegends -> {f, g}];
Following Ulrich Neumann's recommendation to use NMinimize
s[z_?NumericQ] := {x, y, z} /.
NMinimize[{f[x, y, z]^2 + g[x, y, z]^2,
566/100 < x < 2 Pi, -15/100 < y < 0}, {x, y},
WorkingPrecision -> 15][[2]]
data3d = Table[s[z], {z, 0, Pi, 1/100}];
Legended[
Show[cp3d,
ListLinePlot3D[data3d,
PlotStyle -> Directive[Red, Thick]]],
LineLegend[{Red}, {"f[ThinSpace]=[ThinSpace]g"}]]
Use Interpolation
to define z
as a function of x
zfx = Interpolation[DeleteDuplicatesBy[data3d[[All, {1, 3}]], First]];
The static plot with "mile markers" is
Legended[
ListLinePlot[Most /@ data3d,
Frame -> True,
FrameLabel ->
(Style[#, 14, Bold] & /@ {x, y}),
ColorFunction -> Function[{x, y},
ColorData["Rainbow"][zfx[x]/Pi]],
ColorFunctionScaling -> False,
Epilog -> {AbsolutePointSize[3],
Tooltip[Point[Most@#],
StringForm["z[ThinSpace]=[ThinSpace]``", N@#[[3]]]] & /@
Select[data3d, IntegerQ[2 #[[3]]] &]},
PlotLabel -> Style[StringForm["``=[ThinSpace]0, ``=[ThinSpace]0",
HoldForm[f[x, y, z]],
HoldForm[g[x, y, z]]], 14, Bold]],
BarLegend[{"Rainbow", {0, Pi}},
LegendLabel -> Style[z, 14, Bold]]]
For a dynamic plot use either Manipulate
or Animate
Manipulate[
Legended[
ListLinePlot[Most /@ data3d,
Frame -> True,
FrameLabel ->
(Style[#, 14, Bold] & /@ {x, y}),
ColorFunction -> Function[{x, y},
ColorData["Rainbow"][zfx[x]/Pi]],
ColorFunctionScaling -> False,
Epilog -> {AbsolutePointSize[4],
Point[Most@s[zz]]},
PlotLabel -> Style[StringForm["``=[ThinSpace]0, ``=[ThinSpace]0",
HoldForm[f[x, y, z]],
HoldForm[g[x, y, z]]], 14, Bold]],
BarLegend[{"Rainbow", {0, Pi}},
LegendLabel -> Style[z, 14, Bold]]],
{{zz, 0, z}, 0, Pi, 0.01, Appearance -> {"Open","Labeled"}}]
To make a GIF
make a Table
of the desired frames
frames = Table[
Manipulate[
Legended[
ListLinePlot[Most /@ data3d,
Frame -> True,
FrameLabel ->
(Style[#, 14, Bold] & /@ {x, y}),
ColorFunction -> Function[{x, y},
ColorData["Rainbow"][zfx[x]/Pi]],
ColorFunctionScaling -> False,
Epilog -> {AbsolutePointSize[4],
Point[Most@s[zz]]},
PlotLabel -> Style[StringForm["``=[ThinSpace]0, ``=[ThinSpace]0",
HoldForm[f[x, y, z]],
HoldForm[g[x, y, z]]], 14, Bold]],
BarLegend[{"Rainbow", {0, Pi}},
LegendLabel -> Style[z, 14, Bold]]],
{{zz, init, z}, 0, Pi, 0.01, Appearance -> {"Open", "Labeled"}}],
{init, 0, Pi, Pi/10.}]; (* change step size as required *)
Export["/Users/roberthanlon/Downloads/manipulate.gif",
frames]
(* "/Users/roberthanlon/Downloads/manipulate.gif" *)
Answered by Bob Hanlon on June 14, 2021
Get help from others!
Recent Answers
Recent Questions
© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP