Services & ResourcesWolfram ForumsMathGroup Archive

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

find roots on a rectangle in 2D domain

• To: mathgroup at smc.vnet.net
• Subject: [mg71069] find roots on a rectangle in 2D domain
• From: "dimitris" <dimmechan at yahoo.com>
• Date: Wed, 8 Nov 2006 06:11:57 -0500 (EST)

Thanks a lot to Maxim that mentioned me the mistake.
Here is the new version.

Clear["Global`*"]

Off[General::spell1]

CurveFindRoot::usage =
"CurveFindRoot[{f,g},{x,xmin,xmax},{y,ymin,ymax},curve,points,opts]
finds all nontangential solutions to \
\n\t\t{f=0, g=0}, on a contour line.";

ContourFindRoot::usage =
"ContourFindRoot[{f,g},{x,xmin,xmax},{y,ymin,ymax},points,opts] finds
all nontangential solutions to \n\t\t{f=0, g=0}.";

ContourPlotFunctionRoots::usage =
"ContourPlotFunctionRoots[{f,g},{x,xmin,xmax},{y,ymin,ymax},roots,optsplot]
gives the graph of curves and zeros.";

CurveFindRoot[{f_, g_}, {x_, x0_, x1_}, {y_, y0_, y1_}, curve_,
points_, opts___] :=
  Block[{contourdata, pos, seeds, gg},
   contourdata = Cases[Graphics[ContourPlot[f, {x, x0, x1}, {y, y0,
y1}, Contours -> {0}, ContourShading -> False,
        PlotPoints -> points, DisplayFunction -> Identity]], Line[a_]
:> a, Infinity]; gg = Function[{x, y}, Evaluate[g]];
    pos = Position[Partition[Apply[gg, contourdata[[curve]], {1}], 2,
1], _?(Times @@ #1 < 0 & ), {1}];
    seeds = contourdata[[curve,Flatten[pos]]]; (FindRoot[{f == 0, g ==
0}, {x, #1[[1]]}, {y, #1[[2]]}, opts] & ) /@ seeds]

ContourFindRoot[{f_, g_}, {x_, x0_, x1_}, {y_, y0_, y1_}, points_,
opts___] :=
  Block[{lengthcontourdata, roots},
   lengthcontourdata = Length[Cases[Graphics[ContourPlot[f, {x, x0,
x1}, {y, y0, y1}, Contours -> {0}, ContourShading -> False,
         PlotPoints -> points, DisplayFunction -> Identity]], Line[a_]
:> a, Infinity]];
    roots = (CurveFindRoot[{f, g}, {x, x0, x1}, {y, y0, y1}, #1,
points, opts] & ) /@ Range[lengthcontourdata];
    {x, y} /. Flatten[DeleteCases[roots, {}], 1]]

ContourPlotFunctionRoots[{f_, g_}, {x_, x0_, x1_}, {y_, y0_, y1_},
points_, roots_, optsplot___] :=
  Show[MapThread[ContourPlot[#1, {x, x0, x1}, {y, y0, y1}, optsplot,
PlotPoints -> points, Contours -> {0},
      ContourShading -> False, DisplayFunction -> Identity,
ContourStyle -> {Hue[#2/3]}] & , {{f, g}, {1, 2}}],
   Graphics[({Red, AbsolutePointSize[6], Point[#1]} & ) /@ roots],
DisplayFunction -> $DisplayFunction]

It works properly as someone can see

Clear[f]
f[x_, y_] := x - y^2*Cos[y]
g[x_, y_] := -y + x*Sin[x]
sols = ContourFindRoot[{f[x, y], g[x, y]}, {x, -21, 21}, {y, -21, 21},
200];
ContourPlotFunctionRoots[{f[x, y], g[x, y]}, {x, -21, 21}, {y, -21,
21}, 200, sols];

Clear[f]
f[z_] := Sin[z] - z
ref[x_, y_] = Simplify[Re[ComplexExpand[f[z] /. z -> x + I*y]], {x, y}
â?? Reals]
imf[x_, y_] = Simplify[Im[ComplexExpand[f[z] /. z -> x + I*y]], {x, y}
â?? Reals]
-x + Cosh[y]*Sin[x]
-y + Cos[x]*Sinh[y]
sols = ContourFindRoot[{ref[x, y], imf[x, y]}, {x, -10, 10}, {y, -5,
5}, 200];
ContourPlotFunctionRoots[{ref[x, y], imf[x, y]}, {x, -10, 10}, {y, -5,
5}, 200, sols];

Clear[f]
f[z_] := Sin[Cos[z]] - z
ref[x_, y_] = Simplify[Re[ComplexExpand[f[z] /. z -> x + I*y]], {x, y}
â?? Reals]
imf[x_, y_] = Simplify[Im[ComplexExpand[f[z] /. z -> x + I*y]], {x, y}
â?? Reals]
-x + Cosh[Sin[x]*Sinh[y]]*Sin[Cos[x]*Cosh[y]]
-y - Cos[Cos[x]*Cosh[y]]*Sinh[Sin[x]*Sinh[y]]
sols = ContourFindRoot[{ref[x, y], imf[x, y]}, {x, -Pi, Pi}, {y, -Pi,
Pi}, 200];
ContourPlotFunctionRoots[{ref[x, y], imf[x, y]}, {x, -Pi, Pi}, {y, -Pi,
Pi}, 200, sols];