Local Extrema of f[x,y]

Therese Shelton and Kendall Richards
Southwestern University

Set-up

Clear[f,x,y,fx,fy,fxx,fyy,fxy,gradf,CPRules,CPs,n,numPts,disc,d1,d2]
Clear[p1,p2,xlo,xhi,ylo,yhi,numCon,type]
Clear[t1,p3,t2,p4]

Define a function of two variables.

f[x_,y_]:= 2x^3 y-y^2-3x*y

Note that the domain of this function is all of the real plane.

Find critical points

Calculate the 1st and 2nd order derivatives and the critical points just based on where the gradient is zero.

Also check where the gradient is undefined.  Our gradient is defined everywhere.

fx[x_,y_]=(∂_x) f[x,y]
fy[x_,y_]=(∂_y) f[x,y]

gradf[x_,y_]={fx[x,y],fy[x,y]}

fxx[x_,y_]=(∂_(x,x)) f[x,y]
fyy[x_,y_]=(∂_(y,y)) f[x,y]
fxy[x_,y_]=(∂_(x,y)) f[x,y]

the Hessian of f

MatrixForm[{{fxx[x,y],fxy[x,y]},{fxy[x,y],fyy[x,y]}}]

CPRules=Solve[{fx[x,y]==0,fy[x,y]==0},{x,y}]

N[CPRules]

All these points are contained between these values of x and of y:

xlo=-1.5; xhi = 1.5; ylo=-0.9;yhi=0.9;

This is the number of critical points, which are places in the domain where we might have extrema:

numPts=Length[CPRules]

CPs = Table[{x,y}/.CPRules[[i]],{i,1,numPts}]

We should double-check that these points are in the domain of f.  Critical points also include any points where f is defined but the gradient is not.  For this function, there are no other points, and all these points are in the domain of f.  Alternatively, we can calculate the function values:

Table[f[x,y]/.CPRules[[i]],{i,1,numPts}]

Test CPs

This is the "discriminant of f" or the determinant of the Hessian of f.

disc[x_,y_] = Det[{{fxx[x,y],fxy[x,y]},{fxy[x,y],fyy[x,y]}}]

Manual calculations  (you can skip this and use the automated effort)

If there are any critical points, execute this next cell to see the values needed to determine if it is an extremum.

n=1;
type="no info";
CPs[[n]]
d1=disc[x,y]/.CPRules[[n]]
d2=fxx[x,y]/.CPRules[[n]]
If[And[d1>0,d2<0],type="local max" ];
If[And[d1>0,d2>0],type="local min" ];
If[d1<0,type="saddle point"];
Print[type]

In general, for another function, you’ll need to copy and paste the next cell, then execute, until you classify all critical points.  Here, I’ve included it enough times to cover all the critical points in this case.

n=n+1;
type="no info";
CPs[[n]]
d1=disc[x,y]/.CPRules[[n]]
d2=fxx[x,y]/.CPRules[[n]]
If[And[d1>0,d2<0],type="local max" ];
If[And[d1>0,d2>0],type="local min" ];
If[d1<0,type="saddle point"];
Print[type]

n=n+1;
type="no info";
CPs[[n]]
d1=disc[x,y]/.CPRules[[n]]
d2=fxx[x,y]/.CPRules[[n]]
If[And[d1>0,d2<0],type="local max" ];
If[And[d1>0,d2>0],type="local min" ];
If[d1<0,type="saddle point"];
Print[type]

n=n+1;
type="no info";
CPs[[n]]
d1=disc[x,y]/.CPRules[[n]]
d2=fxx[x,y]/.CPRules[[n]]
If[And[d1>0,d2<0],type="local max" ];
If[And[d1>0,d2>0],type="local min" ];
If[d1<0,type="saddle point"];
Print[type]

n=n+1;
type="no info";
CPs[[n]]
d1=disc[x,y]/.CPRules[[n]]
d2=fxx[x,y]/.CPRules[[n]]
If[And[d1>0,d2<0],type="local max" ];
If[And[d1>0,d2>0],type="local min" ];
If[d1<0,type="saddle point"];
Print[type]

An automated effort

For[n=1,n≤Length[CPs], 
type="has no info from this method";
d1=disc[x,y]/.CPRules[[n]];
d2=fxx[x,y]/.CPRules[[n]];
If[And[d1>0,d2<0],type=" is a local max" ];
If[And[d1>0,d2>0],type=" is a local min" ];
If[d1<0,type=" is a saddle point"];
Print["Critical point", CPs[[n]], type];
n=n+1]

Some graphs

numCon=30;
p1=Plot3D[f[x,y],{x,xlo,xhi},{y,ylo,yhi},AxesLabel->{"x","y","z"}]
p2=ContourPlot[f[x,y],{x,xlo,xhi},{y,ylo,yhi},Contours->numCon]

Show the critical points on the surface and within the contour plot.

t1=Table[{x,y,f[x,y]}/.CPRules[[index]],{index,1,numPts}]

p3=ListPointPlot3D[t1,PlotStyle->PointSize[0.03]]
Show[p1,p3]

t2=Table[{x,y}/.CPRules[[index]],{index,1,numPts}]
p4=ListPlot[t2,PlotStyle->PointSize[0.03]]
Show[p2,p4]

CPs[[1]]

Show[{ContourPlot[f[x,y],{x,xlo,xhi},{y,ylo,yhi},ContourShading->False],
VectorPlot[gradf[x,y],{x,xlo,xhi},{y,ylo,yhi}], p4}]

Graph the gradient vector field using the same lengths so we can see the vectors better; length is meaningless here.

Show[{ContourPlot[f[x,y],{x,xlo,xhi},{y,ylo,yhi},ContourShading->False,Contours->20],
VectorPlot[gradf[x,y],{x,xlo,xhi},{y,ylo,yhi},VectorScale->{Small,Small,None}], p4}]