Find parameters of constant eigenvalue in a region of the phase space

Question

I have a 2 $\times$ 2 matrix of the form

mat[a_, b_, c_, d_, e_, x_, y_] := {{a - b*Cos[2*x]*Cos[2*y], c*(Cos[x] + Cos[y])}, {c*(Cos[x] + Cos[y]), d - e*Cos[2*x]*Cos[2*y]}};

where a,b,c,d,e are parameters and x,y are coordinates. I would like to find parameters such that one of the eigenvalues of the matrix, preferably the lower one, becomes flat in $|x|+|y|<\pi/2$. I have plotted these eigenvalues using

Manipulate[Plot3D[Eigenvalues[mat[a, b, c, d, e, x, y]], {x, -Pi, Pi}, {y, -Pi, Pi}, PlotRange -> {-7, 7}, ColorFunction -> "TemperatureMap"], {a, -1, 2}, {b, -1, 5}, {c, -1, 1}, {d, -1, 1}, {e, -1, 1}]

and I can roughly estimate that at $a=1$, $b=0$, $c=-0.465$, $b=0.505$, $e=-0.285$ the lower eigenvalue is almost flat. How can I find the exact parameters such that the eigenvalue is constant, or at least consists of four patches of constant values, in $|x|+|y|<\pi/2$.

Answer 1

A function is as flat as possible when its derivative is as close to zero as possible. Let $m(a,b,c,d,e,x,y)$ be the first eigenvalue of your matrix; I'm going to minimise $$ f(a,b,c,d,e):=\int_{(x,y)\in\Omega} |\nabla_{x,y}m(a,b,c,d,e,x,y)|^2\ \mathrm dx\,\mathrm dy $$ where $\Omega$ is the region you are interested in. To simplify the code, I'm going to take $\Omega:=[-\pi,\pi]^2$, and I leave it to you to restrict it to one quadrant if you want to.

fun[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ] :=
Total @@ NIntegrate[
         Grad[Eigenvalues[mat[a, b, c, d, e, x, y], 1], {x, y}]^2
         , {x, -π, π}, {y, -π, π}]

With this, the minimisation is straightforward:

FindMinimum[
fun[a, b, c, d, e]
, {{a, 1}, {b, 0}, {c, -.4}, {d, .5}, {e, -.3}}]
(* {4.4*10^-15, {a -> 1.059, b -> 0.056, c -> -0.000016, d -> 0.44, e -> -7.49*10^-9}} *)

The plot confirms that the function is rather flat:

Plot3D[Eigenvalues[mat[1.059, 0.056, -0.000016, 0.44, 7.49*^-9, x, y], 1], {x, -π, π}, {y, -π, π}, PlotRange -> {-7, 7}, ColorFunction -> "TemperatureMap"]

You can also compare the maximum of $m$ to its minimum:

NMinimize[{Re @@ Eigenvalues[mat[1.059, 0.056, -0.000016, 0.44, -7.49*^-9, x, y], 1], -π <= x <= π, -π <= y <= π}, {x, y}]
NMaximize[{Re @@ Eigenvalues[mat[1.059, 0.056, -0.000016, 0.44, -7.49*^-9, x, y], 1], -π <= x <= π, -π <= y <= π}, {x, y}]
%[[1]]/%%[[1]]
(* {0.441261, {x -> 3.1224, y -> 1.59253}}    *)
(* {0.441261, {x -> -3.14158, y -> -3.14156}} *)
(* 1.00000003 *)

This is consistent with the plot, which is rather flat, and the almost-vanishing value of the derivative, which is of order $10^{-15}$.