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[ ...

equation solving - Invert and fit implicitly defined curve

I need to fit an implicitly defined curve. I thought I could get some data out of Solve , and then using FindFit . Therefore, I would like to find the relation the parametric curve defined by $F(x,y)=0$: Solve[-(1/2) + 1/2 (0.41202 BesselK[0, 0.1 Sqrt[x^2 + y^2]] + (0.101483 x BesselK[1, 0.1 Sqrt[x^2 + y^2]])/Sqrt[x^2 + y^2]) == 0, y] But I can't get an output: Solve was unable to solve the system with inexact coefficients or the system obtained by direct rationalization of inexact numbers present in the system. Since many of the methods used by Solve require exact input, providing Solve with an exact version of the system may help. >> Edit: In particular, I would like to fit the data coming from the curve with the expression of another curve, and not with a function $f(x)$. In particular, since this clearly looks like a cardioid , I would like it to fit to something like it. What other strategies could I try?

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...