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

MathGroup Archive 1997

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

Search the Archive

Re: Minima

  • To: mathgroup at smc.vnet.net
  • Subject: [mg7995] Re: Minima
  • From: Paul Abbott <paul at physics.uwa.edu.au>
  • Date: Wed, 30 Jul 1997 23:57:48 -0400
  • Organization: University of Western Australia
  • Sender: owner-wri-mathgroup at wolfram.com

Bernhard Petri wrote:

> Is there a way to determin several (best all) minima and/or maxima of a
> interpolating function optained with ndsolve?

There is only *one* maxima or minima.  Do you mean all local maxima and
minima?

Code for finding the extrema of functions over a domain using Plot and
Cases 
was presented in "Maxima and minima over an interval," in The
Mathematica Journal 6(4): 26, 1996.  It also works with interpolating
functions:

 In[1]:= Delta[f_, {x_, a_, b_}] := Module[{y}, y = 
     Last[Transpose[Cases[Plot[f, {x, a, b}, 
          PlotRange -> All, DisplayFunction -> Identity], 
          _Line, Infinity][[1,1]]]]; {Min[y], Max[y]}]

 In[2]:= sol = First[NDSolve[{y''[x] == -y[x], y[0] == 1, y'[0] == 0},
y, 
     {x, -6, 6}]]; 

 In[3]:= Plot[y[x] /. sol, {x, -6, 6}]; 

Here we find the minima and maxima over (-6,6):

 In[4]:= Delta[y[x] /. sol, {x, -6, 6}]
 Out[4]= {-0.99999, 0.999987}

In the forthcoming issue of the Mathematica Journal, there is code for
finding roots of a function over a domain.  Applying this to the
derivative of a function yields the extrema:

 In[5]:= Needs["Utilities`FilterOptions`"]

 In[6]:= RootsInRange[d_, {l_, lmin_, lmax_}, 
   opts___] := Module[{s, p, x, 
    f = Function[l, Evaluate[d]]}, 
   s = Plot[f[l], {l, lmin, lmax}, 
      Compiled -> False, Evaluate[FilterOptions[Plot, opts]]]; 
    p = Cases[s, Line[{x__}] -> x, Infinity]; 
    p = Map[First, Select[Split[p, 
        Sign[Last[#2]] == -Sign[Last[#1]] & ], Length[#1] == 2 & ],
{2}]; 
    Apply[FindRoot[f[l] == 0, {l, ##1}, 
       Evaluate[FilterOptions[FindRoot, opts]]] & , p, {1}]]

For example:

 In[7]:= {x, y[x]} /. RootsInRange[y'[x] /. sol, {x, -6, 6}] /. sol //
Chop 
 Out[7]= {{-3.14159, -0.99999}, {0, 1.}, {3.14159, -0.99999}}

Cheers,
	Paul 

____________________________________________________________________ 
Paul Abbott                                   Phone: +61-8-9380-2734
Department of Physics                           Fax: +61-8-9380-1014
The University of Western Australia           
Nedlands WA  6907                     mailto:paul at physics.uwa.edu.au 
AUSTRALIA                              http://www.pd.uwa.edu.au/Paul

            God IS a weakly left-handed dice player
____________________________________________________________________


  • Prev by Date: Comparison of Mathematica on Various Computers
  • Next by Date: Re: How do I read/write binary image data? (fwd)
  • Previous by thread: Re: Minima
  • Next by thread: Help needed!