Lagrange Multipliers

2D examples

2D Example 1

Clear[f,g,fx,fy,gx,gy,x,y,L,eqn,pts,nearPts]
f[x_,y_]:= (y^2)-4 x* y + 4 (x^2)
fx[x_,y_]=(∂_x) f[x,y]
fy[x_,y_]=(∂_y) f[x,y]
g[x_,y_]:= (x^2)+  (y^2) - 1
gx[x_,y_]=(∂_x) g[x,y]
gy[x_,y_]=(∂_y)g[x,y]
eqns={fx[x,y] == L* gx[x,y],fy[x,y] == L* gy[x,y],g[x,y]==0}
pts=Solve[eqns,{x,y,L}]
f[x,y]/.pts
N[f[x,y]/.pts]
Print["Beware if the gradient is zero!"]
{gx[x,y], gy[x,y]}/.pts
Print["Some points near the solutions"]
nearPts=N[Table[{x+a*.1,y+b*.1,f[x+a*.1,y+b*.1]},{a,-1,1},{b,-1,1}]/.pts]

graph stuff

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

numCon=25;
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,ContourShading->False];
p2g=ContourPlot[g[x,y],{x,xlo,xhi},{y,ylo,yhi},Contours->numCon,ContourShading->False];
Show[p2,p2g]

p2ga=ContourPlot[g[x,y] == 0, {x,xlo,xhi},{y,ylo,yhi},Axes->True]

Show[{p2,p2ga},Axes->True]

t1=Table[{x,y,f[x,y]}/.pts[[index]],{index,1,Length[pts]}]
p3=ListPointPlot3D[t1,PlotStyle->PointSize[0.03]]
Show[p1,p3]

Table[Point[{x,y}/.pts[[index]]],{index,1,Length[pts]}]
Show[{p2,p2ga},Graphics[{PointSize[0.02`],%}],PlotRange->All,Axes->True]

Another 2D example

Clear[f,g,fx,fy,gx,gy,x,y,L,eqn,pts,nearPts]
f[x_,y_]:= 2 (x^2)+ x* y - (y^2) + y
fx[x_,y_]=(∂_x) f[x,y]
fy[x_,y_]=(∂_y) f[x,y]
g[x_,y_]:=2 x+ 3 y - 1 
gx[x_,y_]=(∂_x) g[x,y]
gy[x_,y_]=(∂_y)g[x,y]
eqns={fx[x,y] == L* gx[x,y],fy[x,y] == L* gy[x,y],g[x,y]==0}
pts=Solve[eqns,{x,y,L}]
f[x,y]/.pts
N[f[x,y]/.pts]
Print["Beware if the gradient is zero!"]
{gx[x,y], gy[x,y]}/.pts
Print["Some points near the solutions"]
nearPts=N[Table[{x+a*.1,y+b*.1,f[x+a*.1,y+b*.1]},{a,-1,1},{b,-1,1}]/.pts]

graph stuff

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

numCon=25;
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,ContourShading->False];
p2g=ContourPlot[g[x,y],{x,xlo,xhi},{y,ylo,yhi},Contours->numCon,ContourShading->False];
Show[p2,p2g]

p2ga=ContourPlot[g[x,y] == 0, {x,xlo,xhi},{y,ylo,yhi},Axes->True]

Show[{p2,p2ga},Axes->True]

t1=Table[{x,y,f[x,y]}/.pts[[index]],{index,1,Length[pts]}]
p3=ListPointPlot3D[t1,PlotStyle->PointSize[0.03]]
Show[p1,p3]

Table[Point[{x,y}/.pts[[index]]],{index,1,Length[pts]}]
Show[{p2,p2ga},Graphics[{PointSize[0.02`],%}],PlotRange->All,Axes->True]

3D examples

Clear[f,g,fx,fy,fz,gx,gy,gz,x,y,L,eqn,pts,nearPts]
f[x_,y_,z_]:= (x^2)+(y^2)+(z^2)
fx[x_,y_,z_]=(∂_x) f[x,y,z]
fy[x_,y_,z_]=(∂_y) f[x,y,z]
fz[x_,y_,z_]=(∂_z) f[x,y,z]
g[x_,y_,z_]:= x + y + z - 25
gx[x_,y_,z_]=(∂_x) g[x,y,z]
gy[x_,y_,z_]=(∂_y)g[x,y,z]
gz[x_,y_,z_]=(∂_z)g[x,y,z]
eqns={fx[x,y,z] == L* gx[x,y,z],fy[x,y,z] == L* gy[x,y,z],fz[x,y,z] == L* gz[x,y,z],g[x,y,z]==0}
pts=Solve[eqns,{x,y,z,L}]
f[x,y,z]/.pts
N[f[x,y,z]/.pts]
Print["Beware if the gradient is zero!"]
{gx[x,y,z], gy[x,y,z], gz[x,y,z]}/.pts
Print["Some points near the solutions"]
nearPts=N[Table[{x+a*.1,y+b*.1,z+ c*.1,f[x+a*.1,y+b*.1,z+c*.1]},{a,-1,1},{b,-1,1},{c,-1,1}]/.pts]

Clear[f,g,fx,fy,fz,gx,gy,gz,x,y,L,eqn,pts,nearPts]
f[x_,y_,z_]:= z - (x^2)+(y^2)
fx[x_,y_,z_]=(∂_x) f[x,y,z]
fy[x_,y_,z_]=(∂_y) f[x,y,z]
fz[x_,y_,z_]=(∂_z) f[x,y,z]
g[x_,y_,z_]:= x + y + z -1
gx[x_,y_,z_]=(∂_x) g[x,y,z]
gy[x_,y_,z_]=(∂_y)g[x,y,z]
gz[x_,y_,z_]=(∂_z)g[x,y,z]
eqns={fx[x,y,z] == L* gx[x,y,z],fy[x,y,z] == L* gy[x,y,z],fz[x,y,z] == L* gz[x,y,z],g[x,y,z]==0}
pts=Solve[eqns,{x,y,z,L}]
f[x,y,z]/.pts
N[f[x,y,z]/.pts]
Print["Beware if the gradient is zero!"]
{gx[x,y,z], gy[x,y,z], gz[x,y,z]}/.pts
Print["Some points near the solutions"]
nearPts=N[Table[{x+a*.1,y+b*.1,z+ c*.1,f[x+a*.1,y+b*.1,z+c*.1]},{a,-1,1},{b,-1,1},{c,-1,1}]/.pts]

blank templates, ready to fill in

Clear[f,g,fx,fy,gx,gy,x,y,L,eqn,pts,nearPts]
f[x_,y_]:=
fx[x_,y_]=(∂_x) f[x,y]
fy[x_,y_]=(∂_y) f[x,y]
g[x_,y_]:=
gx[x_,y_]=(∂_x) g[x,y]
gy[x_,y_]=(∂_y)g[x,y]
eqns={fx[x,y] == L* gx[x,y],fy[x,y] == L* gy[x,y],g[x,y]==0}
pts=Solve[eqns,{x,y,L}]
f[x,y]/.pts
N[f[x,y]/.pts]
Print["Beware if the gradient is zero!"]
{gx[x,y], gy[x,y]}/.pts
Print["Some points near the solutions"]
nearPts=N[Table[{x+a*.1,y+b*.1,f[x+a*.1,y+b*.1]},{a,-1,1},{b,-1,1}]/.pts]

Clear[f,g,fx,fy,fz,gx,gy,gz,x,y,L,eqn,pts,nearPts]
f[x_,y_,z_]:=
fx[x_,y_,z_]=(∂_x) f[x,y,z]
fy[x_,y_,z_]=(∂_y) f[x,y,z]
fz[x_,y_,z_]=(∂_z) f[x,y,z]
g[x_,y_,z_]:= 
gx[x_,y_,z_]=(∂_x) g[x,y,z]
gy[x_,y_,z_]=(∂_y)g[x,y,z]
gz[x_,y_,z_]=(∂_z)g[x,y,z]
eqns={fx[x,y,z] == L* gx[x,y,z],fy[x,y,z] == L* gy[x,y,z],fz[x,y,z] == L* gz[x,y,z],g[x,y,z]==0}
pts=Solve[eqns,{x,y,z,L}]
f[x,y,z]/.pts
N[f[x,y,z]/.pts]
Print["Beware if the gradient is zero!"]
{gx[x,y,z], gy[x,y,z], gz[x,y,z]}/.pts
Print["Some points near the solutions"]
nearPts=N[Table[{x+a*.1,y+b*.1,z+ c*.1,f[x+a*.1,y+b*.1,z+c*.1]},{a,-1,1},{b,-1,1},{c,-1,1}]/.pts]