RR: x^4


f[x_]= Exp[-b x^c]
ke=Integrate[f'[x]^2,{x,0,Infinity}]
n=Integrate[f[x]^2,{x,0,Infinity}]
pe=Integrate[x^4 f[x]^2,{x,0,Infinity}]
e=(ke+pe)/n
ContourPlot[e,{b,.5,2},{c,1.5,2.5}]
FindMinimum[e,{{b,.8},{c,2.2}}]
Out[13]= {1.0625, {b -> 0.614571, c -> 2.36692}}

Note: slightly above exact: 1.0604

f[x_]= x Exp[-b x^c]
ke=Integrate[f'[x]^2,{x,0,Infinity}]
n=Integrate[f[x]^2,{x,0,Infinity}]
pe=Integrate[x^4 f[x]^2,{x,0,Infinity}]
e=(ke+pe)/n
ContourPlot[e,{b,.5,2},{c,1.5,2.5}]

FindMinimum[e,{{b,.8},{c,2.2}}]
Out[20]= {3.80241, {b -> 0.667362, c -> 2.39768}}

Note: slightly above exact:  3.7997

------------------
RR: morse 1 & 2

alpha=10

$Assumptions={q>1}
f[x_]= Exp[-q x^2]
ke=Integrate[f'[x]^2,{x,-Infinity,Infinity}]/alpha^2
n=Integrate[f[x]^2,{x,-Infinity,Infinity}]
pe=Integrate[ (1-Exp[-x])^2  f[x]^2,{x,-Infinity,Infinity}]
e=(ke+pe)/n
Plot[e,{q,.1,10}]
FindMinimum[e,{q,5}]
Out[11]= {0.104178, {q -> 5.40905}}
exact[nn_]=2/alpha (nn+.5)-(nn+.5)/alpha^2
exact[0]    
Out[11]= 0.095

Note: slighlty more than exact

$Assumptions={a>0}

f[x_]= (a^2-x^2)
ke=Integrate[f'[x]^2,{x,-a,a}]/alpha^2
n=Integrate[f[x]^2,{x,-a,a}]
pe=Integrate[ (1-Exp[-x])^2  f[x]^2,{x,-a,a}]
e=(ke+pe)/n
Plot[e,{a,.1,2}]
FindMinimum[e,{a,.5}]
Out[24]= {0.124154, {a -> 0.623593}}
Note: slighlty more than exact & previous

-------------------
WKB x^4

ClearAll[e]
$Assumptions={e>0}
wkb= Integrate[Sqrt[e-x^4],{x,-e^(1/4),e^(1/4)}]
            3/4
         4 e    EllipticK[-1]
Out[28]= --------------------
                  3

WKB approx says: wkb= Pi (n-1/2) (as both turning points are linear)
i.e. wkb/Pi = n-1/2 where n=1,2,3,...

Plot[wkb/Pi,{e,0,12}]

FindRoot[wkb/Pi-.5,{e,1}]       
Out[29]= {e -> 0.867145}
          
FindRoot[wkb/Pi-1.5,{e,4}]  
Out[30]= {e -> 3.75192}

FindRoot[wkb/Pi-2.5,{e,8}]      
Out[32]= {e -> 7.41399}

FindRoot[wkb/Pi-3.5,{e,12}]     
Out[31]= {e -> 11.6115}

these are all slighlty below (but getting quite close) to the exact values:
1.0604, 3.7997, 7.4557, 11.6447

There is no claim that WBK is above or below the exact so this is all OK
Also it is expected that WKB works best with large n...check

-----
dTIPT stark with v = x (e E)...copy code from assignments.txt:

Recall the H-atom wavefunction in Mathematica form and
it will help to have the complex conjugate of this wavefunction:

psi[n_,l_,m_,r_]=2/(n^2 Sqrt[Pochhammer[n-l,2l+1]]) (2r/n)^l LaguerreL[n-l-1,2l+1,2r/n] Exp[-r/n] SphericalHarmonicY[l, m, theta,phi]
psic[n_,l_,m_,r_]=2/(n^2 Sqrt[Pochhammer[n-l,2l+1]]) (2r/n)^l LaguerreL[n-l-1,2l+1,2r/n] Exp[-r/n] SphericalHarmonicY[l, m, theta,-phi]

lm={{0,0},{1,1},{1,0},{1,-1},{2,2},{2,1},{2,0},{2,-1},{2,-2}}


For the Stark Effect we seek the x matrix elements:  <l' m'|x|l m> where x=r Sin[theta] Cos[phi]

Calculate these 81 integrals in one chunk:
Table[Table[
Integrate[Integrate[Integrate[psic[3,First[lm[[i]]],Last[lm[[i]]],r] r Sin[theta] Cos[phi] psi[3,First[lm[[j]]],Last[lm[[j]]],r] r^2 Sin[theta],{phi,-Pi,Pi}],{theta,0,Pi}],{r,0,Infinity}],
{j,1,9}],{i,1,9}]

{{0, 3*Sqrt[3], 0, -3*Sqrt[3], 0, 0, 0, 0, 0}, 
{3*Sqrt[3], 0, 0, 0, 9/2, 0, (-3*Sqrt[3/2])/2, 0, 0}, 
{0, 0, 0, 0, 0, 9/(2*Sqrt[2]), 0, -9/(2*Sqrt[2]), 0}, 
{-3*Sqrt[3], 0, 0, 0, 0, 0, (3*Sqrt[3/2])/2, 0, -9/2}, 
{0, 9/2, 0, 0, 0, 0, 0, 0, 0}, 
{0, 0, 9/(2*Sqrt[2]), 0, 0, 0, 0, 0, 0}, 
{0, (-3*Sqrt[3/2])/2, 0, (3*Sqrt[3/2])/2, 0, 0, 0, 0, 0}, 
{0, 0, -9/(2*Sqrt[2]), 0, 0, 0, 0, 0, 0}, 
{0, 0, 0, -9/2, 0, 0, 0, 0, 0}}


MatrixForm[%]

0            3 Sqrt[3]    0            -3 Sqrt[3]   0            0            0            0            0

                                                                                      3
                                                                              -3 Sqrt[-]
                                                    9                                 2
                                                    -                         ----------
3 Sqrt[3]    0            0            0            2            0                2        0            0



                                                                     9                         -9
                                                                  ---------                 ---------
0            0            0            0            0            2 Sqrt[2]    0            2 Sqrt[2]    0

                                                                                  3
                                                                           3 Sqrt[-]
                                                                                  2                       9
                                                                          ---------                     -(-)
-3 Sqrt[3]   0            0            0            0            0                2        0              2



             9
             -
0            2            0            0            0            0            0            0            0



                              9
                          ---------
0            0            2 Sqrt[2]    0            0            0            0            0            0

                     3                        3
             -3 Sqrt[-]                3 Sqrt[-]
                     2                        2
             ----------                ---------
0                2        0                2        0            0            0            0            0



                              -9
                          ---------
0            0            2 Sqrt[2]    0            0            0            0            0            0



                                         9
                                       -(-)
0            0            0              2          0            0            0            0            0




Eigensystem[%4]
                   9     9   9  9
Out[5]= {{-9, 9, -(-), -(-), -, -, 0, 0, 0}, 
                   2     2   2  2
 
          4                           2
>    {{-------, -2, 0, 2, 1, 0, -Sqrt[-], 0, 1}, 
       Sqrt[3]                        3
 
          4                           2
>     {-------, 2, 0, -2, 1, 0, -Sqrt[-], 0, 1}, {0, 1, 0, 1, -1, 0, 0, 0, 1}, 
       Sqrt[3]                        3
 
>     {0, 0, Sqrt[2], 0, 0, -1, 0, 1, 0}, {0, -1, 0, -1, -1, 0, 0, 0, 1}, 
 
                                            -Sqrt[3]
>     {0, 0, -Sqrt[2], 0, 0, -1, 0, 1, 0}, {--------, 0, 0, 0, 1, 0, 0, 0, 1}, 
                                               2
 
                                        1
>     {0, 0, 0, 0, 0, 1, 0, 1, 0}, {---------, 0, 0, 0, 0, 0, 1, 0, 0}}}
                                    2 Sqrt[2]

The eigenvalues are exactly as with <z>, but...

Recall:
lm={{0,0},{1,1},{1,0},{1,-1},{2,2},{2,1},{2,0},{2,-1},{2,-2}}
so that first eigenvector is a mix of: {{0,0},{1,1},{1,-1},{2,2},{2,0},{2,-2}}
so it has no particular value of m; notice that the eigenvectors are not orthogonal:
{values,vectors}=%

Table[Table[
vectors[[i]].vectors[[j]],
{j,1,9}],{i,1,9}]

Out[11]= {{16, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 16, 0, 0, 0, 0, 0, 0, 0}, 
 
>    {0, 0, 4, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 4, 0, 0, 0, 0, 0}, 
 
>    {0, 0, 0, 0, 4, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 4, 0, 0, 0}, 
 
                                     3
                               -Sqrt[-]
                        11           2
>    {0, 0, 0, 0, 0, 0, --, 0, --------}, {0, 0, 0, 0, 0, 0, 0, 2, 0}, 
                        4         4
 
                              3
                        -Sqrt[-]
                              2      9
>    {0, 0, 0, 0, 0, 0, --------, 0, -}}
                           4         8


i.e. 7 & 9 are not orthogonal; this means that <7|v|9> is not zero but 7 & 9 are degenerate -> infinite 2nd order correction.

this is not a super big problem as the vector:
vector=vectors[[9]]-(vectors[[9]].vectors[[7]]/vectors[[7]].vectors[[7]]) vectors[[7]]
                                   3                 3
                              Sqrt[-]           Sqrt[-]
          2 Sqrt[2]                2                 2
Out[13]= {---------, 0, 0, 0, -------, 0, 1, 0, -------}
             11                 11                11


is orthogonal to all the other eigenvectors and a eigenvector with eigenvalue 0
Table[vector.vectors[[j]],{j,1,8}]
Out[14]= {0, 0, 0, 0, 0, 0, 0, 0}

-----
dTIPT exam #1 (remarks)

let L=1 (wolog)

L=1
psi[nx_,ny_,x_,y_]= 2/L Sin[nx Pi x /L]  Sin[ny Pi y /L] 

f[x_,y_]=(psi[2,1,x,y]+Sqrt[2] psi[1,2,x,y])/Sqrt[3]
g[x_,y_]=(-Sqrt[2] psi[2,1,x,y]+  psi[1,2,x,y])/Sqrt[3]

f[L/4,2 L/3]^2
Out[5]= 0


Simplify[g[L/4,2 L/3]^2]
         9
Out[12]= -
         2

Note: f & g have been normalized (hence the Sqrt[3])

Integrate[Integrate[f[x,y]^2,{x,0,L}],{y,0,L}]
Out[15]= 1
Integrate[Integrate[g[x,y]^2,{x,0,L}],{y,0,L}]
Out[16]= 1

and they are orthogonal:

Integrate[Integrate[g[x,y] f[x,y],{x,0,L}],{y,0,L}]                        

Out[17]= 0

and of course: f[L/4,2 L/3] g[L/4,2 L/3] is zero

Finally all higher order (second, third, etc) corrections for *f* must be zero also as <anything|v|f>=0

-----
exam #3 (TIPT)

psi[nx_,x_]= Sqrt[2/L] Sin[nx Pi x /L]  

Integrate[psi[nx,x]^2,{x,L/2-b,L/2+b}]


                             2 b nx Pi
              Cos[nx Pi] Sin[---------]
        2 b                      L
Out[2]= --- - -------------------------
         L              nx Pi


Table[Evaluate[% /. {b->.05 L}],{nx,1,6}]

Out[3]= {0.198363, 0.00645107, 0.185839, 0.0243173, 0.163662, 0.0495449}

See that these E1 terms are alternatively big & small as 
nx=odd -> psi[nx,L/2] at max
nx=even -> psi[nx,L/2] =0

Integrate[psi[1,x] psi[3,x],{x,L/2-b,L/2+b}]

               b Pi 3     b Pi
        -4 Cos[----]  Sin[----]
                L          L
Out[7]= -----------------------
                  Pi

% /. {b->.05 L}

Out[8]= -0.191912



