1
$\begingroup$

I want plot $W$ vs $t$

eqn= t^3 + (4 - 8/Sqrt[\[Pi]]) w^2 + (3 w^4)/8 + (2 E^(w^2/t) \[Pi] w^2 (-2 t + w^2) Erfc[w/(Sqrt[2] Sqrt[t])]^2)/t ==1/8 t (96 + 56 t + 11 w^2) + (E^(w^2/(2 t)) w (-64 w^2 + Sqrt[\[Pi]] (t (-160 + 7 t) - 8 (-8 + t) w^2 + 3 w^4)) Erfc[w/(
Sqrt[2] Sqrt[t])])/(8 Sqrt[2] Sqrt[t])

I tried Plot using: solns= Solve[eqn, w] // Normal and obtain all solutions of $W$ as the function of $t$ and then plot with

Plot[Evaluate[w /. solns], {t, 0, 3},PlotRange -> {{0.001, 3}, {-3, 3}}, Frame -> True, AspectRatio -> 1, PlotLegends -> Automatic]

But I not getting. I try using CountorPlot, but the plot is horrible. Thanks in advance!.

$\endgroup$
2
$\begingroup$

Because it doesn't seem to be possible to solve for $w(t)$, what you could do to obtain the plot of $w(t)$ is by numerically solving for $w$ for different values of $t$ with FindRoot. The results can then be plotted with ListLinePlot.

numberOfPoints = 300;
wStart = 1;
ts = Rest @ Subdivide[0, 3, numberOfPoints];
ws = Last @* Last /@ Table[
  FindRoot[Evaluate[eqn /. t -> n], {w, wStart}],
  {n, ts}
];
ListLinePlot[Transpose @ {ws, ts}]

(Note that Rest is to exclude the case in which $t = 0$.)

ListLinePlot

Update

At first I ignored the FindRoot::lstol messages, which I shouldn't have. One way of checking if each pair of numerically-obtained $(w, t)$ actually satisfies eqn is by looking at the difference between its left and right sides. The difference should be close to zero.

Trying this:

numberOfPoints = 5;
wStart = 1;
ts = Rest @ Subdivide[0, 3, numberOfPoints];
ws = Last @* Last /@ Table[
  FindRoot[Evaluate[eqn /. t -> n], {w, wStart}],
  {n, ts}
];
points = Transpose @ {ws, ts};
diff = Subtract @@ List @@ eqn;
diff /. {w -> First @ #, t -> Last @ #} & /@ points

we get:

{-4.72339, -14.1116, -26.7086, -41.0978, -55.888}

As they're not relatively close to zero, the numerical solutions are bad. One way of addressing this is by giving FindRoot a better wStart.

To find it, we could explore the plot of the difference at some values of t to visually identify w at which diff is zero. It appears that

Plot[Evaluate[Table[diff /. t -> n, {n, ts}]], {w, -3, 10}, PlotRange -> {-600, 50}]

Plot

which signifies that wStart should be somewhere near -2 for $t \in (0, 3]$. Let's try wStart = -3:

numberOfPoints = 5;
wStart = -3;
ts = Rest @ Subdivide[0, 3, numberOfPoints];
ws = Last @* Last /@ Table[
  FindRoot[Evaluate[eqn /. t -> n], {w, wStart}],
  {n, ts}
];
points = Transpose @ {ws, ts};
diff = Subtract @@ List @@ eqn;
diff /. {w -> First @ #, t -> Last @ #} & /@ points

from which we get

{2.226*10^-13, 4.9738*10^-14, 4.36984*10^-13, 7.31859*10^-13, -4.54747*10^-13}

which are all close to zero, so this wStart is good. Now, back to the code at the beginning, with the better wStart (and note that because t shouldn't be too close to zero, I let ts start at 11/100 rather than 0):

numberOfPoints = 300;
wStart = -3;
ts = Subdivide[11/100, 3, numberOfPoints];
ws = Last @* Last /@ Table[
  FindRoot[Evaluate[eqn /. t -> n], {w, wStart}],
  {n, ts}
];
ListLinePlot[Transpose @ {ws, ts}]

No more FindRoot::lstol messages.

ListLinePlot

$\endgroup$
5
  • $\begingroup$ Hi @Talki, thanks. I have a problem with your code because I have an alert in the plot, of the kind: ************************ $FindRoot:$ The line search decreased the step size to within tolerance specified by AccuracyGoal and PrecisionGoal but was unable to find a sufficient decrease in the merit function. You may need more than MachinePrecision digits of working precision to meet these tolerances. ******************** $General:$ Further output of FindRoot::lstol will be suppressed during this calculation. ************************ And the plot blue is the same, but without the frame. $\endgroup$ – will.al Aug 16 '18 at 2:05
  • 1
    $\begingroup$ @will.al Those warnings come from FindRoot for some values of t and wStart, and basically mean that w solved may not be correct. You might want to adjust wStart or perhaps change the method of FindRoot until the warnings disappear, but I wouldn’t find them concerning, because the plot is smooth. As to the frame, it’s just the matter of formatting the plot; consult the documentation on relevant options of ListLinePlot. $\endgroup$ – Taiki Aug 16 '18 at 6:34
  • 1
    $\begingroup$ @will.al Gosh, I look into the issue and the numerical solutions are really bad... Updating the answer right now... $\endgroup$ – Taiki Aug 16 '18 at 7:26
  • 1
    $\begingroup$ @will.al Done! What we can learn from this is that it is important to find a good starting point for FindRoot somehow first. $\endgroup$ – Taiki Aug 16 '18 at 8:54
  • $\begingroup$ Thank you so much @Taiki. $\endgroup$ – will.al Aug 16 '18 at 20:58
2
$\begingroup$

A way:

eqn = t^3 + (4 - 8/Sqrt[\[Pi]]) w^2 + (3 w^4)/
8 + (2 E^(w^2/t) \[Pi] w^2 (-2 t + w^2) Erfc[
    w/(Sqrt[2] Sqrt[t])]^2)/
t - (1/8 t (96 + 56 t + 
    11 w^2) + (E^(w^2/(2 t)) w (-64 w^2 + 
      Sqrt[\[Pi]] (t (-160 + 7 t) - 8 (-8 + t) w^2 + 3 w^4)) Erfc[
     w/(Sqrt[2] Sqrt[t])])/(8 Sqrt[2] Sqrt[t])) // Simplify

ContourPlot[eqn == 0, {t, 1/10, 3}, {w, -3, 3}, FrameLabel -> Automatic]

enter image description here

In near point t=0

ContourPlot[eqn == 0, {t, 1/10000, 3}, {w, -3, 3}, FrameLabel -> Automatic,
PlotPoints -> 100, MaxRecursion -> 4, WorkingPrecision -> 20]

Real part of eqn:

 Show[{ContourPlot[(eqn // Re) == 0, {t, -2, -1/100}, {w, -3, 3}, 
 FrameLabel -> Automatic, WorkingPrecision -> 20], 
 ContourPlot[(eqn // Re) == 0, {t, 1/100, 3}, {w, -3, 3}, 
 FrameLabel -> Automatic, WorkingPrecision -> 20]}, 
 PlotRange -> {{-3, 3}, {-3, 3}}]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you so much @Mariusk Iwaniuk. $\endgroup$ – will.al Aug 16 '18 at 20:58

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.