Max-Min for Real Valued Functions
of a Vector Variable

by
K. D.  Stroyan
University of Iowa

copyright 1997 by Academic Press, Inc. - All rights reserved.

Special Mathematica Functions used in this NoteBook

We told you not to look.  This horrible stuff sets various defaults and defines some functions needed to draw the geometric side of the lexicon.  Ignore the details here and go on to the lesson.

Off[General::spell];
Off[General::spell1];
Off[ParametricPlot3D::ppcom];
Off[ParametricPlot::"ppcom"];
Needs["Graphics`Colors`"];

SetOptions[Graphics,Axes->False,AxesOrigin->{0,0},AspectRatio->Automatic];
SetOptions[Graphics3D,ViewPoint->{5,2,1},Boxed->False,AspectRatio->Automatic];
SetOptions[ParametricPlot3D,ViewPoint->{5,2,1},AspectRatio->Automatic];
SetOptions[Plot3D,ViewPoint->{5,2,1},BoxRatios->{1,1,1}];
SetOptions[ParametricPlot,AspectRatio->Automatic];
SetOptions[Plot,AspectRatio->Automatic];

\(\(parametricCrv3D[X, {t_, tmin_, tmax_, step_}, opns___] := 
	
      Module[{tPoints, tt}, 
		
        tPoints\  = \ Table[tt, {tt, tmin, tmax, step}]; 

        Return[Show[Graphics3D[{opns, 
		Line[Map[N[X[#]]&, tPoints]]}]]]; 
        
		]; \)\)

colorQ[a_]:=(Head[a]===RGBColor);
grayQ[a_]:=(Head[a]===GrayLevel);
thickQ[a_]:=(Head[a]===Thickness);
absthickQ[a_]:=(Head[a]===AbsoluteThickness);
notruleQ[u_] := !(Head[u]===Rule);
ruleQ[u_] := (Head[u]===Rule);

Norm::usage = "Norm[expr] returns the Euclidean length of the
		vector, 'expr'.";

Norm[a_?VectorQ] := Sqrt[a.a];

Angle[a_?VectorQ,b_?VectorQ] := ArcCos[(a.b)/(Norm[a] Norm[b])]

Proj[a_?VectorQ,b_?VectorQ] := ((a.b)/(b.b))b

tol = .5*10^-6;

OrthUp[a_?VectorQ] :=
	Module[{b,c,d,f},
		d = N[a/Norm[a]];
		If[Chop[d[[3]]^2 - 1,tol] == 0, b={1,0,0} ,
		b = {0,0,1} - d[[3]] d; b = b/Norm[b];];
	Return[b]];
	
OrthSet[a_?VectorQ] :=
	Module[{b,c,d},
		d = N[a/Norm[a]];
		If[Chop[d[[1]],tol]==0,b={1,0,0},
			 If[Chop[d[[2]],tol]==0,b={0,1,0},
			  b={-d[[2]],d[[1]],0}]];
			b=b/Norm[b];c = Cross[d,b];
	Return[{b,c/Norm[c],d}]];

				
Rotate[a_?VectorQ,theta_] :=
	Module[{u,v,r},
		u = OrthSet[a];
		v = Transpose[u];
		r = N[{{Cos[theta],-Sin[theta],0},{Sin[theta],Cos[theta],0},{0,0,1}}];
	Return[v.r.u]];

Vector2D[tail_,tip_,opts___]:=
	Module[{ntail,ntip,sopts,Punit,up,arrow},
	ntail = N[tail];
	ntip = N[tip];
	
	sopts = Join[Select[{opts},colorQ],Select[{opts},
				thickQ],Select[{opts},absthickQ],Select[{opts},grayQ]];

If[Chop[ntail.ntail+ntip.ntip,tol] == 0,
			(*too small to plot or not number*)
			Return[Graphics[Point[{0,0}]]];
	,						
If[Chop[(ntip-ntail).(ntip-ntail),tol] == 0,
		Return[Graphics[{Join[sopts,{Line[{ntail,ntip}]}]}]];
	,
	Punit =  0.125 (ntip-ntail) ;
	up = 0.3 {-Punit[[2]],Punit[[1]]};
	arrow = Line[{ntail,ntip,ntip-Punit+up,ntip,ntip-Punit-up}];
	]];
Return[Graphics[{Join[{AbsoluteThickness[2]},Join[sopts,{arrow}]]}]];
];

Vector3D[tail_,tip_,opts___]:=
	Module[{ntail,ntip,sopts,Punit,up,u2,u3,u4,rotmat,arrow},
	ntail = N[tail];
	ntip = N[tip];
	
	sopts = Join[Select[{opts},colorQ],Select[{opts},
				thickQ],Select[{opts},absthickQ],Select[{opts},grayQ]];

If[Chop[ntail.ntail+ntip.ntip,tol] == 0,
			(*too small to plot or not number*)
			Return[Graphics3D[Point[{0,0,0}]]];					
	,		
If[Chop[(ntip-ntail).(ntip-ntail),tol] == 0,
		Return[Graphics3D[{Join[sopts,{Line[{ntail,ntip}]}]}]];
	,
	Punit = (ntip-ntail);
	rotmat = Rotate[Punit,N[Pi/2]];
	up = OrthUp[Punit];
	Punit = 0.125 Punit;
	up = 0.3 Norm[Punit] up;
	u2 = rotmat.up;
	u3 = rotmat.u2;
	u4 = rotmat.u3;
	arrow = Line[{ntail,ntip,
				ntip - Punit + up,ntip,
				ntip - Punit + u2,ntip,
				ntip - Punit + u3,ntip,
				ntip - Punit + u4}];
	]];
Return[Graphics3D[{Join[{AbsoluteThickness[2]},Join[sopts,{arrow}]]}]];
];

aRCtAN[y_,x_] := Module[{v},
	If[ Chop[N[x],tol] == 0 ,If[ N[y] < 0, v = -N[Pi/2], v = N[Pi/2]],
		v = N[ArcTan[y/x]];
		If[ x < 0 && y < 0, v = N[Pi -  v],v]];
	Return[v]];

Arc2D[X_,Y_,opts___] := Graphics[{opts, Disk[{0,0},1,
{Min[aRCtAN[N[X[[2]]],N[X[[1]]]],aRCtAN[N[Y[[2]]],N[Y[[1]]]]]
						,
Max[aRCtAN[N[X[[2]]],N[X[[1]]]],aRCtAN[N[Y[[2]]],N[Y[[1]]]]]}]}];

Arc3D[X_,Y_] := 
	Module[{t,U,V},
		U[V_]:= N[(1/Sqrt[V.V]) V];
		Return[Graphics3D[
		Polygon[Append[Table[U[t X + (1-t) Y],{t,0,1,0.1}],{0,0,0}]]
				]
		]
	];

(*Zero Arrow causes trouble. Put in Vector?*)

Vector[tail_,tip_,opts___]:=
	If[Length[N[tail]]==2,Return[Vector2D[tail,tip,opts]],
		Return[Vector3D[tail,tip,opts]]];
		
Arrow[vec_,opts___]:= 
	Module[{a,b},
				If[Length[N[vec]]==2,
				a=ToExpression["Tail"]/.Select[{opts},ruleQ]/.
					{ToExpression["Tail"]->{0,0}};
				Return[Vector2D[a,a+vec,opts]],
				a=ToExpression["Tail"]/.Select[{opts},ruleQ]/.
					{ToExpression["Tail"]->{0,0,0}};
				Return[Vector3D[a,a+vec,opts]]]
				];

Frame2D[delta_] := 
      Graphics[{
            {Green,Line[{{-delta/4,0},{delta,0}}]},
                    Text["x",{1.01 delta,0}],
            {Green,Line[{{0,-delta/4},{0,delta}}]},
                    Text["y",{0, 1.01 delta}]}];

Frame3D[delta_] := 
      Graphics3D[{
            {Green,Line[{{-delta/4,0,0},{delta,0,0}}]},
                    Text["x",{1.01 delta,0,0}],
            {Green,Line[{{0,-delta/4,0},{0,delta,0}}]},
                    Text["y",{0, 1.01 delta,0}],
            {Green,Line[{{0,0,-delta/4},{0,0,delta}}]},
                    Text["z",{0,0,1.01 delta}]}];

View2D[stuff_] := Show[stuff,Frame2D[1]];
View3D[stuff_] := Show[stuff,Frame3D[1]];

Notebook Overview

Max-min theory has two main results, the Critical Point Theorem and the Extreme Value Theorem.  Your job is to formulate your own working versions of these results using the examples below and then to apply them to some max-min problems.
	Solving max-min problems, we "set the partials equal to zero," but why?  What does that tell us?  How do we know if we even have a max or min?  The prupose of this NoteBook is to help you think critically about your computations.  Work through the NateBook answering the questions as you go.  Your goal is to understand how the Critical Point Theorem and Extreme Value theorem work together in max-min problems.

References to the Text

This NoteBook goes with Chapter 19 of the text.

Review on Partial and Total Derivatives:
(The Mother of All Differentiation Review Problems)

The next cell contains a computation to review the various uses of partial derivatives. The computation:

(1)  Finds the symbolic partial derivatives of  f[x,y]  with respect to  x  and  y.

(2)  Computes these derivatives at a particular point (x1,y1) = (9/4,7/4).

(3)  Uses these particular partials in the total derivative and gradient to draw a tangent plane with its normal vector and draw the tangent line to the contour level through (x1,y1) with its normal.

You need to have a clear idea of the meanings of these various quantities in order to use them for max-min theory.   <Enter> the computation and then answer the questions after the output.

Clear[x, y, z, f, dx, dy, dz, p, v, pfpx, pfpy, gradf]; \(f[x_, y_] := 5\ x\ y\ Exp[\(-\((x\^2\/2 + y\^2\/3)\)\)]; 

    pfpx[x_, y_] := \ Evaluate[D[f[x, y], x]]; 

    pfpy[x_, y_] := \ Evaluate[D[f[x, y], y]]; 

    gradf[x_, y_]\  := \ {pfpx[x, y], pfpy[x, y]}; 

x1 = 2.25; 

    \(y1 = 1.75; \)\)d = 5; z1 = f[x1, y1]; dz[dx_, dy_] := pfpx[x1, y1] dx + pfpy[x1, y1] dy; p = {x1, y1, z1}; v = {-pfpx[x1, y1], -pfpy[x1, y1], 1}; Print["The numerical differential  dz = ", N[dz[dx, dy]]]; Print["The numerical gradient  Grad f = ", N[gradf[x1, y1]]]; 
    Print["Normal vector v = ", N[v]]; Print[" at point  p =", N[p]]; plane = 
      Plot3D[dz[x - x1, y - y1] + z1, {x, x1 - (d/2), x1 + (d/2)}, {y, 
          y1 - (d/2), y1 + (d/2)}, PlotRange -> {z1 - d, z1 + d}, 
        ViewPoint -> {0.839, -3.200, 0.713}, 
        PlotPoints -> {2, 2}, Axes -> False, 
        DisplayFunction -> Identity]; surface = 
      Plot3D[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {z1 - d, z1 + d}, PlotPoints -> 30, 
        ViewPoint -> {0.839, -3.200, 0.713}, 
        AxesLabel -> {"x", "y", "z"}, 
        DisplayFunction -> Identity]; combine = 
      Show[{plane, surface, Graphics3D[{PointSize[0.02], Point[p]}], 
          Arrow[v, Tail -> p]}, 
        DisplayFunction -> $DisplayFunction]; line = 
      ContourPlot[
        gradf[x1, y1] . {x - x1, y - y1}, {x, x1 - d, x1 + d}, {y, y1 - d, 
          y1 + d}, Contours -> {0}, ContourShading -> False, 
        DisplayFunction -> Identity]; contour = 
      ContourPlot[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotPoints -> 30, DisplayFunction -> Identity]; Show[{contour, Arrow[gradf[x1, y1], Tail -> {x1, y1}, Red], 
        Frame2D[1], line}, DisplayFunction -> $DisplayFunction];

Questions on the review example:

The input point (x1,y1) = (9/4,7/4) ~ (2.25,1.75) shown above on the surface and contour plots is not a maximum point nor a minimum point.  Our basic question is: "Why not?"

QUESTION 1: What is the symbolic formula for the gradient in terms of partial derivatives?

ANSWER 1:

QUESTION 2:  What is the numerical value of the gradient vector at the point (x1,y1) = (2.25,1.75)? (HINT: Read the print-out.)

ANSWER 2:

QUESTION 3: Which vector in the figures above is the gradient at (x1,y1)?

ANSWER 3:

QUESTION 4: The tangent plane to the surface above (x1,y1) has explicit equation in (dx,dy,dz)-coordinates:

ANSWER 4:

QUESTION 5: A normal vector to the tangent plane above (x1,y1) with positive z-component is:

ANSWER 5:

QUESTION 6: What is the connection between the answers to 3, 4, and 5, that is, what is the connection between the gradient, a normal vector to a tangent plane and the explicit equation of the tangent plane?

ANSWER 6:

QUESTION 7: The tangent plane at (x1,y1) "slopes" upward fastest in the direction of the (x,y)- vector:

ANSWER 7:  Most sloping direction:

QUESTION 8: The "slope of the tangent plane" could be defined as the rate of increase of  z  in the direction of fastest increase.  What is this slope at (x,y) = (2.25,1.75)?

ANSWER 8: Amount of maximal slope:

QUESTION 9: The four points (x,y) = (0,0),
(-1,Sqrt[3/2]),
(-1,-Sqrt[3/2]),
(1,Sqrt[3/2]),
(1,-Sqrt[3/2])
lie below points on the surface where the tangent plane is horizontal.  What is the value of a normal vector to the tangent plane at these points?  What is the value of the gradient?

ANSWER 9:

QUESTION 10: Which point(s) are the maximum? Which are the minimum? and Why can't (x1,y1) = (2.25,1.75) be either one?

ANSWER 10:

Critical Thinking

Don't Monkey Around, It Can't Be Here

The next cell computes partials and graphs a cubic polynomial related to the "monkey saddle."

Clear[x, y, z, f, dx, dy, dz, p, v, pfpx, pfpy, gradf]; f[x_, y_] := 3 x - (x^3) - 3 x (y^2);

pfpx[x_, y_] :=  Evaluate[D[f[x, y], x]];
pfpy[x_, y_] :=  Evaluate[D[f[x, y], y]];

gradf[x_, y_] := {pfpx[x, y], pfpy[x, y]};
x1 = 0; 
      y1 = 0; z1 = f[x1, y1]; d = 2; surface = 
      Plot3D[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {z1 - d, z1 + d}, PlotPoints -> 30, 
        ViewPoint -> {0.796, -2.805, 1.718}, 
        AxesLabel -> {"x", "y", "z"}, 
        ClipFill -> None]; contour = 
      ContourPlot[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotPoints -> 30];

The first question is: Where are the critical points of this function?

crits = 
      Show[{contour, 
          Graphics[{
              AbsolutePointSize[5], {Point[{-1, 0}], Point[{1, 0}], 
                Point[{0, -1}], Point[{0, 1}]}}]}];

The second question is: Could any other point be a maximum or minimum?

Let's look at the point (x,y) = (0,0) with the gradient:

grad = Arrow[(1/7) gradf[0, 0], Blue, AbsoluteThickness[2]]; point = Graphics[{Blue, AbsolutePointSize[4], Point[{0, 0}]}]; Show[crits, grad, point];

QUESTION:  Why does the little blue arrow point to the right?

YOUR ANSWER:

Here is a bunch of gradients on a circle of radius 1/2.

r = (1/2); grads = 
      Table[Arrow[(1/7) gradf[r Cos[t], r Sin[t]], 
          Tail -> r {Cos[t], Sin[t]}, Blue, AbsoluteThickness[2]], {t, 
          0, 2 π, (π/5)}]; Show[crits, grads];

QUESTION:  Why do the little blue arrows point to the right?

YOUR ANSWER:

Here is a bunch of gradients on a circle of radius 5/4.

r = (5/4); grads = 
      Table[Arrow[(1/7) gradf[r Cos[t], r Sin[t]], 
          Tail -> r {Cos[t], Sin[t]}, Blue, AbsoluteThickness[2]], {t, 
          0, 2 π, (π/5)}]; Show[crits, grads];

QUESTION:  Why don't the little blue arrows point to the right?  Where do they point?  Why?

YOUR ANSWERS:

QUESTION: And Finally,

Where is the maximum of this function and where is the minimum?  
Why are these points extreme?

YOUR ANSWER:

Or Can It?

The final question in the last section was sucker bait.  This function has neither a maximum nor minimum.  Here's a look on a larger scale, notice where it's largest and smallest.

Clear[x, y, z, f, dx, dy, dz, p, v, pfpx, pfpy, gradf]; f[x_, y_] := 3 x - (x^3) - 3 x (y^2);

pfpx[x_, y_] :=  Evaluate[D[f[x, y], x]];
pfpy[x_, y_] :=  Evaluate[D[f[x, y], y]];

gradf[x_, y_] := {pfpx[x, y], pfpy[x, y]};
x1 = 0; 
      y1 = 0; z1 = f[x1, y1]; d = 3; surface = 
      Plot3D[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {z1 - d, z1 + d}, PlotPoints -> 30, 
        ViewPoint -> {0.796, -2.805, 1.718}, 
        AxesLabel -> {"x", "y", "z"}, 
        ClipFill -> None]; contour = 
      ContourPlot[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotPoints -> 30, DisplayFunction -> Identity]; crits = 
      Show[{contour, 
          Graphics[{
              AbsolutePointSize[5], {Point[{-1, 0}], Point[{1, 0}], 
                Point[{0, -1}], Point[{0, 1}]}}]}, 
        DisplayFunction -> $DisplayFunction];

A Better QUESTION:

AMONGST THE POINTS SHOWN ON THE CONTOUR PLOT ABOVE, where is the function largest?  Where is it smallest?  (How is the plot shaded?)   Why are these points at places where the gradient is NOT zero?

YOUR ANSWER:

Sum it Up

Your friend just finished high school calculus and you tell him about PARTIAL derivatives.  He gets the idea immediately and has a suggestion to help you with your max-min problems:

"Just compute the partial derivatives and set them BOTH equal to zero.  This is messy because you have to solve two equations, but if you can solve these, the maximum has to be one of the solutions."

You reply, "The solution part might work easily if we type

Solve[ gradf[x,y] == {0,0}]

or use some FindRoot[] command in Mathematica, so solution of the equations isn't the problem."

QUESTION:
Is your friend's suggestion right (assuming you can solve the equations)?

YOUR ANSWER:

QUESTION:
Could a point be the maximum of your function and yet have a non-zero gradient at that point?

YOUR ANSWER:

QUESTION:
Suppose a function  f[x,y]  has a non-zero gradient at (x1,y1), say gradf[x1,y1] = {-1/2,(Sqrt[3])/2}.  When can you be sure that f[x1,y1] is NOT the maximum?  How does this relate to The Critical Point Theorem of your text?

YOUR ANSWER:

Check your answer on the following:

\(f[x_, y_]\  := \ x^2\  + \ y^2/3; 

    Plot3D[f[x, y], {x, 0, 1}, {y, 0, 1}]; \)

Going to Extremes

The Extreme Value Theorem says that a continuous function attains both its max and min over a compact domain.  A compact domain is one that is both "closed " and bounded.

Why bounded?

If there are no limits on the size of  x  and  y, a function could get arbitrarily large or small.

Clear[x, y, z, f, dx, dy, dz, p, v, pfpx, pfpy, gradf]; \(f[x_, y_] := x\^3 - 3\ x\ y\^2; 


    pfpx[x_, y_] := \ Evaluate[D[f[x, y], x]]; 

    pfpy[x_, y_] := \ Evaluate[D[f[x, y], y]]; 

    gradf[x_, y_]\  := \ {pfpx[x, y], pfpy[x, y]}; 


    Print["Gradient f = ", gradf[x, y]]; 

x1 = 0; 
\(y1 = 0; \)\)d = 5; z1 = 0; surface = 
      Plot3D[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {z1 - d, z1 + d}, PlotPoints -> 40, 
        ViewPoint -> {0.839, -3.200, 0.713}, 
        AxesLabel -> {"x", "y", "z"}, 
        ClipFill -> None]; contour = 
      ContourPlot[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotPoints -> 30];

Boundlessly BIG or small:

Find points ((Subscript[x, 1]), (Subscript[y, 1])), ((Subscript[x, 2]), (Subscript[y, 2])) and ((Subscript[x, 3]), (Subscript[y, 3])) such that:

f[(Subscript[x, 1]), (Subscript[y, 1])] > (10^30)

ANSWER:

f[(Subscript[x, 2]), (Subscript[y, 2])] < -(10^30)

ANSWER:

f[(Subscript[x, 3]), (Subscript[y, 3])] = 0, but ((Subscript[x, 3])^2) + ((Subscript[y, 3])^2) > (10^30)

ANSWER:

What's Closed?

A domain for a function is "closed" if whenever a sequence of vectors  (xn,yn)  lie in the domain and  Limit (xn,yn) = (x0,y0)  exists in space, then the limit vector (x0,y0) also lies in the domain.  If this FAILS, a function could get bigger and bigger (or smaller and smaller) on the sequence, but noth ave a limiting value.  Here's an example:

Clear[x, y, z, f, dx, dy, dz, p, v, pfpx, pfpy, gradf]; \(f[x_, y_] := 
      Log[\(\((x - 1)\)\^2 + \((y + 1)\)\^2\)\/\(\((x + 1)\)\^2 + 
            \((y - 1)\)\^2\)]; 

pfpx[x_, y_] := \ Evaluate[D[f[x, y], x]]; 
    
pfpy[x_, y_] := \ Evaluate[D[f[x, y], y]]; 

    gradf[x_, y_]\  := \ Together[{pfpx[x, y], pfpy[x, y]}]; 


    Print["Gradient f = ", gradf[x, y]]; 

x1 = 0; 
\(y1 = 0; \)\)d = 5; z1 = 0; surface = 
      Plot3D[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {z1 - d, z1 + d}, PlotPoints -> 40, 
        ViewPoint -> {0.839, -3.200, 0.713}, 
        AxesLabel -> {"x", "y", "z"}, 
        ClipFill -> None]; contour = 
      ContourPlot[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotPoints -> 40];

BIG or small within bounds:

Find points ((Subscript[x, 1]), (Subscript[y, 1]))  and  ((Subscript[x, 2]), (Subscript[y, 2]))  such that:

QUESTION 1:  f[(Subscript[x, 1]), (Subscript[y, 1])] > (10^30), and  the vector norm  |{(Subscript[x, 1]), (Subscript[y, 1])}| < 2

ANSWER:

QUESTION 2:  f[(Subscript[x, 2]), (Subscript[y, 2])] < -(10^30) and  the vector norm  |{(Subscript[x, 2]), (Subscript[y, 2])}| < 2

ANSWER:

QUESTION 3:  What is the largest domain possible for the function  f[x,y] above?  Why?

ANSWER:

The Extreme Value Theorem

State the Extreme Value Theorem from your text and explain why the two examples from this section don't contradict it, even though neither has either a max or a min.

Mathematica's FindMinimum[ · ] for min and MAX

We know that the gradient vector G = ∇f[x,y]  of a function  z = f[x,y]  points in the direction of fastest increase at that (x,y) point.   We also know that the rate of increase is the norm,  |G|.  See the NoteBook  Grad  and the review problem above.

If we are at a point  (x,y)  where  ∇f[x,y]  is not zero and we move in the direction opposite the gradient, -∇f[x,y], we will decrease at the rate |∇f[x,y]|.  As we move, the direction of  ∇f[x,y]  will change, but if we keep moving, constantly pointing in the fastest way down, -∇f[x,y], the function will keep decreasing until  ∇f[x,y] = {0,0}.  At this point, the gradient does not help, because it does not give us a direction to move.

The Steepest way Down the Mountain

The Perfecto Skier in Problem 18.2 plots this course to move down the slope of altitude a given by  a = (x^2) + 2 (y^2):

\(Clear[a, x, y]; 
a[x_, y_] = x\^2 + 2\ y\^2; 

    gradA = {D[a[x, y], x], D[a[x, y], y]}\)\(Print["Gradient = ", gradA]; 

    topo = ContourPlot[a[x, y], {x, 0, 3}, {y, 0, 3}, 
        FrameLabel -> {"x", "y"}, 
        DisplayFunction -> Identity]; 
x = 1; y = 2; 

    topo = Show[topo, Arrow[0.1\ gradA, Tail -> {x, y}, Blue], 
        Graphics[{PointSize[0.03], Orange, Point[{x, y}]}], 
        DisplayFunction -> $DisplayFunction]; 

    Print["Gradient at (", x, ",", y, ")  as Blue arrow."]; \)

If we want to move in the direction opposite this vector, our change vector will satisfy

{dx,dy} = -k{x,2y}

for some positive constant  k.   Expressing this as a differential equation

(dy/dx) = ((2 y)/x)

We can solve this equation starting at a point like  (1,2)  as follows:

Clear[x, y, soln]; 
    soln =  DSolve[{x y'[x] == 2  y[x], y[1] ==  2}, y[x], x]path[x_]  = y[x] /. soln;

\(curve\  = \ 
      Plot[path[x], {x, 0, 1}, Ticks -> None, 
        PlotStyle -> {Thickness[0.01], Red}, DisplayFunction -> Identity]; 

    Show[topo, curve, DisplayFunction -> $DisplayFunction]; \)

Mathematica can move to the approximate place where  ∇f[x,y] = {0,0} with the command:

\(Clear[x, y]; 
FindMinimum[a[x, y], {x, 1}, {y, 2}]\)

In this simple example we see that  (x,y) = (0,0)  is the minimum because the function is a sum of squares. (We don't even need calculus.)  Following is the 3-D view:

\(Clear[x, X]; 

    X[x_]\  = Flatten[{{x +  .01}, path[x] +  .01, a[x, path[x]]}]; 

    SkiPath\  = \ parametricCrv3D[X, {x, 0, 1, 0.05}, Thickness[0.05], Red]; 
    
hill\  = \ 
      Plot3D[a[x, y], {x, 0, 2}, {y, 0, 2}, Ticks -> False, 
        AxesLabel -> {"x", "y", "z"}, Mesh -> False, 
        BoxRatios -> {1, 1, 3}, Boxed -> False, DisplayFunction -> Identity]; 
    
Show[hill, SkiPath, DisplayFunction -> $DisplayFunction]; \)

The Gradient Method is "Only Local"
(or Stuck in Monkey Mountain Lake)

This section shows that FindMinimum can lead us to a point that is only a local (or nearby) minimum, not a real averall minimum.

Now let's repeat the fast skier's path on Monkey Mountain:

\(Clear[a, x, y, gradA]; 
a[x_, y_] = 3\ x - x\^3 - 3\ x\ y\^2; 

    gradA[x_, y_] = {D[a[x, y], x], D[a[x, y], y]}; 

    Print["Gradient = ", gradA[x, y]]; 

    topo = ContourPlot[a[x, y], {x, \(-3\), 2}, {y, \(-2\), 2}, 
        FrameLabel -> {"x", "y"}, Contours -> 30, 
        PlotPoints -> 30, DisplayFunction -> Identity]; 
x = \(-1\); 
    y = 1; 
topo = 
      Show[topo, 
        Arrow[0.1\ gradA[\(-1\), 1], Tail -> {\(-1\), 1}, Blue], 
        Graphics[{PointSize[0.03], Blue, Point[{\(-1\), 1}]}], 
        Arrow[0.1\ gradA[\(-2\), 0], Tail -> {\(-2\), 0}, Orange], 
        Graphics[{PointSize[0.03], Orange, Point[{\(-2\), 0}]}], 
        DisplayFunction -> $DisplayFunction]; 

    Print["Gradients at (-1,1) and (-2,0)."]; \)

If we want to move in the direction opposite this vector, our change vector will satisfy

{dx,dy} = -k{3 - 3 (x^2) - 3 (y^2),-6 x y}

for some positive constant  k.   Expressing this as a differential equation

(dy/dx) = (((y^2) +  (x^2) -  1)/(2 x y))

Mathematica can solve this equation, but it is better to show the motion as a functin of time, because it stops when the gradient is zero.  Expressing this as differential equations with actual motion in time:

(dx/dt) = (y^2) +  (x^2) -  1

	(dy/dt) = 2 x y

We can solve these equations starting at a point like  (-1,1)  as follows:

\(Clear[x, y, t, soln]; 
tfinal\  = \ 10; 

    soln = \ NDSolve[{\(x'\)[t]\  == \ y[t]^2 + x[t]^2\  - \ 1, \ 
          \(y'\)[t]\  == \ 2\ x[t]\ y[t], \ x[0] == \ \(-1\), 
          y[0]\  == \ 1}, {x[t], y[t]}, {t, 0, tfinal}]; 

    path1[t_]\  = \ {x[t], y[t]} /. soln; 

    curve\  = \ 
      ParametricPlot[path1[t], {t, 0, tfinal}, Ticks -> None, 
        PlotStyle -> {Thickness[0.01], Red}, DisplayFunction -> Identity]; 

    topo = Show[topo, curve, DisplayFunction -> $DisplayFunction]; \)

We can solve this equation starting at another point like  (-2,0)  as follows:

\(Clear[x, y, t, soln]; 
tfinal\  = \ 10; 

    soln = \ NDSolve[{\(x'\)[t]\  == \ y[t]^2 + x[t]^2\  - \ 1, \ 
          \(y'\)[t]\  == \ 2\ x[t]\ y[t], \ x[0] == \ \(-2\), 
          y[0]\  == \ 0}, {x[t], y[t]}, {t, 0, tfinal}]; 

    path2[t_]\  = \ {x[t], y[t]} /. soln; 

    curve\  = \ 
      ParametricPlot[path2[t], {t, 0, tfinal}, Ticks -> None, 
        PlotStyle -> {Thickness[0.01], Brown}, DisplayFunction -> Identity]; 
    
topo = Show[topo, curve, DisplayFunction -> $DisplayFunction]; \)

Mathematica tries to approximate place where  ∇f[x,y] = {0,0} with the command:

\(Clear[x, y]; 
FindMinimum[a[x, y], {x, 1}, {y, 2}]\)

Smart function.  It knows something is fishy.  Let's see the critical points

Solve[gradA[x, y]  ==  {0, 0}]

Show[topo, 
      Graphics[{PointSize[0.03], DarkGreen, Point[{-1, 0}], 
          Point[{1, 0}], Point[{0, 1}], Point[{0, -1}]}]];

The problem here is that the gradient leads us to a local minimum, but not over the pass that leads farther down the mountain:

\(Clear[x1, y1, x2, y2]; x1[t_]\  = \ \(Flatten[path1[t]]\)[\([1]\)]; 

    y1[t_]\  = \ \(Flatten[path1[t]]\)[\([2]\)]; 

    x2[t_]\  = \ \(Flatten[path2[t]]\)[\([1]\)]; 

    y2[t_]\  = \ \(Flatten[path2[t]]\)[\([2]\)]; 
		
    SkiPath\  = \ 
      ParametricPlot3D[{{x1[t], y1[t], a[x1[t], y1[t]]}, {x2[t], y2[t], 
            a[x2[t], y2[t]]}}, {t, 0, tfinal}, 
	Ticks -> None	, 
        Boxed -> False, DisplayFunction -> Identity]; 

    hill\  = \ 
      Plot3D[a[x, y] -  .1, {x, \(-2\), 2}, {y, \(-2\), 2}, Ticks -> False, 
        AxesLabel -> {"x", "y", "z"}, Mesh -> False, 
        BoxRatios -> {1, 1, 1}, DisplayFunction -> Identity]; 

    Show[hill, SkiPath, 
      Graphics3D[{PointSize[0.03], DarkGreen, 
          Point[{\(-1\), 0, a[\(-1\), 0]}], Point[{1, 0, a[1, 0]}], 
          Point[{0, \(-1\), a[0, \(-1\)]}], Point[{0, 1, a[0, 1]}]}], 
      ViewPoint -> {2, 1, 2}, DisplayFunction -> $DisplayFunction]; \)

Maxima of  f[x,y]  are minima of  -f[x,y]

Here is a surface with two minima and two maxima.  You can clearly see them.

\(Clear[x, y, f]; 

    f[x_, y_] := 5\ x\ y\ Exp[\(-\((x\^2\/2 + y\^2\/3)\)\)]; 
x1\  = \ 0; 
    y1\  = \ 0; \ d\  = \ 5; 

    surface = 
      Plot3D[f[x, y], {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {\(-d\), \(+d\)}, PlotPoints -> 30, 
        ViewPoint -> {3, 1.5, 0.5}, 
        AxesLabel -> {"x", "y", "z"}]; \)

We will locate the minima accurately with FindMinimum[.], starting at places that look like a good place to start to ski to the bottom:

FindMinimum[f[x, y], {x, -2}, {y, 2}]

Plot the location on the surface:

surface  =  
      Show[surface, 
        Arrow[{0, 0, -1}, Tail -> {-1, 1.22, f[-1, 1.22]}, Red]];

Now we start in another corner and ski to the bottom of the other valley:

FindMinimum[f[x, y], {x, 3}, {y, -3}]

Plot the location on the surface:

surface  =  
      Show[surface, 
        Arrow[{0, 0, -1}, Tail -> {1, -1.22, f[1, -1.22]}, 
          Orange]];

If we plotted the function  -f[x,y], the graph would just be turned upside down.  Minimizing on that graph is the same as maximizing on the original, so now we locate the maxima accurately:

\(negSurf\  = \ 
      Plot3D[\(-f[x, y]\), {x, x1 - d, x1 + d}, {y, y1 - d, y1 + d}, 
        PlotRange -> {\(-d\), \(+d\)}, PlotPoints -> 30, 
        ViewPoint -> {3, 1.5, 0.5}, 
        AxesLabel -> {"x", "y", "z"}, 
        DisplayFunction -> Identity]; 

    Show[GraphicsArray[{negSurf, surface}], 
      DisplayFunction -> $DisplayFunction]; \)

FindMinimum[-f[x, y], {x, 3}, {y, 3}]FindMinimum[-f[x, y], {x, -3}, {y, -3}]

Plot the location on the surface:

surface  =  
      Show[surface, 
        Arrow[{0, 0, 1}, Tail -> {-1, -1.22, f[-1, -1.22]}, 
          Blue], Arrow[{0, 0, 1}, Tail -> {1, 1.22, f[1, 1.22]}, Brown]];

More "Local" Trouble

A bad place to start skiing in this example will take you off to infinity by the gradient.

FindMinimum[f[x, y], {x, 2}, {y, 2}]

Let's see the path:

\(Clear[x, y, fX, fY]; 
fX[x_, y_]\  = \ Evaluate[D[f[x, y], x]]; 

    fY[x_, y_]\  = \ Evaluate[D[f[x, y], y]]; 

    soln\  = \ 
      NDSolve[{\(x'\)[t]\  == \ fX[x[t], y[t]], 
				
          \(y'\)[t]\  == \ fY[x[t], y[t]], 
				x[0]\  == \ 2, 
				
          y[0] == 2}, {x[t], y[t]}, {t, 0, 1000}]; 

    path[t_]\  = \ Flatten[{x[t], y[t]} /. soln]; 

    ParametricPlot[path[t], {t, 0, 1000}, PlotRange -> {{0, 5}, {0, 5}}]; 
    \)

The problem here is that the downhill direction points toward infinity.  Worse yet, the hill gets flatter and flatter, os tha the gradient is nearly zero and you hardly move.

x'[t]  ==  fX[x[t], y[t]]\(\(y'\)[t]\  == \ fY[x[t], y[t]]
\)N[{fX[5, 5], fY[5, 5]}]

Summary

FindMinimum[f[x,y], {x,xGuess},{y,yGuess}]

and

FindMinimum[-f[x,y], {x,xGuess},{y,yGuess}]

will use a rfined version of the gradient method of skiing downhill in the steepest direction.  If you start at a "good" point (xGuess,yGuess), this will lead you to the minimum and (the negative of) the MAXIMUM.  However, since all this method does is move downhill, it may get stuck in a mountain valley or at the top of a molehill, rather than finding the true lowest and highest places.

Exercises

Exercise CD19.2.2

Work through the whole NoteBook above here answering the questions as you go.  Then solve the exercise below here.

Exercise CD19.4.1: A Max-Min Problem

Find the maximum and mimimum of the functions

a

f[x,y,z] =  z(y-x)

b

g[x,y,z] = x y z

amongst all x, y, and z such that  x >= 0, y >= 0, z >= 0, and  x + y + z = 1.

Explain why this problem satisfies the hypotheses of the Extreme Value Theorem.  Use the Critical Point Theorem carefully when you justify which point is a maximum or minimum.

Give both the value and location of the max amn min.

z = 1 - x - y; w := If[x > 0 && y > 0 && z > 0, x y z, 0]Plot3D[w, {x, 0, 1}, {y, 0, 1}, PlotRange -> { .001,  .04}, 
      ClipFill -> None, ViewPoint -> {5, -3, 2}, 
      AxesLabel -> {"x", "y", "z"}, Ticks -> None, 
      PlotPoints -> 40, BoxRatios -> {1, 1, 1}]; ContourPlot[w, {x, 0, 1}, {y, 0, 1}, 
      AxesLabel -> {"x", "y"}, Ticks -> None, 
      PlotPoints -> 40];

This function is zero all around the boundary of the domain of extremization and clearly has a max at the peak or center of the contour plot.  Here's Mathematica's solution to the MAX:

FindMinimum[-w, {x, 0.2}, {y, 0.3}]

Further Exercises are in the SvVarMxMn NoteBook