Skip to main content

differential equations - NDSolve eigenvalue problem of bound state


I am trying to solve this eigenvalue problem:
\begin{align} \mu \Psi(r) & = -\frac{1}{2}\left ( \Psi^{\prime \prime}(r) + \frac{2}{r} \Psi' (r)\right ) -4\pi \Psi(r) \int _0^\infty dr' r'^2 \frac{\Psi(r')^2}{r>}, \end{align} where $\mu$ is the eigenvalue, $\Psi(r)$ the eigenfunction I'm trying to solve, and $r_>$ is the greater one of $r$ and $r'$. The requirement of the system is
\begin{align}\Psi'(0)& = 0, \cr \Psi(\infty) & = 0.\end{align}


Since it involves an integral, the way I deal with it is to decouple it to two equations.


\begin{align} \mu \Psi (r) & = -\frac{1}{2}\left ( \Psi^{\prime \prime}(r) + \frac{2}{r} \Psi'(r) \right ) +\Psi(r) \Phi(r), \\ \nabla^2 \Phi(r) & = 4\pi \Psi(r)^2, \end{align}


with boundary


\begin{align} \Psi'(0)& = 0, \\ \Psi(\infty) & = 0,\\ \Phi'(0)& = 0, \\ \Phi(\infty) & = 0. \end{align}



Any idea how to solve it?


Attempt 1:


I manually tweak the boundary condition $\Psi(0)$ at zero trying to find a solution of $\Psi(r)$ that doesn't blow up at infinity. \begin{align} \mu \Psi (r) & = -\frac{1}{2}\left ( \Psi^{\prime \prime}(r) + \frac{2}{r} \Psi'(r) \right ) +\Psi(r) \Phi(r), \\ \nabla^2 \Phi(r) & = 4\pi \Psi(r)^2, \end{align}


with boundary


\begin{align} \Psi'(0)& = 0, \\ \Psi(0) & = A,\\ \Phi'(0)& = 0, \\ \Phi(\infty) & = 0. \end{align}


My current method is to guess a pair of input data $(\mu, A)$, use NDSolve to solve for $\Psi, \Phi$, and check whether the solution gives me a $\Psi$ whose absolute value decreases monotonically $i.e.$ vanishes at infinity, as suggested here. However, even with this method I haven't had much success. So, a) is there a good way to implement this algorithm; b) is there a better/alternative way to attack this whole problem? --AFAIK, (N)DEigensystem cannot handle this problem.


Edited:


Attemp 2:


So I just tried it out, naively if I use NDEigensystem directly as follows, it won't solve at all, which is not surprising.


rStart1=10^-3;

rEnd1=5;
epsilon=0;
sollst1=NDEigensystem[{(-1/2*(D[ψ[r],r,r]+2/r*D[ψ[r],r])-4Pi*ψ[r]*Integrate[rp^2*ψ[rp]^2/If[rp>r,rp,r],{rp,0,Infinity}])+NeumannValue[0,r==rStart1]},ψ[r],{r,rStart1,rEnd1},8];//AbsoluteTiming

Attemp 3: So this time I have fixed $\mu$, kept the boundary condition as \begin{align} \Psi'(0)& = 0, \\ \Psi(\infty) & = 0,\\ \Phi'(0)& = 0, \\ \Phi(\infty) & = 0. \end{align} and used the shooting method to select normalization for $\Psi(0)$. The following code works but only for very specific choice of rEnd1 and $\mu=-0.4$. Changing any of them gives me a trivial solution again. It seems the code is a bit fine-tuned in this sense.


rEnd1 = 3.7;
rStart1 = 10^-3;
stableHunter3[μ_] := Module[{}, epsilon = 0;
eqn2 = {-μ*ψ[r] -
1/2*(D[ψ[r], r, r] + 2/r*D[ψ[r], r]) + ϕ[

r]*ψ[r](*-1/8*ψ[r]^3*)== 0,
D[ϕ[r], r, r] + 2/r*D[ϕ[r], r] == 4 Pi*ψ[r]^2};
bc2 = {ψ[rEnd1] ==
epsilon, (D[ψ[r], r] /. r -> rStart1) ==
epsilon, (D[Ï•[r], r] /. r -> rStart1) ==
epsilon, (Ï•[rEnd1]) == epsilon};
sollst1 =
Map[NDSolveValue[
Flatten@{eqn2, bc2}, {ψ[r], ϕ[r]}, {r, rStart1,
rEnd1}, Method ->

"BoundaryValues" -> {"Shooting",
"StartingInitialConditions" -> {ψ[0] == #}},
Method -> "StiffnessSwitching"] &, Range[-3, 3, 0.1]]
]
funclst = stableHunter3[-0.4];
Plot[Evaluate[funclst /. r -> r00], {r00, rStart1, rEnd1}]

Attemp 4: So based on the suggestion from @bbgodfrey, an analysis on the asymptotic behavior suggests the following. When $r\rightarrow \infty$, \begin{align} \mu \Psi(r) & = -\frac{1}{2}\left ( \Psi^{\prime \prime}(r) + \frac{2}{r} \Psi' (r)\right ) -4\pi \Psi(r) \int _0^\infty dr' r'^2 \frac{\Psi(r')^2}{r>}, \cr & \approx -\frac{1}{2}\left ( \Psi^{\prime \prime}(r) + \frac{2}{r} \Psi' (r)\right ) -\frac{N}{r}\Psi(r),\end{align} where $N\equiv \int_0^\infty \Psi(r)^2 4\pi r^2 d r$. Here $\Phi(r)$ is not necessary, but if it is defined then $\Phi(r) \approx -\frac{N}{r}$ at large $r$. Then, I could use the following code to solve the eigenvalue $\mu$.


rStart1 = 10^-3;
rEnd1 = 5;

epsilon = 0;
Nphy1 = 1;

sollst1 =
NDEigensystem[{(-1/2*(D[ψ[r], r, r] + 2/r*D[ψ[r], r]) -
Nphy1/r*ψ[r]) + NeumannValue[0, r == rStart1](*,
DirichletCondition[ψ[r]\[Equal]epsilon,
x\[Equal]rStart1]*)}, ψ[r], {r, rStart1, rEnd1},
8]; // AbsoluteTiming
sollst1

sollst1[[2]] /. r -> rEnd1
Plot[Evaluate[%[[2]]], {r, rStart1, rEnd1},
PlotRange -> All(*,PlotLabels\[Rule]{1,2,3}*)]


{{-0.176753, 0.497306, -0.507498, 1.62112, 3.15356, 5.08955, 7.42803,
10.1706}, {InterpolatingFunction[{{0.001, 5.}}, <>][r],
InterpolatingFunction[{{0.001, 5.}}, <>][r],
InterpolatingFunction[{{0.001, 5.}}, <>][r],
InterpolatingFunction[{{0.001, 5.}}, <>][r],

InterpolatingFunction[{{0.001, 5.}}, <>][r],
InterpolatingFunction[{{0.001, 5.}}, <>][r],
InterpolatingFunction[{{0.001, 5.}}, <>][r],
InterpolatingFunction[{{0.001, 5.}}, <>][r]}}
{0.205938, -0.112739, 0.0259637, -0.094238, -0.0840003, -0.0769606}

enter image description here


I believe the $\mu =-0.507498$ is the ground state eigenvalue. However, when I use the boundary conditions at $rEnd1$ to trade for the ones at infinity, I ended up with trivial solution only.


stableHunter3[μ_] := Module[{},
eqn2 = {-μ*ψ[r] -

1/2*(D[ψ[r], r, r] + 2/r*D[ψ[r], r]) + ϕ[
r]*ψ[r] == 0,
D[ϕ[r], r, r] + 2/r*D[ϕ[r], r] == 4 Pi*ψ[r]^2};
bc2 = {ψ[rEnd1] ==
0.025963699315910634`, (D[ψ[r], r] /. r -> rStart1) ==
epsilon, (D[Ï•[r], r] /. r -> rStart1) ==
epsilon, (Ï•[rEnd1]) == Nphy1/rEnd1};
sollst1 =
NDSolveValue[
Flatten@{eqn2, bc2}, {ψ[r], ϕ[r]}, {r, rStart1,

rEnd1}](*Map[NDSolveValue[Flatten@{eqn2,bc2},{ψ[r],ϕ[
r]},{r,rStart1,rEnd1},
Method\[Rule]"BoundaryValues"\[Rule]{"Shooting",
"StartingInitialConditions"\[Rule]{ψ[0]\[Equal]#}}]&,Range[-3,
3,0.05]]*)
]
sollst1 = stableHunter3[-0.5074977775084505`]
Plot[Evaluate[sollst1 /. r -> r00], {r00, rStart1, rEnd1}]

enter image description here



Any thoughts how to proceed from there to solve $\Psi(r)$ at region where $r$ is small?


Attempt 5: Something weird happened. I start believing there is something related to the precision of NDSolve. Here is the code in which only the second element of the list gives me a nontrivial solution.


stableHunter3[μ_] := Module[{},
eqn2 = {-μ*ψ[r] -
1/2*(D[ψ[r], r, r] + 2/r*D[ψ[r], r]) + ϕ[
r]*ψ[r] == 0,
D[ϕ[r], r, r] + 2/r*D[ϕ[r], r] == 4 Pi*ψ[r]^2};
bc2 = {ψ[rEnd1] ==
0.025963699315910634`, (D[ψ[r], r] /. r -> rStart1) ==
epsilon, (D[Ï•[r], r] /. r -> rStart1) ==

epsilon, (Ï•[rEnd1]) == -Nphy1/rEnd1};
sollst1 =
NDSolveValue[
Flatten@{eqn2, bc2}, {ψ[r], ϕ[r]}, {r, rStart1,
rEnd1}](*Map[NDSolveValue[Flatten@{eqn2,bc2},{ψ[r],ϕ[
r]},{r,rStart1,rEnd1},
Method\[Rule]"BoundaryValues"\[Rule]{"Shooting",
"StartingInitialConditions"\[Rule]{ψ[0]\[Equal]#}}]&,Range[-3,
3,0.05]]*)
]

sollst1 =
Map[stableHunter3[#] \
&,(*Range[-0.5074977775084505-0.02,-0.5074977775084505+0.02,
0.005]*){-0.5074977775084505`, -0.5074977775084505`-0, \
-0.5074977775084505`+0.01}]
Plot[Evaluate[Flatten@sollst1 /. r -> r00], {r00, rStart1, rEnd1},
PlotRange -> All]

enter image description here



Answer




It turns out that the `trial-and-error' method is the simplest, as suggested by a few people that I talked to. Below is a piece of sample code.


epsilon = 0;
rEnd1 = 12;
rStart1 = 10^-5;
stableHunter3[μ_, A_, B_] :=
Module[{},
eqn2 = {-μ*ψ[r] -
1/2*(D[ψ[r], r, r] + 2/r*D[ψ[r], r]) + ϕ[
r]*ψ[r] == 0,
D[ϕ[r], r, r] + 2/r*D[ϕ[r], r] == 4 Pi*ψ[r]^2};

bc2 = {ψ[rStart1] == A, (D[ψ[r], r] /. r -> rStart1) ==
epsilon, (D[Ï•[r], r] /. r -> rStart1) ==
epsilon, (Ï•[rStart1]) == B};
sollst1 =
NDSolveValue[
Flatten@{eqn2, bc2}, {ψ, ϕ}, {r, rStart1, rEnd1},
Method -> "StiffnessSwitching"]]

sollst = Table[
sol = stableHunter3[muloop, psiloop, -4][[1]];

solder[rr_] := D[sol[r], r] /. r -> rr;
pt = rStart1;
While[solder[pt] <= 0 && sol[pt] >= 0 && pt < rEnd1,
pt += (rEnd1 - rStart1)/10;
];
If[pt == rEnd1, {muloop, psiloop, sol}]
, {muloop, -4, -3, 0.002}, {psiloop, 0.1, 0.4,
0.002}]; // AbsoluteTiming

Out[5]= {69.0395, Null}


(*I used twelve remote kernels to run it.
Running locally it'll take about 15 min.
You can try a coarse-grained lattice for
the muloop and psiloop, and decrease rEnd1
at the same time.*)

In[6]:= Flatten[DeleteCases[sollst /. Null -> Sequence[], {}], 1]

(-3.77 0.1 InterpolatingFunction[Domain: (0.00001 12.)

Output: scalar]
-3.756 0.106 InterpolatingFunction[Domain: (0.00001 12.)
Output: scalar]
-3.742 0.112 InterpolatingFunction[Domain: (0.00001 12.)
Output: scalar]
-3.65 0.152 InterpolatingFunction[Domain: (0.00001 12.)
Output: scalar])

sol = stableHunter3[-3.65, 0.152, -4][[1]];


solder[rr_] := D[sol[r], r] /. r -> rr;
Plot[Evaluate[{sol[r], solder[r]} /. r -> rrr], {rrr, rStart1, rEnd1},
PlotRange -> All]

enter image description here


Helpful communications with @bbgodfrey, M. Hertzberg, E. Schiappacasse, S. Schwarz, L. Titus, @xzczd are appreciated.


Comments

Popular posts from this blog

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...

dynamic - How can I make a clickable ArrayPlot that returns input?

I would like to create a dynamic ArrayPlot so that the rectangles, when clicked, provide the input. Can I use ArrayPlot for this? Or is there something else I should have to use? Answer ArrayPlot is much more than just a simple array like Grid : it represents a ranged 2D dataset, and its visualization can be finetuned by options like DataReversed and DataRange . These features make it quite complicated to reproduce the same layout and order with Grid . Here I offer AnnotatedArrayPlot which comes in handy when your dataset is more than just a flat 2D array. The dynamic interface allows highlighting individual cells and possibly interacting with them. AnnotatedArrayPlot works the same way as ArrayPlot and accepts the same options plus Enabled , HighlightCoordinates , HighlightStyle and HighlightElementFunction . data = {{Missing["HasSomeMoreData"], GrayLevel[ 1], {RGBColor[0, 1, 1], RGBColor[0, 0, 1], GrayLevel[1]}, RGBColor[0, 1, 0]}, {GrayLevel[0], GrayLevel...

list manipulation - Selecting multiple columns from a matrix?

Sample data: data = { {{2013, 1, 1}, 24.13, 167.67, 231.82}, {{2013, 1, 2}, 32.15, 170.92, 225.99}, {{2013, 1, 3}, 35.43, 172.68, 221.67}, {{2013, 1, 4}, 36.73, 173.05, 218.32}, {{2013, 1, 5}, 58.19, 165.96, 197.05}, {{2013, 1, 6}, 69.99, 163.50, 187.52}, {{2013, 1, 7}, 71.37, 154.21, 175.58}, {{2013, 1, 8}, 72.51, 149.66, 163.25}}; I want a DateListPlot with three graphs, so for a matrix formed by columns 1 and 2, one for columns 1 and 3, and 1 for columns 1 and 4. At the moment I'm using this code: data2 = Transpose[{data[[All, 1]], data[[All, 2]]}]; data3 = Transpose[{data[[All, 1]], data[[All, 3]]}]; data4 = Transpose[{data[[All, 1]], data[[All, 4]]}]; DateListPlot[{data2, data3, data4}, Joined -> True, Filling -> {3 -> {1}}] but I have a hunch that this can be done more efficiently. I don't like the Transpose s in particular. Any ideas? edit (for extra credit) What if I need to multiply the second column by 2, which in my solution is simp...