FindMinimum function does not produce minimum from near point

Question

Using my simple program and I would like to find such matrix elements that minimize difference of their eigenvalues.

H1 = {{1, 2}, {3, 4}};  
H2 = {{2, 2}, {3, 2}};  
f1[R_, S_] := R*H1 + S*IdentityMatrix[2]  
f2[R_, S_] := S*H2 + R*IdentityMatrix[2]  
Evl1 = N[Eigenvalues[f1[R, S]]];  
Evl2 = N[Eigenvalues[f2[R, S]]];  
h[R_, S_] := Evl1[[1]] - Evl2[[1]]  
h[1, 1]  
FindMinimum[h[R, S], {R, 1}, {S, 1}]   

Problems encountered are as follows:
1. Inserting values {1,1} into defined function h does not produce any specific numerical value, but an expression depending on variables R,S.
2. FindMinimum function does not produce minimum from near point. When trying to find minimum point, I found close solution {0.87, 1.101}. Does anyone know what I am doing wrong here?

Answer 1

You have a couple problems. First, as Andrew Cheong pointed out, Evl1 and Evl2 should be SetDelayed (:=). As you can see from evaluating h[1,1], S and R don't seem to get substituted:

h[1, 1]
(* -R + 0.44949 S + 0.5 (-0.744563 R + 2. S) *)

This is because Mathematica first Sets (=) the values of the Evl* to expressions involving the symbols R and S. However, the definition of h involves the named patterns R_ and S_. R and S in the right-hand-side don't ever get replaced, since they're "hidden" by the Evl*. You probably want something like this:

Evl1[R_, S_] := N[Eigenvalues[f1[R, S]]]
Evl2[R_, S_] := N[Eigenvalues[f2[R, S]]]
h[R_, S_] := Evl1[R, S][[1]] - Evl2[R, S][[1]]

Now the Evl* take in R and S and compute the correct value:

h[1, 1]
(* 0.922792 *)

And now FindMinimum returns a value:

FindMinimum[h[R, S], {{R, 1}, {S, 1}}]
(* {-2.09628*10^17, {R -> 7.22028*10^16, S -> -7.62651*10^16}} *)

We also get a warning message:

FindMinimum::lstol: The line search decreased the step size to within the tolerance
specified by AccuracyGoal and PrecisionGoal but was unable to find a sufficient
decrease in the function. You may need more than MachinePrecision digits of working
precision to meet these tolerances. >>

We can get an idea of why this happens by plotting h:

Plot3D[h[R, S], {R, -5, 5}, {S, -5, 5}, MaxRecursion -> 5, MeshFunctions -> {#3 &}]

The plot of h just keeps sloping downward as R gets bigger and S gets smaller. This is because FindMinimum will try to make h as negative as possible, which means it will end up making the difference as large as possible. You can fix that by minimizing the absolute difference (with Abs) or the square of the distance (which behaves better numerically):

h[R_, S_] := (Evl1[R, S][[1]] - Evl2[R, S][[1]])^2
Plot3D[h[R, S], {R, -2, 2}, {S, -2, 2}, MaxRecursion -> 4, MeshFunctions -> {#3 &}]

We can see now that there is a clear minimum value, and so FindMinimum works as expected.

h[1, 1] (* 0.851544 *)
FindMinimum[h[R, S], {{R, 1}, {S, 1}}]
(* {1.2326*10^-32, {R -> 1.02659, S -> 0.971911}} *)

---

There is one more issue. R and S are not independent of each other. Imagine multiplying both of them by two: then the f* will both be exactly doubled, and their eigenvalues Evl* will also be exactly doubled. If their difference was zero before, it will be zero again. You can see this in the plot of h, where the minimum is a long trough with h on the centerline equal to zero.

You probably want to fix a condition like R + S == 1. You can do this by redefining the f*, Evl*, and h to be functions of only S, replacing R by 1-S; or, you can use a condition in FindMinimum:

FindMinimum[{h[R, S], R + S == 1}, {{R, 1}, {S, 1}}]
(* {1.2326*10^-32, {R -> 0.513681, S -> 0.486319}} *)

Plotting shows that with this condition, there is a single minima:

Plot[h[s, 1 - s], {s, -2, +2}]