3
$\begingroup$

I have set of matrices(multiplied to give U123[q, p, r]) and would like to diagonalize U123[q, p, r] and plot the eigenvalues. Fortunately, after some try I was able to get out of the Root. For this, I used dynamic calculation (dynamically giving values to the variables and calculating the eigenvalues inside the Module). 

Element[k, Reals];
H31[q_] := {{0, 0, q Exp[I k]}, {0, 0, 0}, {q  Exp[-I k], 0, 0}};
H12[p_] := {{0, p, 0}, {p, 0, 0}, {0, 0, 0}};
H23[r_] := {{0, 0, 0}, {0, 0, r}, {0, r, 0}};

(*FullSimplify[PowerExpand@MatrixExp[-I  H31].MatrixExp[-I  H12].\
MatrixExp[-I  H23].MatrixExp[-I  H12]];*)

U123[q_, p_, r_] := 
  MatrixExp[-I  H31[q]].MatrixExp[-I  H23[r]].MatrixExp[-I  H12[p]];

quit[q_, p_, r_] := 
 Module[{$ph}, $ph = -I Log[Eigenvalues[U123[q, p, r]]];
  Plot[Evaluate@Flatten[Through[{Re}[$ph]]], {k, -Pi, Pi}, 
   Frame -> True, 
   PlotLegends -> {"Re $ph1", "Re $ph2", "Re $ph3"}]]
Manipulate[
 quit[q, p, r], {{q, Pi/2}, 0, 2 Pi, 
  Appearance -> "Labeled"}, {{p, 3 Pi/2}, 0, 2 Pi, 
  Appearance -> "Labeled"}, {{r, Pi/4}, 0, 2 Pi, 
  Appearance -> "Labeled"}]

The problem I am facing now is, I can freely change p and r but not q (which supposed to work like them p and r).

This what I getting after changing q, even by a very small value. Only thing I am able to do is that I am able to change the values for q here {{q, Pi/2}, 0, 2 Pi, Appearance -> "Labeled"}. Then it works but not through sliding.

enter image description here Can this graph be resolved, as I am getting this also: enter image description here

I have no idea how to solve this. To get even this much working, I am very thankful to the solutions I received at this and this from @Bob Hanlon and @yohbs.

|improve this question
$\endgroup$
3
$\begingroup$

Adapted from the code in Reordering numerically calculated eigenvalues assuming smooth dependence on a parameter

Clear["Global`*"]
Element[k, Reals];
H31[k_, q_] := {{0, 0, q (Cos[k] + I Sin[k])}, {0, 0, 
    0}, {q (Cos[k] + I Sin[k]), 0, 0}};
H12[p_] := {{0, p, 0}, {p, 0, 0}, {0, 0, 0}};
H23[r_] := {{0, 0, 0}, {0, 0, r}, {0, r, 0}};

(*FullSimplify[PowerExpand@MatrixExp[-I H31].MatrixExp[-I \
H12].MatrixExp[-I H23].MatrixExp[-I H12]];*)

U123[k_?NumericQ, q_?NumericQ, p_?NumericQ, r_?NumericQ] := 
  MatrixExp[-I H31[k, q]].MatrixExp[-I H23[r]].MatrixExp[-I H12[
       p]] // N;

q = \[Pi]/2;
p = 3 \[Pi]/2;
r = \[Pi]/4;
c = {};
frames = {};
xvals = Pi Range[-1, 1, 1/100];
alle = Table[({k, #} & /@ (-I Log[Eigenvalues[U123[k, q, p, r]]] // 
   Re)), {k, xvals}];
colors = {RGBColor[0.368417, 0.506779, 0.709798], RGBColor[
   0.880722, 0.611041, 0.142051], RGBColor[
   0.560181, 0.691569, 0.194885]};
Clear[g];
Monitor[Do[
  line = First@Position[alle, First@SortBy[#, #[[2]] &]] & /@ 
    alle[[;; 2]];
  MapIndexed[(nextx = #;
     proj = {nextx, 
       Quiet[Interpolation[alle[[Sequence @@ #]] & /@ line]@nextx]};
     AppendTo[line, 
      Position[alle, 
        First@Nearest[alle[[First@#2 + 2]], proj]][[1]]]) &, 
   xvals[[3 ;;]]];
  AppendTo[c, alle[[Sequence @@ #]] & /@ line];
  alle = Delete[alle, line];
  AppendTo[frames, 
   g = Show[{If[Length@First@alle > 0, ListPlot[Flatten[alle, 1]], 
       Graphics[]], 
      Graphics[
       MapIndexed[{Thick, colors[[First@#2]], Line[#]} &, c]]}, 
     PlotRange -> All, AxesOrigin -> {0, 0}]], {nrem, 3, 1, -1}], g]
Graphics[MapIndexed[{Thick, colors[[First@#2]], Line[#]} &, c], 
 Axes -> True]

before:

enter image description here

after:

enter image description here

edit:

to put the above inside Manipulate, just wrap it inside a function e.g. plotevs[...] that returns the figure, like this:

Element[k, Reals];
H31[k_, q_] := {{0, 0, q (Cos[k] + I Sin[k])}, {0, 0, 
    0}, {q (Cos[k] + I Sin[k]), 0, 0}};
H12[p_] := {{0, p, 0}, {p, 0, 0}, {0, 0, 0}};
H23[r_] := {{0, 0, 0}, {0, 0, r}, {0, r, 0}};

(*FullSimplify[PowerExpand@MatrixExp[-I H31].MatrixExp[-I \
H12].MatrixExp[-I H23].MatrixExp[-I H12]];*)

U123[k_?NumericQ, q_?NumericQ, p_?NumericQ, r_?NumericQ] := 
  MatrixExp[-I H31[k, q]].MatrixExp[-I H23[r]].MatrixExp[-I H12[
       p]] // N;

plotevs[q_, p_, r_] := Module[{},
  c = {};
  frames = {};
  xvals = Pi Range[-1, 1, 1/100];
  (*alle=Table[{{xvals[[k]],xvals[[k]],xvals[[k]]},-I Log[Eigenvalues[
  U123[xvals[[k]],q,p,r]]]//Re}\[Transpose],{k,1,Length[xvals]}];*)

  alle = Table[({k, #} & /@ (-I Log[Eigenvalues[U123[k, q, p, r]]] // 
        Re)), {k, xvals}];
  colors = {RGBColor[0.368417, 0.506779, 0.709798], RGBColor[
    0.880722, 0.611041, 0.142051], RGBColor[
    0.560181, 0.691569, 0.194885]};
  Clear[g];
  Do[line = 
    First@Position[alle, First@SortBy[#, #[[2]] &]] & /@ 
     alle[[;; 2]];
   MapIndexed[(nextx = #;
      proj = {nextx, 
        Quiet[Interpolation[alle[[Sequence @@ #]] & /@ line]@nextx]};
      AppendTo[line, 
       Position[alle, First@Nearest[alle[[First@#2 + 2]], proj]][[
        1]]]) &, xvals[[3 ;;]]];
   AppendTo[c, alle[[Sequence @@ #]] & /@ line];
   alle = Delete[alle, line];
   (*AppendTo[frames,g=Show[{If[Length@First@alle>0,ListPlot[Flatten[
   alle,1]],Graphics[]],Graphics[MapIndexed[{Thick,colors[[First@#2]],
   Line[#]}&,c]]},PlotRange\[Rule]All,AxesOrigin\[Rule]{0,
   0}]]*), {nrem, 3, 1, -1}];
  Return[Graphics[
    MapIndexed[{Thick, colors[[First@#2]], Line[#]} &, c], 
    Axes -> True]]
  ]

then use Manipulate[] as before:

Manipulate[
 plotevs[q, p, r], {{q, Pi/2}, 0, 2 Pi, 
  Appearance -> "Labeled"}, {{p, 3 Pi/2}, 0, 2 Pi, 
  Appearance -> "Labeled"}, {{r, Pi/4}, 0, 2 Pi, 
  Appearance -> "Labeled"}]
|improve this answer
$\endgroup$
  • $\begingroup$ Thanks for this. But it seems very complicated to understand. Is this is Real part plot or something else? As it is not matching with my plot for same values of q, p and r. Now I am suspicious about my result. $\endgroup$ – Shamina May 3 '17 at 9:42
  • $\begingroup$ @Shamina the figures I posted as example matched the answer you posted with the q,p,r taken to be the initial value in Manipulate[]: q = \[Pi]/2, p = 3 \[Pi]/2, r = \[Pi]/4. and is only the real part of -I Log[Eigenvalues[U123[k, q, p, r]]]. It is plotted by making a table alle={{{kvalue1,eigen1},{kvalue1,eigen2},{kvalue1,eigen2}},{{kvalue2,eigen1},{kvalue2,eigen2},{kvalue2,eigen2}}...} $\endgroup$ – egwene sedai May 3 '17 at 12:57
  • $\begingroup$ Plots are not same. I checked. If we take p -> 4.80035,r -> 1.58336, q -> 4.86319}. It behaves very badly $\endgroup$ – Shamina May 3 '17 at 13:50
  • $\begingroup$ @Shamina the answer from the reference link assumes smooth dependence on a parameter. in some cases it may indeed fail, like the example p -> 4.80035,r -> 1.58336, q -> 4.86319. I do not yet now how to get around that. If you do not care about assigning different colors to different eigenvalues, you can always delete everything under alle=Table[...] and just use ListPlot[alle, PlotStyle -> Blue] $\endgroup$ – egwene sedai May 3 '17 at 14:39
  • $\begingroup$ @Shamina additionally, for that particular example (p -> 4.80035,r -> 1.58336, q -> 4.86319), use more sample points with xvals = Pi Range[-1, 1, 1/500]; seems to work. code may need to run for a couple of minutes. $\endgroup$ – egwene sedai May 3 '17 at 14:43
2
$\begingroup$

Thanks to you all again.
I was able to get answer partly (still great help, after working on the problem). I was able to resolve the first problem of the that blue color error plot but not second one.
Here is the answer:

Element[k, Reals];
H31[q_] := {{0, 0, q  (Cos[k] + I Sin[k])}, {0, 0, 0}, {q  (Cos[k] + I Sin[k]), 0, 0}};
H12[p_] := {{0, p, 0}, {p, 0, 0}, {0, 0, 0}};
H23[r_] := {{0, 0, 0}, {0, 0, r}, {0, r, 0}};

(*FullSimplify[PowerExpand@MatrixExp[-I  H31].MatrixExp[-I  H12].\
MatrixExp[-I  H23].MatrixExp[-I  H12]];*)

U123[q_, p_, r_] := 
  MatrixExp[-I  H31[q]].MatrixExp[-I  H23[r]].MatrixExp[-I  H12[p]];

quit[q_, p_, r_] := 
 Module[{$ph}, $ph = -I Log[Eigenvalues[U123[q, p, r]]];
  Plot[Evaluate@Flatten[Through[{Re}[$ph]]], {k, -Pi, Pi}, 
   Frame -> True, 
   PlotLegends -> {"Re $ph1", "Re $ph2", "Re $ph3"}]]
Manipulate[
 quit[q, p, r], {{q, Pi/2}, 0, 2 Pi, 
  Appearance -> "Labeled"}, {{p, 3 Pi/2}, 0, 2 Pi, 
  Appearance -> "Labeled"}, {{r, Pi/4}, 0, 2 Pi, 
  Appearance -> "Labeled"}]

I just redefined Exp[I k] = (Cos[k] + I Sin[k]). However, I don't have a single idea of the fact that why it worked, also of the second problem.

|improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.