Local Extrema of f[x,y]

Therese Shelton and Kendall Richards
Southwestern University

Set-up

Clear[f,x,y,fx,fy,fxx,fyy,fxy,CP,n,disc]
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.

(Recall, you should also check where the gradient is undefined.)

fx[x_,y_]=(∂_x) f[x,y]
fy[x_,y_]=(∂_y) f[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]

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

N[CP]

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.

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

xlo=ylo=-2; xhi=yhi=2;

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

Length[CP]

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

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";
CP[[n]]
num1=disc[x,y]/.CP[[n]]
num2=fxx[x,y]/.CP[[n]]
If[And[num1>0,num2<0],type="local max" ];
If[And[num1>0,num2>0],type="local min" ];
If[num1<0,type="saddle point"];
Print[type]

Copy and paste the next cell, then execute, until you classify all critical points

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

An automated effort

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

Some graphs

numCon=50;
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]}/.CP[[index]],{index,1,Length[CP]}]

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

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