I am doing a brute force search for "gradient extremals" on the following example function

`fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2; `

This involves finding the following zeros

`gecond = With[{g = D[fv[{x, y}], {{x, y}}], h = D[fv[{x, y}], {{x, y}, 2}]}, g.RotationMatrix[Pi/2].h.g == 0] `

Which `Reduce`

happily does for me:

`geyvals = y /. Cases[[email protected]@Reduce[gecond, {x, y}], {y -> _}]; `

`geyvals`

is the three roots of a cubic polynomial, but the expression is a bit large to put here.

Now to my question: For different values of `x`

, different numbers of these roots are real, and I would like to pick out the values of `x`

where the solutions branch in order to piece together the gradient extremals along the valley floor (of `fv`

). In the present case, since the polynomial is only cubic, I could probably do it by hand -- but I am looking for a simple way of having Mathematica do it for me?

**Edit**: To clarify: The gradient extremals stuff is just background -- and a simple way to set up a hard problem. I am not so interested in the specific solution to this problem as in a general hand-off way of spotting the branch points for polynomial roots. Have added an answer below with a working approach.

**Edit 2**: Since it seems that the actual problem is much more fun than root branching: rcollyer suggests using `ContourPlot`

directly on `gecond`

to get the gradient extremals. To make this complete we need to separate valleys and ridges, which is done by looking at the eigenvalue of the Hessian perpendicular to the gradient. Putting a check for "valleynes" in as a `RegionFunction`

we are left with only the valley line:

`valleycond = With[{ g = D[fv[{x, y}], {{x, y}}], h = D[fv[{x, y}], {{x, y}, 2}]}, g.RotationMatrix[Pi/2].h.RotationMatrix[-Pi/2].g >= 0]; gbuf["gevalley"]=ContourPlot[gecond // Evaluate, {x, -2, 4}, {y, -.5, 1.2}, RegionFunction -> Function[{x, y}, [email protected]], PlotPoints -> 41]; `

Which gives just the valley floor line. Including some contours and the saddle point:

`fvSaddlept = {x, y} /. [email protected][Thread[D[fv[{x, y}], {{x, y}}] == {0, 0}]] gbuf["contours"] = ContourPlot[fv[{x, y}], {x, -2, 4}, {y, -.7, 1.5}, PlotRange -> {0, 1/2}, Contours -> [email protected] (Range[6]/3 - .01), PlotPoints -> 41, AspectRatio -> Automatic, ContourShading -> None]; gbuf["saddle"] = Graphics[{Red, Point[fvSaddlept]}]; Show[gbuf /@ {"contours", "saddle", "gevalley"}] `

We end up with a plot like this:

-------------Problems Reply------------

Not sure if this (belatedly) helps, but it seems you are interested in discriminant points, that is, where both polynomial and derivative (wrt y) vanish. You can solve this system for {x,y} and throw away complex solutions as below.

`fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;`

```
```gecond = With[{g = D[fv[{x, y}], {{x, y}}],

h = D[fv[{x, y}], {{x, y}, 2}]}, g.RotationMatrix[Pi/2].h.g]

In[14]:= Cases[{x, y} /.

NSolve[{gecond, D[gecond, y]} == 0, {x, y}], {_Real, _Real}]

`Out[14]= {{-0.0158768, -15.2464}, {1.05635, -0.963629}, {1.,`

0.0625}, {1., 0.0625}}

If you only want to plot the result then use `StreamPlot[]`

on the gradients:

`grad = D[fv[{x, y}], {{x, y}}];`

StreamPlot[grad, {x, -5, 5}, {y, -5, 5},

RegionFunction -> Function[{x, y}, fv[{x, y}] < 1],

StreamScale -> 1]

You may have to fiddle around with the plot's precision, StreamStyle, and the RegionFunction to get it perfect. Especially useful would be using the solution for the valley floor to seed `StreamPoints`

programmatically.

**Updated**: see below.

I'd approach this first by visualizing the imaginary parts of the roots:

This tells you three things immediately: 1) the first root is always real, 2) the second two are the conjugate pairs, and 3) there is a small region near zero in which all three are real. Additionally, note that the exclusions only got rid of the singular point at `x=0`

, and we can see why when we zoom in:

We can then use the `EvalutionMonitor`

to generate the list of roots directly:

`Map[Module[{f, fcn = #1},`

f[x_] := Im[fcn];

Reap[Plot[f[x], {x, 0, 1.5},

Exclusions -> {True, f[x] == 1, f[x] == -1},

EvaluationMonitor :> Sow[{x, f[x]}][[2, 1]] //

SortBy[#, First] &];]

]&, geyvals]

(Note, the `Part`

specification is a little odd, `Reap`

returns a `List`

of what is sown as the second item in a `List`

, so this results in a nested list. Also, `Plot`

doesn't sample the points in a straightforward manner, so `SortBy`

is needed.) There may be a more elegant route to determine where the last two roots become complex, but since their imaginary parts are piecewise continuous, it just seemed easier to brute force it.

**Edit**: Since you've mentioned that you want an automatic method for generating where some of the roots become complex, I've been exploring what happens when you substitute in `y -> p + I q`

. Now this assumes that `x`

is real, but you've already done that in your solution. Specifically, I do the following

`In[1] := poly = g.RotationMatrix[Pi/2].h.g /. {y -> p + I q} // ComplexExpand;`

In[2] := {pr,pi} = poly /. Complex[a_, b_] :> a + z b & // CoefficientList[#, z] & //

Simplify[#, {x, p, q} \[Element] Reals]&;

where the second step allows me to isolate the real and imaginary parts of the equation and simplify them independent of each other. Doing this same thing with the generic 2D polynomial, `f + d x + a x^2 + e y + 2 c x y + b y^2`

, but making both `x`

and `y`

complex; I noted that `Im[poly] = Im[x] D[poly, Im[x]] + Im[y] D[poly,[y]]`

, and this may hold for your equation, also. By making `x`

real, the imaginary part of `poly`

becomes `q`

times some function of `x`

, `p`

, and `q`

. So, setting `q=0`

always gives `Im[poly] == 0`

. But, that does not tell us anything new. However, if we

`In[3] := qvals = Cases[[email protected]@RReduce[ pi == 0 && q != 0, {x,p,q}],`

{q -> a_}:> a];

we get several formulas for `q`

involving `x`

and `p`

. For some values of `x`

and `p`

, those formulas may be imaginary, and we can use `Reduce`

to determine where `Re[qvals] == 0`

. In other words, we want the "imaginary" part of `y`

to be real and this can be accomplished by allowing `q`

to be zero or purely imaginary. Plotting the region where `Re[q]==0`

and overlaying the gradient extremal lines via

`With[{rngs = Sequence[{x,-2,2},{y,-10,10}]},`

[email protected]{

RegionPlot[Evaluate[Thread[Re[qvals]==0]/.p-> y], rngs],

ContourPlot[g.RotationMatrix[Pi/2].h.g==0,rngs

ContourStyle -> {[email protected],Dashed}]}]

gives

which confirms the regions in the first two plots showing the 3 real roots.

Ended up trying myself since the goal really was to do it 'hands off'. I'll leave the question open for a good while to see if anybody finds a better way.

The code below uses bisection to bracket the points where `CountRoots`

changes value. This works for my case (spotting the singularity at x=0 is pure luck):

`In[214]:= findRootBranches[Function[x, [email protected][[1, 1]]], {-5, 5}]`

Out[214]= {{{-5., -0.0158768}, 1}, {{-0.0158768, -5.96046*10^-9}, 3}, {{0., 0.}, 2}, {{5.96046*10^-9, 1.05635}, 3}, {{1.05635, 5.}, 1}}

Implementation:

`Options[findRootBranches] = {`

AccuracyGoal -> $MachinePrecision/2,

"SamplePoints" -> 100};

```
```findRootBranches::usage =

"findRootBranches[f,{x0,x1}]: Find the the points in [x0,x1] \

where the number of real roots of a polynomial changes.

Returns list of {<interval>,<root count>} pairs.

f: Real -> Polynomial as pure function, e.g f=Function[x,#^2-x&]." ;

findRootBranches[f_, {xa_, xb_}, OptionsPattern[]] := Module[

{bisect, y, rootCount, acc = 10^-OptionValue[AccuracyGoal]},

rootCount[x_] := {x, CountRoots[f[x][y], y]};

(* Define a ecursive bisector w/ automatic subdivision *)

bisect[{{x1_, n1_}, {x2_, n2_}} /; Abs[x1 - x2] > acc] :=

Module[{x3, n3},

{x3, n3} = rootCount[(x1 + x2)/2];

Which[

n1 == n3, bisect[{{x3, n3}, {x2, n2}}],

n2 == n3, bisect[{{x1, n1}, {x3, n3}}],

True, {bisect[{{x1, n1}, {x3, n3}}],

bisect[{{x3, n3}, {x2, n2}}]}]];

`(* Find initial brackets and bisect *)`

Module[{xn, samplepoints, brackets},

samplepoints = [email protected][{sp = OptionValue["SamplePoints"]},

If[NumberQ[sp], xa + (xb - xa) Range[0, sp]/sp, Union[{xa, xb}, sp]]];

(* Start by counting roots at initial sample points *)

xn = rootCount /@ samplepoints;

(* Then, identify and refine the brackets *)

brackets = Flatten[bisect /@

Cases[Partition[xn, 2, 1], {{_, a_}, {_, b_}} /; a != b]];

(* Reinclude the endpoints and partition into same-rootcount segments: *)

With[{allpts = Join[{[email protected]},

Flatten[brackets /. bisect -> List, 2], {[email protected]}]},

{#1, Last[#2]} & @@@ Transpose /@ Partition[allpts, 2]

]]]