Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2004
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2004

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

Search the Archive

Re: envelope of an oscillatory InterpolatingFunction

  • To: mathgroup at smc.vnet.net
  • Subject: [mg49832] Re: envelope of an oscillatory InterpolatingFunction
  • From: Paul Abbott <paul at physics.uwa.edu.au>
  • Date: Tue, 3 Aug 2004 01:11:04 -0400 (EDT)
  • Organization: The University of Western Australia
  • Sender: owner-wri-mathgroup at wolfram.com

Hi Stergios:

>Thanks very much! Your RootsInRange is much better than my loop
>using NMaximize.  I do have one final detail to ask about.
>RootsInRange returns results of the form (where t is my
>variable):
>
>{t$9472 -> 3.3268729370875564`*^-7}

Actually, I broke the code by changing the variables (to avoid posting 
code with Greek symbols). I've appended the correct code below.

Also note that Ted Ersek's package at

  http://library.wolfram.com/infocenter/MathSource/4482/

is more robust that RootsInRange for finding all the roots of a function.

Cheers,
Paul



Notebook[{

Cell[CellGroupData[{
Cell["Envelope", "Section"],

Cell[TextData[{
  "Why not compute the values of the extrema of the ",
  Cell[BoxData[
      FormBox[
        StyleBox["InterpolatingFunction",
          "Input"], TraditionalForm]]],
  " and then use ",
  Cell[BoxData[
      FormBox[
        StyleBox["FindFit",
          "Input"], TraditionalForm]]],
  " to determine the envelope? For example,"
}], "Text"],

Cell[BoxData[
    RowBox[{"nsol", "=", 
      RowBox[{"First", "[", 
        RowBox[{"NDSolve", "[", 
          RowBox[{
            RowBox[{"{", 
              RowBox[{
                RowBox[{
                  RowBox[{\(5\ y[x]\), "+", 
                    RowBox[{
                      SuperscriptBox["y", "\[Prime]",
                        MultilineFunction->None], "[", "x", "]"}], "+", 
                    RowBox[{"10", " ", 
                      RowBox[{
                        SuperscriptBox["y", "\[Prime]\[Prime]",
                          MultilineFunction->None], "[", "x", "]"}]}]}], 
                  "\[Equal]", "0"}], ",", \(y[0] \[Equal] 1\), ",", 
                RowBox[{
                  RowBox[{
                    SuperscriptBox["y", "\[Prime]",
                      MultilineFunction->None], "[", "0", "]"}], 
"\[Equal]", 
                  "0"}]}], "}"}], ",", "y", ",", \({x, 0, 50}\)}], 
"]"}], 
        "]"}]}]], "Input"],

Cell[BoxData[
    \(Plot[Evaluate[y[x] /. \[InvisibleSpace]nsol], {x, 0, 50}, 
      PlotRange \[Rule] All]\)], "Input"],

Cell[TextData[{
  "Compute the (absolute) values of the extrema of the ",
  Cell[BoxData[
      FormBox[
        StyleBox["InterpolatingFunction",
          "Input"], TraditionalForm]]],
  ":"
}], "Text"],

Cell[BoxData[
    RowBox[{
      RowBox[{\({x, Abs[y[x]]}\), "/.", "\[InvisibleSpace]", 
        RowBox[{"RootsInRange", "[", 
          RowBox[{
            RowBox[{"Evaluate", "[", 
              RowBox[{
                RowBox[{
                  SuperscriptBox["y", "\[Prime]",
                    MultilineFunction->None], "[", "x", "]"}], "/.", 
                "\[InvisibleSpace]", "nsol"}], "]"}], ",", \({x, 0, 
50}\)}], 
          "]"}]}], "/.", "\[InvisibleSpace]", "nsol"}]], "Input"],

Cell["\<\
and then fit to find the envelope (here assuming exponential form):\
\
\>", "Text"],

Cell[BoxData[
    \(FindFit[%, c + a\/\[ExponentialE]\^\(b\ x\), {a, b, c}, x]\)], 
"Input"],

Cell[CellGroupData[{

Cell["Roots in Range", "Subsubsection"],

Cell["\<\
Here is some code for finding the roots of a function over a \
specified range:\
\>", "Text"],

Cell[BoxData[
    \(Needs["\<Utilities`FilterOptions`\>"]\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(RootsInRange[\[Delta]_, {\[Lambda]_, \[Lambda]min_, 
\[Lambda]max_}, 
        opts___] := 
      Module[{p, pts, x, f = Function[\[Lambda], Evaluate[\[Delta]]]}, 
        p = Plot[f[\[Lambda]], {\[Lambda], \[Lambda]min, \[Lambda]max}, 
            Compiled \[Rule] False, Evaluate[FilterOptions[Plot, 
opts]]]; 
        pts = Cases[First[p], Line[{x__}] \[Rule] x, \[Infinity]]; 
        pts = Map[First, 
            Select[Split[pts, Sign[Last[#2]] \[Equal] 
\(-Sign[Last[#1]]\) &], 
              Length[#1] \[Equal] 2 &], {2}]; \((FindRoot[
                f[\[Lambda]] \[Equal] 0, {\[Lambda], Sequence @@ ##1}, 
                Evaluate[FilterOptions[FindRoot, opts]]] &)\) /@ 
          pts]\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(RootsInRange::"\<usage\>" = "\<RootsInRange[f,{x,xmin,xmax}] 
generates \
a plot of f as a function of x from xmin to xmax and then uses FindRoot 
to \
determine the roots of f in the range (xmin,xmax).\>"; \)], "Input",
  InitializationCell->True]
}, Open  ]]
}, Open  ]]
},
FrontEndVersion->"5.0 for Macintosh",
ScreenRectangle->{{0, 1436}, {0, 878}},
AutoGeneratedPackage->None,
WindowSize->{861, 787},
WindowMargins->{{124, Automatic}, {Automatic, 24}}
]

-- 
Paul Abbott                                   Phone: +61 8 9380 2734
School of Physics, M013                         Fax: +61 8 9380 1014
The University of Western Australia      (CRICOS Provider No 00126G)         
35 Stirling Highway
Crawley WA 6009                      mailto:paul at physics.uwa.edu.au 
AUSTRALIA                            http://physics.uwa.edu.au/~paul


  • Prev by Date: Re: Re: PutAppend Command and Data Output
  • Next by Date: Forcing Argument Evaluation
  • Previous by thread: Re: envelope of an oscillatory InterpolatingFunction
  • Next by thread: Re: DiscreteDelta Evaluation Question