0
$\begingroup$

Using some list manipulation I am able to produce a list of eigenvalues eigenim of the form {d,#[[2]]}, where d is some parameter, and #[[2]] is the imaginary part of each eigenvalue. I then use SelectFirst to extract the first {d,#[[2]]} for which #[[2]] is nonzero.

dmax=0.2;
s[d_?NumericQ] := SolveValues[r^3 - 10 r^2 + (25 + 100d^2) r - 4 == 0, r, Reals]
eigenfunc[{d_,r_}] := {d, (0.5 - 0.2 r + # Sqrt[0.01 r^2 - d^2])} & /@ {1, -1};

rvalues = 
  Join @@ (Transpose /@ 
     Table[{Array[d &, Length[s[d]]], s[d]}, {d, 0, dmax, 0.0001}]);

eigenvalues = Catenate[eigenfunc /@ rvalues];
eigenim = MapAt[Im, eigenvalues, {All, 2}];
SelectFirst[eigenim, 0.0 < #[[2]] &]

This generates {0.0172, 0.00150665}. I wish to repeat this process for different values of a parameter f, such that f=dmax and our cubic becomes:

r^3 - 10 r^2 + (25 + 100d^2) r - 100f^2 == 0

but instead of our output being some {d,#[[2]]}, I wish to extract the d from the first nonzero #[[2]], along with the f. This gives a single {d,f} for each value of f, such that the domain of f is [0,2] with some step size df=0.01.

$\endgroup$
2
  • 2
    $\begingroup$ You can use rvalues = Catenate @ Table[Thread @ {d, s[d]}, {d, 0, dmax, 0.0001}] which calls the s one time and is simpler. $\endgroup$
    – Ben Izd
    Commented Jan 4, 2023 at 4:10
  • $\begingroup$ I've now got some function t[f] such that eigenfunc[{d_, r_}] := {d, (0.5 - 0.2 r + # Sqrt[0.01 r^2 - d^2])} & /@ {1, -1}; t[f_] := SelectFirst[MapAt[Im, Catenate[eigenfunc /@Catenate@Table[Thread@{d, SolveValues[r^3 - 10 r^2 + (25 + 100*d^{2}) r - 100 f^2 == 0, r, Reals]}, {d, 0, f, 0.0001}]], {All, 2}], 0.0 < #[[2]] &]; If I run Evaluate[{t[f]} /. (t[#] & /@ Range[0.01, 2, 0.01])], the process will seemingly take hours or even days. Is there a better way to do this/ how can I end up with {d, f}-- currently my t[f] gives some list of the form {d, #[[2]]} $\endgroup$
    – ξύλο
    Commented Jan 5, 2023 at 6:44

1 Answer 1

2
$\begingroup$

One of the greatest advantages of Mathematica is its symbolic engine. Many functions support symbolic expression which can be cached for further use. Here is how I would tackle such problems:

Block[{temp1, temp2, temp3, temp4, f, r, d},

 temp1 = 
  SolveValues[r^3 - 10 r^2 + (25 + 100 d^2) r - 100 f^2 == 0, r, Reals];

 temp2 = 
  Catenate@
   Table[Im[(0.5 - 0.2 r + # Sqrt[0.01 r^2 - d^2])] & /@ {1, -1}, {r, temp1}];
 
 temp3 = temp2 /. {f -> .2};

Do[temp4 = SelectFirst[temp3, GreaterThan[0], {}];
   If[temp4 =!= {}, Return@{d, temp4}]
   
   , {d, 0, .2, .0001}]
  
  ]

which output {0.0172, 0.0015066530736155246} 60 times faster (on my computer it took around 0.2 seconds - The original solution took around 14 seconds) while using 19 times lower memory at peak.

First, we solve the expression symbolically, then apply transformations and Im to it. Then in the Do loop, we iterate over each d (instead of populating for all possible values), if we find the solution, it returns the result.

I should also point out the slight differences in the results:

(* Original Output: *)
{0.0172`, 0.0015066530736155606`}

(* Proposed Output: *)
{0.0172`, 0.0015066530736155246`}

Remember there is always room for improvement and I'm sure somebody in this forum can substantially improve this code.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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