Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Plotting a series of Roots

• To: mathgroup at smc.vnet.net
• Subject: [mg128832] Re: Plotting a series of Roots
• From: Bob Hanlon <hanlonr357 at gmail.com>
• Date: Thu, 29 Nov 2012 06:05:46 -0500 (EST)
• Delivered-to: l-mathgroup@mail-archive0.wolfram.com
• Delivered-to: l-mathgroup@wolfram.com
• Delivered-to: mathgroup-newout@smc.vnet.net
• Delivered-to: mathgroup-newsend@smc.vnet.net
• References: <20121127083149.2C094687C@smc.vnet.net>

This is most of a solution.

M = 10000;
g = 1;
A = 10;
a = 1/100;(*initial plot temp*)
b = 12/10;(*final plot temp*)

c = 10^-8;(*initial temp*)
d = 0;(*initial \[Beta]*)
m = 1;

s[\[Alpha]_?NumericQ, t_?NumericQ] := Module[
   {bb = (g/(2*\[Pi])^(3/2)*(m/T)^(3/2)*E^(-m/T))},
   \[Beta][t] /. NDSolve[{\[Beta]'[T] ==
        (3*\[Alpha]^2*M*T^(5/2))/(Sqrt[2*g]*m^(9/2))*
         (bb^2 - \[Beta][T]^2),
       \[Beta][c] == d}, \[Beta], {T, a, b}, Method -> "BDF"][[1]]];

Plot3D[s[alpha, temp],
 {temp, a, b}, {alpha, 0, 1.2},
 AxesLabel -> (Style[#, Bold, 14] & /@
    {"T", "| \[Alpha] |", "\[Beta]"}),
 ViewPoint -> {1.3, -2.4, 2.}]

maxThreshold = NMaximize[{s[alpha, temp],
   0 <= alpha <= 1.2, a <= temp <= b}, {alpha, temp}]

{0.0260268, {alpha -> 1.02633, temp -> 0.66908}}

Manipulate[
 Module[{pt, t1, t},
  t = Union[Select[
      t1 /. FindRoot[{Abs[s[\[Alpha], t1] - value]},
          {t1, #}] & /@
       {0.4`, 1.0`}, a <= # <= b &],
     SameTest -> (Abs[#1 - #2] < 10^-6 &)] //
    Quiet;
  Column[{
    ContourPlot[s[alpha, temp],
     {temp, a, b}, {alpha, 0, 1.2},
     Contours -> {value},
     ContourShading -> None,
     Epilog -> {Red,
       AbsolutePointSize[4],
       Tooltip[Point[pt = {#, \[Alpha]}], pt] & /@ t},
     PlotRange -> {0, 1.25},
     PlotPoints -> 30,
     FrameLabel -> (Style[#, Bold, 14] & /@
        {"T", "\[Alpha]"}),
     WorkingPrecision -> 25,
     ImageSize -> 300],
    If[ Length [t] > 1, "For \[Alpha] = " <>
      ToString[\[Alpha]] <> ",  \[CapitalDelta]T = " <>
      ToString[t[[2]] - t[[1]], TraditionalForm], ""]}]],
 {{value, 0.022}, 0.001,
  Floor[maxThreshold[[1]], 0.001], 0.001,
  Appearance -> "Labeled"},
 {{\[Alpha], 1, "| \[Alpha] |"}, 0, 1.2, Appearance -> "Labeled"},
 Deployed -> True,
 ContinuousAction -> False]

If output panel displays $Aborted, wait for display.

FindRoot does not always find both roots when there are two. The
initial starting values for FindRoot need to be refined (made
adaptive).


Bob Hanlon


On Tue, Nov 27, 2012 at 3:31 AM, William Duhe <wjduhe at loyno.edu> wrote:
> So here I have an algorithm that gives me how my roots change as a functi=
on of lambda or t1[lambda,1]:
>
> s1[lambda_, t_] =
>   x[t] /. DSolve[{x'[t] == lambda, x[0] == 0}, x[t], t][[1]];
>
> lambda t;
>
>
> t1[lambda_, value_] = t /. Solve[s1[lambda, t] == value, t][[1]];
>
> value/lambda;
>
>
> s1[lambda, t1[lambda, value]];
>
> value;
>
> Plot[t1[lambda, 1], {lambda, .1, 1}, PlotRange -> Automatic]
>
>
> What I would like to do is in a similar fashion solve the differential eq=
uation bellow and plot how a particular root of that equation changes with =
\[Alpha]. It is important to note here that I have to use NDSolve rather th=
an DSolve for this type of equation.What I would like is analogous to the a=
bove code modified to be t1[\[Alpha],1]with the modified equations.
>
> M = 10000;
> g = 1;
> \[Alpha] = 1;
> A = 10;
> a = .01;(*initial plot temp*)
> b = 1.2; (*final plot temp*)
> c = 0.00000001; (*initial temp*)
> d = 0; (*initial \[Beta]*)
> m = 1;
> bb = (g/(2*\[Pi])^(3/2)*(m/T)^(3/2)*E^(-m/T));
>
> s = NDSolve[{\[Beta]'[T] == (3*\[Alpha]^2*M*T^(5/2))/(
>       Sqrt[2*g]*m^(9/2))*(bb^2 - \[Beta][T]^2), \[Beta][c] ==
>      d}, \[Beta], {T, a, b}, Method -> "BDF"];
>

• References:
  • Re: Plotting a series of Roots
    • From: William Duhe <wjduhe@loyno.edu>