Kvanttimekaniikka II luennot, kevät 2003

Kahdesta tilasta muodostuva systeemi

a = 1
Em = 0
ep = Em + Sqrt[de^2 + a^2]
em = Em - Sqrt[de^2 + a^2]
ep0 = Em + de
em0 = Em - de
Plot[{ep, em, ep0, em0}, {de, -5, 5}, 
      PlotRange -> All]

Sironta potentiaalivallista uusi

Luentomonisteen merkinnät

a = 1;
\(\(tekstivall = {Graphics[Text["V = 0", {1.5, 1.5}]], 
          Graphics[Text[\*""V = \!\(V\_0\)"", {0.5, 1.5}]], 
          Graphics[Text["V = 0", {\(-0.5\), 1.5}]], 
          Graphics[Text["0", {0.1, \(-0.2\)}]], 
          Graphics[Text["a", {a - 0.1, \(-0.2\)}]], 
          Graphics[Text["I", {\(-0.5\), 2.5}]], 
          Graphics[Text["III", {1.5, 2.5}]], 
          Graphics[Text["II", {0.5, 2.5}]]};\)\)
Show[{Graphics[{Thickness[0.01], Line[{{a, 0}, {a, 3}}], 
            Line[{{0, 0}, {0, 3}}], Line[{{0, 3}, {a, 3}}]}], tekstivall}, 
      AxesLabel -> {x, V}, Axes -> True, Ticks -> False, 
      Background -> RGBColor[0.6, 0.8, 0.8], 
      PlotRange -> {{-a, 2  a}, {-1, 4}}, 
      TextStyle -> {FontSize -> 16}]

Heijastus ja läpäisykertoimet

Vastaavasti kuten symmetriselle potentiaalikuopalle, voidaan heijastus- ja läpäisykertoimet ratkaista myös potentiaalivallin tapauksessa.

Clear[A, T, R, k, v0, a, e]
A := v0^2/(4  e (e - v0))
T := 1/(1 + A*Sin[k*a]^2)
R := A*Sin[k*a]^2/(1 + A*Sin[k*a]^2)
k :=  Sqrt[e - v0]
v0 = 1;
e = 1.1;
tx = 
        Table[{n, n, 0.03}, {n, 0, 50, 10}];
ty = 
        Table[{n, n, 0.03}, {n, 0, 1, 0.2}];
kuva1 = 
        Plot[{R, T}, {a, 0, 50}, PlotRange -> All, 
          PlotStyle -> {Hue[0], Hue[0.65]}, 
          Background -> 
            RGBColor[0.6, 0.8, 0.8],   
            AxesLabel -> {a, P}, Ticks -> {tx, ty}, 
          DisplayFunction -> Identity, 
          TextStyle -> {FontSize -> 10}];

teksti = {Graphics[Text["T", {8, 1}]], 
          Graphics[Text["R", {7, 0.2}]]};

Show[{kuva1, teksti}, DisplayFunction -> $DisplayFunction, 
      TextStyle -> {FontSize -> 16}]

Heijastus- ja läpäisytodennäköisyydet oskilloivat potentiaalivallin paksuuden funktiona. Voidaan lisäksi osoittaa, että potentiaalivallin paksuuden ollessa vallissa etenevän hiukkasen aallonpituuden puolikkaan monikerta heijastumista ei tapahdu ollenkaan ja kaikki säteily tunkeutuu vallin lävitse.

Tarkastellaan seuraavaksi heijastus- ja läpäisykertoimia, kun a=4 ja V\(TraditionalForm\`\_0\)=1.
Piirretään ensin kertoimet hiukkasen energian funktiona, kun hiukkasen energia≥V\(TraditionalForm\`\_0\).

Clear[e]
a = 4;
v0 = 1;
tx = Table[{n, n, 0.03}, {n, 0, 10, 2}];
ty = 
        Table[{n, n, 0.03}, {n, 0, 1, 0.2}];
kuva3 = 
        Plot[{1, R, T}, {e, v0, 10}, 
          PlotStyle -> {Hue[0, 0, 0], Hue[0], Hue[0.65]}, 
          Background -> 
            RGBColor[0.6, 0.8, 0.8],   
            AxesLabel -> {γ, P}, Ticks -> {tx, ty}, 
          DisplayFunction -> Identity, 
          TextStyle -> {FontSize -> 10}];

teksti = {Graphics[Text["R", {1.8, 0.2}]], 
          Graphics[Text["T", {1.8, 0.8}]]};

Show[{kuva3, teksti}, DisplayFunction -> $DisplayFunction, 
      TextStyle -> {FontSize -> 16}]

Piirretään seuraavaksi kertoimet, kun hiukkasen energia ≤ V\(TraditionalForm\`\_0\).

Clear[A, T, R, k, v0, a]
A := v0^2/(4  e (v0 - e))
T := 1/(1 + A*Sinh[k*a]^2)
R := A*Sinh[k*a]^2/(1 + A*Sinh[k*a]^2)
k :=  Sqrt[v0 - e]
v0 = 1;
a = 4;
tx = 
        Table[{n, n, 0.03}, {n, 0, 1, 0.2}];
ty = 
        Table[{n, n, 0.03}, {n, 0, 1, 0.2}];
kuva2 = 
        Plot[{1, R, T}, {e, 0, v0}, PlotRange -> All, 
          PlotStyle -> {Hue[0, 0, 0], Hue[0], Hue[0.65]}, 
          Background -> 
            RGBColor[0.6, 0.8, 0.8],   
            AxesLabel -> {γ, P}, Ticks -> {tx, ty}, 
          DisplayFunction -> Identity, 
          TextStyle -> {FontSize -> 10}];

teksti = {Graphics[Text["R", {0.6, 0.85}]], 
          Graphics[Text["T", {0.6, 0.15}]]};

Show[{kuva2, teksti}, DisplayFunction -> $DisplayFunction, 
      TextStyle -> {FontSize -> 16}]

Show[{kuva3, kuva2, 
        teksti},   DisplayFunction -> $DisplayFunction, 
      TextStyle -> {FontSize -> 16}]

Kuvaajista nähdään, että heijastustodennäköisyys on suurimmillaan hiukkasen energian ollessa pienempi kuin potentiaalivallin korkeus. Kuitenkin heijastuminen on mahdollista myös potentiaalivallin korkeutta suuremiilla hiukkasen energian arvoilla.

Piirretään sironnan aaltofunktion reaaliosa potentiaalivalissa.

Clear[Ah, Bh, Ch, Dh, x, Ψ, a, alf, k, u, 
      k0]
Ah[k_, u_, 
        a_] := -E^(-I k a)*2*(1 + u)/
          alf[k, a, u]
Bh[k_, u_, a_] := 
      E^(I k a)*2*(1 - u)/alf[k, a, u]
Fh[k0_, u_, a_] := -E^(-I k0 a)*4 
         u/alf[k, a, u]
Ch[k_, u_, a_] := 
      2  I Sin[k a] (1 - u^2)/alf[k, a, u]
alf[k_, a_, u_] := 
      2  I (1 + u^2) Sin[k a] - 4  u Cos[k a]

k = 2; a = 5; k0 = 5; u = k/k0;
Ψ[x_] := 
      E^(I k0 x) + Ch[k, u, a] E^(-I k0 x) /; 
        x ≤ 0
Ψ[x_] := 
      Ah[k, u, a]*E^(I k x) + Bh[k, u, a] E^(-I k x) /; 
        0 < x < a
Ψ[x_] := 
      Fh[k0, u, a] E^(I k0 x) /; x ≥ a

kuvavalli = 
        Plot[Re[Ψ[x]], {x, -2 a, 2  a}, 
          PlotStyle -> Hue[0.69], DisplayFunction -> Identity, 
          TextStyle -> {FontSize -> 10}];

Show[{kuvavalli, 
        Graphics[{Thickness[0.01], Line[{{a, 0}, {a, 3}}], 
            Line[{{0, 0}, {0, 3}}], Line[{{0, 3}, {a, 3}}]}]}, 
      AxesLabel -> {x, Ψ}, Axes -> True, 
      Ticks -> False, Background -> RGBColor[0.6, 0.8, 0.8], 
      PlotRange -> {{-2 a, 2  a}, {-2, 4}}, 
      DisplayFunction -> $DisplayFunction, 
      TextStyle -> {FontSize -> 16}]

Animaatio aaltopaketin sironnalle potentiaaliportaasta

Clear[G, K0, x, t, a, hbar, m, k, k0, wave]
G[x_, k_, t_] := 
      1/(Sqrt[Sqrt[Pi]*(delta + ((I hbar t)/(m delta)))])*
        Exp[-(x - ((hbar k)/m) 
                        t)^(2/(2 delta^2 (1 + ((I hbar t)/(m delta^2)))))]*Exp[I k*(x - hbar k t/2  m)]

K0 = 10; k0 = 10.5; k2 = Sqrt[k0^2 - K0^2]; a = 1; delta = 1; m = 1; 
    hbar = 1

wave[x_, t_] := 
      UnitStep[-x]*G[x + a, k0, t] + 
        UnitStep[-x]*G[x - a, -k0, t]*(k0 - k2)/(k0 + k2) +  
        UnitStep[x]*G[k0/Sqrt[k0^2 - K0^2]*x + a, k0, t]*
          Exp[-((I K0^2 x)/Sqrt)[k0^2 - K0^2]]*(2 k0/(k0 + 
                    k2))

Table[
      Plot[{0.4  UnitStep[x], Abs[wave[x, t]]^2}, {x, -6, 6}, 
        PlotRange -> {{-6, 6}, {0, 2}}, 
        Background -> RGBColor[0.6, 0.8, 0.8], 
        PlotStyle -> {{Thickness[0.01]}, {Thickness[0]}}, 
        Ticks -> False], {t, -0.17, 1. , 0.01}]

K0 = 10; k0 = 9.5; k2 = Sqrt[k0^2 - K0^2]; a = 1; delta = 1; m = 1; 
    hbar = 1

wave[x_, t_] := 
      UnitStep[-x]*G[x + a, k0, t] + 
        UnitStep[-x]*G[x - a, -k0, t]*(k0 - k2)/(k0 + k2) +  
        UnitStep[x]*G[k0/Sqrt[k0^2 - K0^2]*x + a, k0, t]*
          Exp[-((I K0^2 x)/Sqrt)[k0^2 - K0^2]]*(2 k0/(k0 + 
                    k2))

Table[
      Plot[{0.4  UnitStep[x], Abs[wave[x, t]]^2}, {x, -10, 0.1}, 
        PlotRange -> {{-6, 6}, {0, 2}}, 
        Background -> RGBColor[0.6, 0.8, 0.8], 
        PlotStyle -> {{Thickness[0.01]}, {Thickness[0]}}, 
        Ticks -> False], {t, -0.17, 1.0, 0.01}]

3D sironta potentiaalikuopasta

n = 0;
r0 =. ;
h0 =. ;
k =. 
h = Sqrt[k^2 + h0^2];
d := n*Pi - k*r0 + ArcTan[k*Tan[h*r0]/h]
stot = 4*Pi*Sin[d]^2/k^2;
Series[stot, {k, 0, 2}] // Simplify;
PowerExpand[%] // Simplify;

Kokonaisvaikutusala aaltoluvun funktiona

h0 = 1. ;
r0 = 1;
tx = Table[{n, n, 0.03}, {n, 0, 3, 1}];
ty = Table[{n, n, 0.03}, {n, 1, 4, 1}];
Plot[stot, {k, 0, 3}, PlotStyle -> {Hue[0.69]}, 
      Background -> RGBColor[0.6, 0.8, 0.8], PlotRange -> All, 
      AxesLabel -> {k, (Subscript[σ, TOT])}, Ticks -> {tx, ty}, 
      TextStyle -> {FontSize -> 20}]

SetDirectory["D:/Mikko/opetus/kvmii"];
Display["kuva24.eps", %31, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

Vaihesiirto kuoppapotentiaalista

Clear[r, u]
h0 = 1;
r0 = 1. ;
 k = 1;
b =  Sin[h*r0]/Sin[k*r0 + d]
u[r_] := Sin[h*r] /; r <= r0
u[r_] := b*Sin[k*r + d] /; r > r0
tx = 
        Table[{n, n, 0.03}, {n, -1, 3, 1}];
ty = 
        Table[{n, n, 0.03}, {n, -1.5, 1.5, 
            0.5}];
kuvab = 
      Plot[{b*Sin[k*r + d]}, {r, -0.5,  1}, 
        PlotRange -> {{-1, 3}, {0, 2}}, 
        DisplayFunction -> Identity]
kuva = 
      Plot[{b*Sin[k*r], u[r]}, {r, 0,  3}, PlotRange -> All, 
        PlotStyle -> {Hue[0.69], Hue[0], Hue[0.88]}, 
        Background -> RGBColor[0.6, 0.8, 0.8], AxesLabel -> {r, u}, 
        Ticks -> {tx, ty}, TextStyle -> {FontSize -> 20}, 
        DisplayFunction -> Identity]

Show[{kuva, kuvab, Graphics[Text["sin(kr)", {2.9, 0.9}]], 
        Graphics[Text["u(r)", {2, 0.3}]], 
        Graphics[Text["-δ", {-0.2, -0.1}]], 
        Graphics[Text["sin(kr+δ)", {-0.5, 0.8}]]}, 
      DisplayFunction -> $DisplayFunction]

SetDirectory["D:/Mikko/opetus/kvmii"];
Display["kuva25.eps", %115, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

Kokonaisvaikutusala kuopan leveyden funktiona, kun k=0.1

Clear[r0]
h0 = 1;
k = 0.1;
tx = Table[{n, n, 0.03}, {n, 0, 10, 2}];
ty = 
        Table[{n, n, 0.03}, {n, 0, 1000, 500}];
Plot[stot, {r0, 0, 10}, PlotStyle -> {Hue[0.69]}, 
      Background -> RGBColor[0.6, 0.8, 0.8], PlotRange -> All, 
      AxesLabel -> {(Subscript[r, 0]), (Subscript[σ, TOT])}, Ticks -> {tx, ty}, 
      TextStyle -> {FontSize -> 20}]

SetDirectory["D:/Mikko/opetus/kvmii"];
Display["rvirtual.eps", %136, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

Kuoppapotentiaalin s-aalto vaihesiirto

Clear[k, r0, k]
d := -k*r0 + ArcTan[k*Tan[h*r0]/h] /; h*r0 < Pi/2
d := 1*Pi - k*r0 + ArcTan[k*Tan[h*r0]/h] /; 
        h*r0 < 3  Pi/2
d := 2*Pi - k*r0 + ArcTan[k*Tan[h*r0]/h] /; 
        h*r0 < 5  Pi/2
d := 3*Pi - k*r0 + ArcTan[k*Tan[h*r0]/h] /; 
        h*r0 < 7  Pi/2
h0 = 1;
k = 0.1;
tx = Table[{n, n, 0.03}, {n, 0, 10, 2}];
ty = Table[{n, n, 0.03}, {n, 0, 10, 2}];
Plot[d, {r0, 0, 10}, PlotStyle -> {Hue[0.69]}, 
      Background -> RGBColor[0.6, 0.8, 0.8], PlotRange -> All, 
      AxesLabel -> {(Subscript[r, 0]), (Subscript[δ, 0])}, Ticks -> {tx, ty}, 
      TextStyle -> {FontSize -> 20}]

SetDirectory["D:/Mikko/opetus/kvmii"];
Display["svaihe.eps", %528, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

Sirontapituus

Clear[a, h]
asir := r0 - ArcTan[k*Tan[h*r0]/h]/k
k = 0.1
h0 = 1
h = Sqrt[k^2 + h0^2];
tx = Table[{n, n, 0.03}, {n, 0, 10, 2}];
ty = Table[{n, n, 0.03}, {n, 0, 20, 10}];
Plot[asir, {r0, 0, 10}, PlotStyle -> {Hue[0.69]}, 
      Background -> RGBColor[0.6, 0.8, 0.8], PlotRange -> All, 
      AxesLabel -> {(Subscript[r, 0]), a}, Ticks -> {tx, ty}, 
      TextStyle -> {FontSize -> 20}]

SetDirectory["D:/Mikko/opetus/kvmii"];
Display["sirpit.eps", %1066, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

Sirontapituus luettuna aaltofunktion nollakohdasta

h0 = 1
r0 = Pi/2 + 0.03
k = 0.001
h = Sqrt[k^2 + h0^2]
d := -k*r0 + ArcTan[k*Tan[h*r0]/h] /; 
        h*r0 <= Pi/2
d := -k*r0 + ArcTan[k*Tan[h*r0]/h] /; 
        Pi/2 <= h*r0 <= 3  Pi/2
b =  Sin[h*r0]/Sin[k*r0 + d]
kuvab = 
      Plot[{b*Sin[k*r + d]}, {r, -50,  50}, 
        PlotRange -> All]

Kokonaisvaikutusala s-aaltosironnassa

a = 5.38;
reff = 1.75;
stot := 
      4*Pi/(k^2 + (-1/a + 
                    1/2*reff*k^2)^2)
tx = 
        Table[{n, n, 0.03}, {n, 0, 2, 0.5}];
ty = 
        Table[{n, n, 0.03}, {n, 0, 350, 50}];
kuva1 = 
        Plot[stot, {k, 0, 2}, PlotStyle -> Hue[0.69], 
          Background -> RGBColor[0.6, 0.8, 0.8], 
          AxesLabel -> {k, (Subscript[σ, TOT])}, Ticks -> {tx, ty}, 
          TextStyle -> {FontSize -> 16}, PlotRange -> All, 
          DisplayFunction -> Identity];
a = -23.7;
reff = 2.4;
tx = 
        Table[{n, n, 0.03}, {n, 0, 2, 0.5}];
ty = 
        Table[{n, n, 0.03}, {n, 0, 7000, 1000}];
kuva2 = 
        Plot[stot, {k, 0, 2}, PlotStyle -> Hue[0.69], 
          Background -> RGBColor[0.6, 0.8, 0.8], 
          AxesLabel -> {k, (Subscript[σ, TOT])}, Ticks -> {tx, ty}, 
          TextStyle -> {FontSize -> 16}, PlotRange -> All, 
          DisplayFunction -> Identity];
Show[{kuva1, Graphics[Text["a = 5.38, reff = 1.75", {1.25, 300}]]}, 
      DisplayFunction -> $DisplayFunction]
Show[{kuva2, 
        Graphics[Text["a = -23.7, reff = 2.4", {1.25, 6000}]]}, 
      DisplayFunction -> $DisplayFunction]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmii\
"];
Display["kuva26.eps", %177, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmii\
"];
Display["kuva27.eps", %178, "EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1\
"];

Integrate[r*Sin[K*r] E^(-r^2/a^2), {r, 0, Infinity}] // 
      Simplify

Besselin funktiot

DSolve[u''[r] + (1 - l*(l + 1)/r^2) u[r] == 0, u[r], 
      r]

Matriisielementit vetymolekyyli-ionille

M1 = -8/R*Integrate[r^2*E^(-2 r), {r, 0, R}] - 
          8*Integrate[r E^(-2 r), {r, R, Infinity}] // 
        Simplify

M2 = 
      4/R*E^(-R)*Integrate[r (E^(-2 r) - 1), {r, 0, R}] + 
          4/R*(E^(-R) - E^R)*
            Integrate[r*E^(-2*r), {r, R, Infinity}] // 
        Simplify

Integrate[t*E^(-t), {t, a, b}]

N2p = 
      2 + 4/R*E^(-R)*
            Integrate[
              r*(1 + R - r - (1 + R + r) E^(-2 r)), {r, 0, 
                R}] + 4/R*
            Integrate[
              r*E^(-2 r)*((1 + r - R)*E^R - (1 + r + R)*
                      E^(-R)), {r, R, Infinity}] // 
        Simplify
N2m = 
      2 - 4/R*E^(-R)*
            Integrate[
              r*(1 + R - r - (1 + R + r) E^(-2 r)), {r, 0, 
                R}] - 4/R*
            Integrate[
              r*E^(-2 r)*((1 + r - R)*E^R - (1 + r + R)*
                      E^(-R)), {r, R, Infinity}] // 
        Simplify

up = 2/R + 2*(M1 + M2)/N2p // Simplify
um = 2/R + 2*(M1 - M2)/N2m // Simplify

derip = D[up, R] // Simplify
roo = FindRoot[derip == 0, {R, 1}]
up /. roo
derim = D[um, R] // Simplify
room = FindRoot[derim == 0, {R, 10}]
um /. room

Plot[{up - 1, um - 1}, {R, 1, 10}]

Vetymolekyylin orbitaalit

a = 1
b = 0
norp = 1/Sqrt[N2p /. R -> 2  a]
norm = 1/Sqrt[N2m /. R -> 2  a]
ContourPlot[
      norp*(E^-Sqrt[(x - a)^2 + (y - b)^2] + 
            E^-Sqrt[(x + a)^2 + (y + b)^2]), {x, -2, 
        2}, {y, -2, 2}]
ContourPlot[
      norm*(E^-Sqrt[(x - a)^2 + (y - b)^2] - 
            E^-Sqrt[(x + a)^2 + (y + b)^2]), {x, -2, 
        2}, {y, -2, 2}]

Tilatiheys ja delta-funktion

del := 
      Sin[1/2*(wk - w)*t]^2/(wk - w)^2
wk = 1
t = 100
kuva = Plot[del, {w, 0, 2}, PlotRange -> All]

Helium atomin perus ja viritystilat

Aaltofunktio ja sen normitus

phi1s = Exp[-r]/Sqrt[Pi]
phi2s = 
      Exp[-r/2]*(2 - r)/Sqrt[8*4*Pi]
phi2p = Exp[-r/2]*r/Sqrt[24*4*Pi]
Integrate[
      4*Pi*r^2*phi1s^2, {r, 0, Infinity}]
Integrate[
      4*Pi*r^2*phi2s^2, {r, 0, Infinity}]
Integrate[4*Pi*r^2*phi2p^2, {r, 0, Infinity}]

Coulombin potentiaalin Fourier muunnos

4  Pi/k*Sqrt[Pi/2] 
      FourierSinTransform[E^(-a*r), r, k]
1/(2  Pi^2*r)*Sqrt[Pi/2] 
        FourierSinTransform[4  Pi*k/(a^2 + k^2), k, r] // 
      PowerExpand

Heliumin perustila

Integrate[Cos[k*r*t], {t, -1, 1}]

f1s = 
      4  Pi/k*Sqrt[Pi/2]*
        FourierSinTransform[r*phi1s^2, r, k]
J = 
      1/(2  Pi^2)*
        Integrate[4*Pi*f1s^2, {k, 0, Infinity}]
Z = 2
J*Z^2*13.6
ene = (-2 + J)*Z^2*13.6

Heliumin  1s2s-viritystila

f2s = 
      4  Pi/k*Sqrt[Pi/2]*
        FourierSinTransform[r*phi2s^2, r, k]
J = 
      1/(2  Pi^2)*
        Integrate[4*Pi*f1s*f2s, {k, 0, Infinity}]
Z = 2
J*Z^2*13.6
f1s2s = 
      4  Pi/k*Sqrt[Pi/2]*
        FourierSinTransform[r*phi1s*phi2s, r, k]
Kvai = 
      1/(2  Pi^2)*
        Integrate[4*Pi*f1s2s^2, {k, 0, Infinity}]
tulos = Kvai*Z^2*13.6
enes1 = (-1 - 1/4 + J + Kvai)*
        Z^2*13.6
enes2 = (-1 - 1/4 + J - Kvai)*Z^2*13.6

Heliumin  1s2p-viritystila

Integrate[t Sin[k*r*t], {t, -1, 1}]

f2p = 4*Pi*Sqrt[Pi/2]*FourierSinTransform[r*phi2p^2, r, k]/k
Plot[{f2p, f1s}, {k, 0, 10}, PlotRange -> All]

Z = 2
J = 1/(2  Pi^2)*Integrate[4*Pi*f1s*f2p, {k, 0, Infinity}]
J*Z^2*13.6
f1s2p = 
      4*Pi*Sqrt[
            Pi/2]*(FourierSinTransform[phi1s*phi2p, r, k]/
                k^2 - 
FourierCosTransform[r*phi1s*phi2p, 
                  r, k]/k) // Simplify
Kvai = 
      1/(2*Pi^2)*Integrate[4*Pi*f1s2p^2, {k, 0, Infinity}]
tulos = Kvai*Z^2*13.6
enep1 = (-1 - 1/4 + J + Kvai)*
        Z^2*13.6
enep2 = (-1 - 1/4 + J - Kvai)*Z^2*13.6

Kuvia

ParametricPlot3D[{Sin[t] Cos[p], 
        Sin[t] Sin[p], Cos[t]}, {t, 0, Pi}, {p, 0, Pi/4}, 
      ViewPoint -> {1, -0.5, 0.2}]