Finding the conditions for degenerate solutions to a cubic equation

Further edited to simplify results

It is not difficult to show that the three eigenvalues, w, of M are equal if and only if M is diagonal; i.e., ab = ac = bc = 0.

f[e_] := 2 Norm[e]^-3 (1 - 3 Sin[θ]^2 Cos[ϕ - ArcTan[e[[1]], e[[2]]]]^2) Cos[{x, y}.e]
abeval = f[{1, 0}]
(* 2 Cos[x] (1 - 3 Cos[ϕ]^2 Sin[θ]^2) *)
aceval = f[{0, 1}]
(* 2 Cos[y] (1 - 3 Sin[θ]^2 Sin[ϕ]^2) *)
bceval = Simplify[TrigExpand[f[{1, 1}] + f[{-1, 1}]]]
(* (Cos[x] Cos[y] (1 + 3 Cos[2 θ]) + 6 Sin[x] Sin[y] Sin[θ]^2 Sin[2 ϕ])/(2 Sqrt[2]) *)

Solutions can be obtained in an orderly manner as follows. For {Cos[x] -> 0, Cos[y] -> 0}, abeval and aceval are zero, and bceval reduces to

Sin[θ] Sin[2 ϕ] == 0

For {Sin[x] -> 0, Cos[y] -> 0}, aceval and bceval are zero, and abeval reduces to

1 - 3 Cos[ϕ]^2 Sin[θ]^2 == 0

Finally, for {Cos[x] -> 0, Sin[y] -> 0}, abeval and bceval are zero, and aceval reduces to

(1 - 3 Sin[θ]^2 Sin[ϕ]^2) == 0

These curves are plotted below and indicate where solutions are located in θ and ϕ.

ContourPlot[{Sin[θ] Sin[2 ϕ] == 0, 
             (1 - 3 Cos[ϕ]^2 Sin[θ]^2) == 0, 
             (1 - 3 Sin[θ]^2 Sin[ϕ]^2) == 0}, 
    {θ, 0, Pi + .01}, {ϕ, 0, 2 Pi + .01}, Frame -> False, Axes -> True, 
    Ticks -> {{0, Pi}, {0, Pi, 2 Pi}}, AxesLabel -> {"θ", "ϕ"}, 
    ContourStyle -> Directive[Black, Thick], 
    AxesStyle -> Directive[Black, Bold, Thick, 12]]

enter image description here

Other values of x and y give rise to discrete points in θ and ϕ, located at the intersections of curves in this plot.

Band Structure Plot

With the information just presented, generating band structure plots is straightforward. To do so, evaluate s

seval = f[{2, 0}] + f[{0, 2}]
(* 1/4 Cos[2 x] (1 - 3 Cos[ϕ]^2 Sin[θ]^2) + 1/4 Cos[2 y] (1 - 3 Sin[θ]^2 Sin[ϕ]^2) *)

define

mplt[θ0_, ϕ0_] := Module[{meval = 
    Det[M] /. {ab -> abeval, ac -> aceval, bc -> bceval, 
               s -> seval} /. {θ -> θ0, ϕ -> ϕ0} // Simplify},
    Plot3D[Evaluate[w /. Solve[meval == 0, w]], {x, -Pi, Pi}, {y, -Pi, Pi}, 
        AxesLabel -> {"x", "y"}, AxesStyle -> Directive[Black, Bold, 12], 
        Ticks -> {{-Pi, 0, Pi}, {-Pi, 0, Pi}, Automatic}, 
        ImageSize -> Large, ViewPoint -> {1.4, -3.0, .35}]]

and invoke it with any pair {θ0, ϕ0} from the plot above or from the three equations that the plot represents. For instance

mplt[Pi/2, ArcSin[Sqrt[1/3]]]

enter image description here

or

mplt[Pi/2, ArcCos[Sqrt[1/3]]]

enter image description here

Plots for values corresponding to interior curve intersections from the {θ0, ϕ0} plot are in a sense degenerate.

 mplt[ArcSin[Sqrt[1/3]], Pi]

enter image description here

mplt[0, 0], of course, gives the plot in the Question.

Addendum

At the request of the OP in a comment below, here is a more detailed argument that M must be diagonal for its three eigenvalues to be equal. To begin, its Determinant must be proportional to [-(w - w0)^3, where w0 is the three-fold-repeated eigenvalue.

eq0 = Expand[-(w - w0)^3]
(* -w^3 + 3 w^2 w0 - 3 w w0^2 + w0^3 *)

The Determinant of M actually is

eq = Collect[Det[M], w, Simplify]
(* 2 ab ac bc - ab^2 s - s (ac^2 + bc^2 - s^2) + (ab^2 + ac^2 + bc^2 - 3 s^2) w + 
   3 s w^2 - w^3 *)

Equating the two yields

Collect[eq - eq0, w, Simplify]
(* 2 ab ac bc - ab^2 s - ac^2 s - bc^2 s + s^3 + 3 w^2 (s - w0) - w0^3 + 
 w (ab^2 + ac^2 + bc^2 - 3 s^2 + 3 w0^2) *)

and the coefficient of every power of w must vanish. Thus, w0 must be equal to s. With that substitution,

Collect[% /. w0 -> s, {w, s}, Simplify]
(* 2 ab ac bc + (-ab^2 - ac^2 - bc^2) s + (ab^2 + ac^2 + bc^2) w *)

The coefficient of w in the last expression vanishes if and only if all three of ab, ac, and bc vanish, in other word, if M is diagonal.


This is an incomplete answer, but we will be able to show that there is no solution for most values of θ and ϕ. We will also be able to draw a plot of the regions of interest that you should check further to find solutions, should they exist.

M = {{s - w, ab, ac}, {ab, s - w, bc}, {ac, bc, s - w}};
{d, c, b, a} = CoefficientList[Det[M], w];
disc = Discriminant[Det@M, w] // FullSimplify;
disc0 = b^2 - 3 a c;

Now, if we want three Real (equal) solutions both disc and disc0 must vanish simultaneously. As both discriminants are always positive, we can explore when the minimum of their sum is zero:

f[e_] := 2 Norm[e]^-3 (1 - 3 Sin[theta]^2 Cos[phi - ArcTan[e[[1]], e[[2]]]]^2) 
                                                           Cos[{x, y}.e];
ab = f[{1, 0}];
ac = f[{0, 1}];
bc = f[{1, 1}] + f[{-1, 1}];
s = f[{2, 0}] + f[{0, 2}];

Plot3D[FindMinValue[disc + disc0 /. {theta -> t, phi -> p}, 
                    {{x, 0, Pi}, {y, 0, Pi}}], 
       {t, 0, Pi/2}, {p, 0, Pi/2}, PlotRange -> {0, .1}, ClippingStyle -> None]

Mathematica graphics

So there you have the few regions to explore (they are lines, BTW)


Starting with bbgodfrey's excellent suggestion to solve ab == ac == bc == 0, we can obtain a fairly compact list of all of the solutions. If we Reduce the equations with conditions on the variables we get a complicated result, so it's easier to Reduce first and apply conditions after:

Reduce the equations and throw out some obviously inconsistent results:

sols = List @@ (
  LogicalExpand@FullSimplify@Reduce[Thread[Simplify@{ab, ac, bc} == 0]] /.     
    {___ && Cos[x_] == 0 && ___ && Sin[x_] == 0 && ___ -> False, 
     ___ && Sin[x_] == 0 && ___ && Cos[x_] == 0 && ___ -> False}
)

The last four solutions are

sols[[-4 ;;]]

Mathematica graphics

We can show that these are not self-consistent by eliminating θ and ϕ like so:

(Or @@ FullSimplify[# /. Solve[#[[;; 2]], {θ, ϕ}], C[_] ∈ Integers] &) /@ %
{False, False, False, False}

The remainder of the solutions are

(sols = Drop[sols, -4]) // TableForm

Mathematica graphics

We can Solve to find some particular solutions and throw away duplicates with

sols1 = Union@Simplify@Flatten[Solve /@ (sols /. _Unequal -> Sequence[]) /. C[_] -> 0, 1]; 

Then pick out solutions where the fixed parameters are between 0 and π:

sols2 = Pick[sols1, 0 == # & /@ Count[v_ /; ! 0 <= v < π] /@ ({x, y, θ, ϕ} /. sols1)]

Mathematica graphics

Plot the third and fourth solutions for {x -> 0, y -> π/2} in the θ and ϕ plane:

 ContourPlot[Evaluate[Equal @@@ sols2[[3 ;; 4, 3]]], {θ, 0, π}, {ϕ, -π/2, π/2}, MaxRecursion -> 3]

Mathematica graphics

And plot the energies as a function of θ and ϕ:

Plot3D[Evaluate[Re[w /. {x -> 0, y -> π/2}]], {θ, 0, π}, {ϕ, -π/2, π/2}, MaxRecursion -> 5]

Mathematica graphics