Kvanttimekaniikan luennot 2010

Aallon vaihe- ja ryhmänopeus

k=2;
w=2;
Animate[Plot[Cos[k* x-w*t],{x,0,20},Axes->False],{t,0,10,0.2}]

k=5;
w=5;
dk=0.3;
dw=0.1;
Animate[ Plot[(Sin[(k+dk)* x-(w+dw)*t]+Sin[(k-dk)* x-(w-dw)*t]),{x,0,20},Axes->False],{t,1,30,0.3}]

Yksöisrakokoe

Show[Graphics[{Line[{{-1,3},{-1,1}}],Line[{{-1,-1},{-1,-3}}],Line[{{-1.25`,0},{3,0}}],Line[{{2,4},{2,-4}}],Line[{{-1,0},{2,2}}],Line[{{2.2`,2},{2.4`,2}}],Arrow[{2.3`,0},{2.3`,2},HeadScaling->Relative],Text[x,{2.5`,1}],Text[(Subscript[r, 0]),{0.5`,1.5`}],Arrow[{0.3`,-2},{-1,-2},HeadScaling->Relative],Arrow[{0.7`,-2},{2,-2},HeadScaling->Relative],Text[L,{0.5`,-2}],Line[{{-1.4`,1},{-1.6`,1}}],Line[{{-1.4`,-1},{-1.6`,-1}}],Arrow[{-1.5`,0.5`},{-1.5`,1},HeadScaling->Relative],Arrow[{-1.5`,-0.5`},{-1.5`,-1},HeadScaling->Relative],Text[b,{-1.5`,0}],Circle[{-1,0},0.7`,{0,(π/6)}],Text[Θ,{0.15`,0.3`}],Arrow[{-3,2},{-2,2},HeadScaling->Relative],Arrow[{-3,1},{-2,1},HeadScaling->Relative],Arrow[{-3,0},{-2,0},HeadScaling->Relative],Arrow[{-3,-1},{-2,-1},HeadScaling->Relative],Arrow[{-3,-2},{-2,-2},HeadScaling->Relative]}],BaseStyle->{FontSize->17},Background->RGBColor[0.6`,0.8`,0.8`]]

Kun Θ ~ 0 niin (Subscript[r, 0])~L.

Clear[i,beta,x,k,El,eps0,c,b,L,i0]

b=0.55*10^-7
L=0.5
k=10^9
c=3*10^8
eps0=8.854*10^-12
El=1
i[x_]:=2eps0 c El^2/(k^2x^2)*Sin[0.5 k b x/L]^2
Plot[i[x],{x,-1,1},Background->RGBColor[0.6,0.8,0.8],PlotRange->All]

Kaksoisrakokoe

Clear[L,x,b,a]
Show[Graphics[{Line[{{-1,0.6`},{-1,-0.6`}}],Line[{{-1,1.4`},{-1,3}}],Line[{{-1,-1.4`},{-1,-3}}],Line[{{-1.25`,0},{3,0}}],Line[{{2,4},{2,-4}}],Line[{{-1,0},{2,2}}],Line[{{2.2`,2},{2.4`,2}}],Line[{{-1,1},{2,2}}],Line[{{-1,-1},{2,2}}],Arrow[{2.3`,0},{2.3`,2},HeadScaling->Relative],Text[x,{2.5`,1}],Text[(Subscript[r, 0]),{0.5`,1.5`}],Arrow[{0.3`,-2},{-1,-2},HeadScaling->Relative],Arrow[{0.7`,-2},{2,-2},HeadScaling->Relative],Text[L,{0.5`,-2}],Line[{{-1.4`,1},{-1.6`,1}}],Line[{{-1.4`,-1},{-1.6`,-1}}],Arrow[{-1.5`,0.5`},{-1.5`,1},HeadScaling->Relative],Arrow[{-1.5`,-0.5`},{-1.5`,-1},HeadScaling->Relative],Text[a,{-1.5`,0}],Text[b,{-1,1}],Text[b,{-1,-1}],Circle[{-1,0},0.7`,{0,(π/6)}],Text[Θ,{0,0.28`}],Arrow[{-3,2},{-2,2},HeadScaling->Relative],Arrow[{-3,1},{-2,1},HeadScaling->Relative],Arrow[{-3,0},{-2,0},HeadScaling->Relative],Arrow[{-3,-1},{-2,-1},HeadScaling->Relative],Arrow[{-3,-2},{-2,-2},HeadScaling->Relative]}],BaseStyle->{FontSize->17},Background->RGBColor[0.6`,0.8`,0.8`]]

Clear[i,beta,x,k,El,eps0,c,b,L,i0,a]

b=10^-8;
a=4b;
L=10;
k=10^9;
c=3*10^8;
eps0=8.854*10^-12;
El=1
i[x_]:=8 eps0 c El^2/(k^2x^2)*Sin[0.5 k b x/L]^2*Cos[0.5 k a x/L]^2
Plot[i[x],{x,-2,2},Background->RGBColor[0.6,0.8,0.8]]

Aaltofunktio äärettömässä potentiaalikuopassa

Luentomoniste s. 26 - 28

a=1;
teksti={Graphics[Text["V = ",{1.33`,3}]],Graphics[Text["ääretön",{1.5`,2.5`}]],Graphics[Text["V = 0",{0.5`,3}]],Graphics[Text["V =",{-0.73`,3}]],Graphics[Text["ääretön",{-0.5`,2.5`}]]};
Show[{Graphics[{Thickness[0.01`],Line[{{0,0},{a,0}}],Line[{{a,0},{a,5}}],Line[{{0,0},{0,5}}]}],teksti},AxesLabel->{x,V},Axes->True,Ticks->False,Background->RGBColor[0.6`,0.8`,0.8`],PlotRange->{{-1,2},{-1,5}},BaseStyle->{FontSize->17}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva9.eps",%199,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Piirretään kolmen alimman tilan normitetut aaltofunktiot äärettömässä potentiaalikuopassa. Koska potentiaali on ääretön kuopan ulkopuolella täytyy aaltofunktion toteuttaa reunaehdot:  (Subscript[u, n])(0)= (Subscript[u, n])(a)= 0 
Sisäalueessa potentiaali on nolla, joten Schrödingerin yhtälö supistuu muotoon u'' + (k^2)u = 0. Reunaehdoista ja normituksesta seuraa aaltofunktio (Subscript[u, n])(x) = (Sqrt[(2/a)])sin (((nπ)/a)x) = (Sqrt[(2/a)])sin [k(n)x]

Clear[n,k,a,u]
a=1;
k[n_]=((n π)/a);
wave[n_,x_]=(Sqrt[(2/a)]) Sin[k[n] x];
tx=Table[{n,n,0.03`},{n,0,1,0.25`}];
ty=Table[{n,n,0.03`},{n,-1.5`,1.5`,0.5`}];
kuva=Plot[Evaluate[Table[wave[n,x],{n,1,3}]],{x,0,a},PlotStyle->{Hue[0],{Hue[0.9`],Dashing[{0.05`,0.05`}]},{Hue[0.7`],Dashing[{0.005`,0.03`,0.07`,0.03`}]}},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,(Subscript[u, n])},Ticks->{tx,ty},DisplayFunction->Identity,BaseStyle->{FontSize->10}];
(∫_0^a)((wave[4,x])^2)\[DifferentialD]x

teksti={Graphics[Text["n=1",{0.71,1.5}]],Graphics[Text["n=2",{0.5,0.7}]],Graphics[Text["n=3",{0.37,0.5}]]};

Show[{kuva,Graphics[Line[{{1,-2},{1,2}}]],teksti},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->16}]

Eli, kuten reunaehdoista jo nähtiin, aaltofunktiot vastaavat päistään kiinnitetyn kielen värähtelyä.

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva10.eps",%212,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Piirretään vielä systeemin todennäköisyystiheydet kolmelle alimmalle tilalle.

tx=Table[{n,n,0.03},{n,0,1,0.25}];
ty=Table[{n,n,0.03},{n,-1.5,1.5,0.5}];
kuva1=Plot[Evaluate[Table[wave[n,x]^2,{n,1,3}]],{x,0,a},PlotStyle->{Hue[0],{Hue[0.9],Dashing[{0.05,0.05}]},{Hue[0.7],Dashing[{0.005,0.03,0.07,0.03}]}},Background->RGBColor[0.6,0.8,0.8],AxesLabel->{x,((Subscript[u, n])^2)},
(*PlotLabel->StyleForm["Normitetut TN-tiheydet n=1,2,3",FontSize->11],*)Ticks->{tx,ty},DisplayFunction->Identity];

teksti1={Graphics[Text["n=1",{0.64,2}]],Graphics[Text["n=2",{0.35,2}]],Graphics[Text["n=3",{0.93,2}]]};

Show[{kuva1,teksti1,Graphics[Line[{{1,0},{1,2}}]]},DisplayFunction->$DisplayFunction,PlotRange->{{0,1},{0,2.2`}},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva10b.eps",%15,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Show[GraphicsRow[{kuva,kuva1}],BaseStyle->{FontSize->10}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva10c.eps",%224,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Äärellinen potentiaalikuoppa

Luentomoniste s. 28 - 32

"Arvataan" ensin aaltofunktio ja piirretään sen kuvaaja.

Clear[a,k,kappa,wave,x]
a=1;
k=2;
kappa=0.5;
wave[x_]:=E^(kappa*x)/;x≤0
wave[x_]:=1E^(k x I)+2E^(-k x I)/;0<x<a
wave[x_]:=1.5E^(-kappa*x)/;x≥a

tx=Table[{n,n,0.03`},{n,-5,7,1}];
ty=Table[{n,n,0.03`},{n,-3,5,1}];
aalto1=Plot[Re[wave[x]],{x,0,a},DisplayFunction->Identity,PlotStyle->Hue[0],Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,V},Ticks->None,BaseStyle->{FontSize->10}];
aalto2=Plot[wave[x],{x,-1,0},DisplayFunction->Identity,PlotStyle->Hue[0],Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,V},Ticks->None,BaseStyle->{FontSize->10}];
aalto3=Plot[wave[x],{x,a,2},DisplayFunction->Identity,PlotStyle->Hue[0],Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,V},Ticks->None,BaseStyle->{FontSize->10}];

tekstipot={Graphics[Text["II",{0.5,-1}]],Graphics[Text["I",{-0.5,-2}]],Graphics[Text["III",{1.5,-2}]],Graphics[Text["V = -(Subscript[V, 0])",{0.5,-2.5}]],Graphics[Text["V = 0",{-0.5,-1}]],Graphics[Text["V = 0",{1.5,-1}]],Graphics[Text["a",{.9,0.25}]],Graphics[Text["0",{0.1,0.25}]]};

Show[{aalto1,aalto2,aalto3,Graphics[{Thickness[0.01`],Line[{{0,-3},{a,-3}}],Line[{{0,-3},{0,0}}],Line[{{0,0},{-1,0}}],Line[{{a,-3},{a,0}}],Line[{{a,0},{2,0}}]}],Graphics[Line[{{a,0},{a,3}}]],tekstipot},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->18}]

Kuten kuvaajasta nähdään, aaltofunktio ei ole jatkuva rajoilla x=0 ja x=a.

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva11.eps",%241,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Energian ominaisarvot

Ratkaistaan energian ominaisarvot graafisesti. Luentojen mukaan y= γα = 2arccos α + (n-1)π. Tämä yhtälö toteutuu, kun sen oikean ja vasemman puolen funktioiden kuvaajat leikkaavat. γ on energiasta riippumaton vakio. Seuraavaksi piirretään funktioiden kuvaajat ja määritetään niiden leikkauspisteet eri γ:n arvoilla.

Clear[gam,alf,n]
tx=Table[{n,n,0.04`},{n,0,1,0.25`}];
ty=Table[{n,n,0.04`},{n,0,12,2}];
suora=Plot[Evaluate[Table[gam alf,{gam,1,13,4}]],{alf,0,1},PlotStyle->{Hue[0.69`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{α,y},Ticks->{tx,ty},DisplayFunction->Identity,BaseStyle->{FontSize->10}];
teksti={Graphics[Text["γ=1",{1.07`,1.3`}]],Graphics[Text["γ=5",{1.07`,5.3`}]],Graphics[Text["γ=9",{1.07`,9.3`}]],Graphics[Text["γ=12",{1.07`,13.3`}]]};
Show[{suora,teksti},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->13},PlotRange->{{0,1.2`},{0,14}}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva12a.eps",%253,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

arccos=Plot[Evaluate[Table[2 ArcCos[alf]+π (n-1),{n,1,4,1}]],{alf,0,1},PlotStyle->{Hue[0.79`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{α,y},Ticks->{tx,ty},DisplayFunction->Identity,BaseStyle->{FontSize->10}];
teksti2={Graphics[Text["2arccosα + 3π",{0.275`,13}]],Graphics[Text["2arccosα + 2π",{0.26`,10}]],Graphics[Text["2arccosα + π",{0.25`,7}]],Graphics[Text["2arccosα",{0.17`,3.8`}]]};
Show[{arccos,teksti2},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->13},PlotRange->{{0,1.2`},{0,14}}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva12b.eps",%259,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Show[{arccos,suora,teksti,teksti2},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->13},PlotRange->{{0,1.2`},{0,14}}]

Kuvan kuvaajien leikkauspisteet ovat sallittuja energianarvoja. Kuten kuvaajista nähdään, parametrin γ kasvaessa potentiaalikuoppa syvenee ja sidottujen tilojen lukumäärä kasvaa.

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva12c.eps",%263,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Numeerinen ratkaisu

Ratkaistaan seuraavaksi kuvaajien leikkauspiste numeerisesti γ:n arvolla 1.

Clear[alf]
gam=1;
n=1;
arvaus=0.95;
FindRoot[gam*alf==2ArcCos[alf]+(n-1)Pi,{alf,arvaus}]
alf=alf/.%

Aaltofunktiot

Piirretään numeerista ratkaisua vastaava aaltofunktio välillä  -∞ -> ∞ a:n arvolla 1. Lisäksi γ = 1ja n=1.

a=1;
k =gam *alf/a;
kappa=gam*Sqrt[1-alf^2]/a;
wave[x_]:=E^(kappa*x)/;x≤0
wave[x_]:=1/alf *Sin[k*(x-a/2)+n*Pi/2]/;0<x<a
wave[x_]:=(-1)^(n-1)E^(-kappa*(x-a))/;x≥a
tx=Table[{n,n,0.03},{n,-20,20,10}];
ty=Table[{n,n,0.03},{n,0,1,0.2}];

teksti={Graphics[Text["γ = 1, n = 1",{12,0.9`}]]};
perus=Plot[wave[x],{x,-20,20},PlotRange->All,PlotStyle->{Hue[0]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,(Subscript[u, n])},Ticks->{tx,ty},DisplayFunction->Identity];
Show[{perus,teksti},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->15}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuvaxx.eps",%283,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Nyt γ = 12 ja n=1.

Clear[alf]
gam=12;
n=1;
arvaus=0.2;
FindRoot[gam*alf==2ArcCos[alf]+(n-1)Pi,{alf,arvaus}]
alf=alf/.%

a=1;
k =gam *alf/a;
kappa=gam*Sqrt[1-alf^2]/a;
wave[x_]:=E^(kappa*x)/;x≤0
wave[x_]:=1/alf *Sin[k*(x-a/2)+n*Pi/2]/;0<x<a
wave[x_]:=(-1)^(n-1)E^(-kappa*(x-a))/;x≥a
tx=Table[{n,n,0.03},{n,-4,4,2}];
ty=Table[{n,n,0.03},{n,0,10,1}];

teksti2={Graphics[Text["γ = 12, n = 1",{4,3}]]};
kakst=Plot[wave[x],{x,-5,5},PlotRange->All,PlotStyle->{Hue[0]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,(Subscript[u, n])},Ticks->{tx,ty},DisplayFunction->Identity];
Show[{kakst,teksti2},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->15}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuvaxx2.eps",%303,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Nyt γ = 12 ja n = 2.

Clear[alf]
gam=12;
n=2;
arvaus=0.4;
FindRoot[gam*alf==2ArcCos[alf]+(n-1)Pi,{alf,arvaus}]
alf=alf/.%

a=1;
k =gam *alf/a;
kappa=gam*Sqrt[1-alf^2]/a;
wave[x_]:=E^(kappa*x)/;x≤0
wave[x_]:=1/alf *Sin[k*(x-a/2)+n*Pi/2]/;0<x<a
wave[x_]:=(-1)^(n-1)E^(-kappa*(x-a))/;x≥a
tx=Table[{n,n,0.03},{n,-4,4,2}];
ty=Table[{n,n,0.03},{n,-2,2,1}];

teksti3={Graphics[Text["γ = 12, n = 2",{2.5`,2}]]};
virit=Plot[wave[x],{x,-4,4},PlotRange->All,PlotStyle->{Hue[0]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,(Subscript[u, n])},Ticks->{tx,ty},DisplayFunction->Identity];
Show[{virit,teksti3},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->15}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuvaxx3.eps",%323,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Ratkaisu, kun V0->0

Graafisesta ratkaisusta nähdään, että rajalla (Subscript[V, 0]) -> 0 
		α -> 1-δ , missä δ = ((Abs(E))/(2(Subscript[V, 0])))
Täten ominaisarvoyhtälö  γα = 2arccos α voidaan kehittää sarjaksi nollan ympäristössä. Tällöin

Series[ArcCos[1-δ],{δ,0,2}]

Joten γ(1-δ) = 2arccos(1-δ) -> 2(Sqrt[2δ]), kun δ->0

Symmetrinen kuoppa

Luentomoniste s. 32 - 37

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

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva13.eps",%329,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Energian ominaisarvot

Ratkaistaan energian ominaisarvot taas graafisesti. Symmetrisessä tapauksessa η = ξ tan ξ ja antisymmetrisessä η = - ξ cot ξ. Toisaalta η2 = R2 - ξ2. Symmetriset ja antisymmetriset ratkaisut saadaan näiden funktioiden kuvaajien leikkauspisteistä.

r=(Sqrt[12]);
tx=Table[{n,n,0.03`},{n,0,5,1}];
ty=Table[{n,n,0.03`},{n,0,5,1}];
kuva14=Plot[{(Sqrt[(r^2)-(ξ^2)]),ξ Tan[ξ],-ξ Cot[ξ]},{ξ,0,r},PlotRange->{0,r},AspectRatio->Automatic,PlotStyle->{Hue[0],{Hue[0.66`],Dashing[{0.05`,0.05`}]},{Hue[0.78`],Dashing[{0.005`,0.03`,0.05`,0.03`}]}},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{ξ,η},Ticks->{tx,ty},DisplayFunction->Identity,BaseStyle->{FontSize->10}];

teksti={Graphics[Text["(R^2)=12",{4.2,0.5}]],Graphics[Text["η=ξtanξ",{0.9,2.5}]],Graphics[Text["η=-ξcotξ",{2.7,4.2}]],Graphics[Text["η=ξtanξ",{4.7,2.7}]]};

Show[{kuva14,teksti,Graphics[Circle[{0,0},(Sqrt[12]),{0,(π/2)}]],Table[Graphics[Circle[{0,0},r,{0,(π/2)}]],{r,1,2,1}]},DisplayFunction->$DisplayFunction,PlotRange->{{0,5.5`},{0,4.4`}},BaseStyle->{FontSize->16}]

Tässä sininen käyrä kuvaa symmetristä ja sinipunainen antisymmetristä ratkaisua. R on potentiaalista riippuva vakio. Kun potentiaalikuoppa on riittävän syvä, saadaan kolme sidottua tilaa (kaksi symmetristä ja yksi antisymmetrinen). Tiloja vastaavat energiat saadaan R:n ja η:n leikkauspisteistä annetulla R:n (eli potentiaalin) arvolla.

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva14.eps",%6,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Numeerinen ratkaisu symmetrisessä tapauksessa

Ratkaistaan seuraavaksi kuvaajien leikkauspiste numeerisesti symmetrisessä tapauksessa. Etsitään perustilan ratkaisua.

Clear[xi,x,i]
r=Sqrt[12];
arvaus=0.7;
FindRoot[xi*Tan[xi]==Sqrt[r^2-xi^2],{xi,arvaus}]
xi=xi/.%

Symmetrinen aaltofunktio

Piirretään alimman symmetrisen tilan aaltofunktio.

a=1;
alf=(xi/a);
bet=((Sqrt[(r^2)-(xi^2)])/a);
B=((E^(-bet a))/(Cos[alf a]));
wave[x_]:=(E^(bet x))/;x≤-a
wave[x_]:=B Cos[alf x]/;-a<x<a
wave[x_]:=(E^(-bet x))/;x≥a
normitus=NIntegrate[((wave[x])^2),{x,-∞,∞}]
tx=Table[{n,n,0.03`},{n,-4 a,4 a,1}];
ty=Table[{n,n,0.03`},{n,0,0.7`,0.2`}];
kuva1=Plot[((wave[x])/(Sqrt[normitus])),{x,-4 a,4 a},PlotStyle->{Hue[0]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,u},Ticks->{tx,ty},AxesOrigin->{0,0},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva15a.eps",%25,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Ratkaistaan toisen virittyneen tilan aaltofunktio.

Clear[xi,x,i]
r=Sqrt[12];
arvaus=2.3;
FindRoot[xi*Tan[xi]==Sqrt[r^2-xi^2],{xi,arvaus}]
xi=xi/.%

a=1;
alf=(xi/a);
bet=((Sqrt[(r^2)-(xi^2)])/a);
B=((E^(-bet a))/(Cos[alf a]));
wave[x_]:=(E^(bet x))/;x≤-a
wave[x_]:=B Cos[alf x]/;-a<x<a
wave[x_]:=(E^(-bet x))/;x≥a
normitus=NIntegrate[((wave[x])^2),{x,-∞,∞}]
tx=Table[{n,n,0.03`},{n,-4 a,4 a,1}];
ty=Table[{n,n,0.03`},{n,0,0.7`,0.2`}];
kuva2=Plot[((wave[x])/(Sqrt[normitus])),{x,-4 a,4 a},PlotStyle->{Hue[0.9`],Dashing[{0.05`,0.05`}]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,u},Ticks->{tx,ty},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva15b.eps",%44,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Numeerinen ratkaisu antisymmetrisessä tapauksessa

Ratkaistaan seuraavaksi kuvaajien leikkauspiste numeerisesti antisymmetrisessä tapauksessa.

r=Sqrt[12];
arvaus=1.9;
FindRoot[-xi*Cot[xi]==Sqrt[r^2-xi^2],{xi,arvaus}]
xi=xi/.%

Antisymmetrinen aaltofunktio

Piirretään ensimmäisen virittyneen tilan(antisymmetrinen) aaltofunktio.

a=1;
alf=(xi/a);
bet=((Sqrt[(r^2)-(xi^2)])/a);
A=-((E^(-bet a))/(Sin[alf a]));
wave[x_]:=(E^(bet x))/;x≤-a
wave[x_]:=A Sin[alf x]/;-a<x<a
wave[x_]:=-(E^(-bet x))/;x≥a
normitus=NIntegrate[((wave[x])^2),{x,-∞,∞}]
tx=Table[{n,n,0.03`},{n,-2,2,1}];
ty=Table[{n,n,0.03`},{n,-1,1,0.5`}];
kuva3=Plot[((wave[x])/(Sqrt[normitus])),{x,-3 a,3 a},PlotStyle->{Hue[0.65`],Dashing[{0.005`,0.03`,0.07`,0.03`}]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,u},Ticks->{tx,ty},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva15c.eps",%62,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Show[{kuva3,kuva2,kuva1}(*,PlotLabel->StyleForm["Alimpien tilojen aaltofunktiot",FontSize->11]*)]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva15d.eps",%66,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Show[{kuva1,kuva2,kuva3,{Graphics[{Thickness[0.01`],Line[{{-1,0},{1,0}}],Line[{{1,0},{1,3}}],Line[{{-1,0},{-1,3}}],Line[{{-1,3},{-3,3}}],Line[{{1,3},{3,3}}]}],tekstisymm}},AxesLabel->{x,V},Axes->True,Ticks->False,Background->RGBColor[0.6`,0.8`,0.8`],PlotRange->{{-3,3},{-1,3}},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva15e.eps",%70,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Tunneloituminen

Integrate[2 E^(-2*bet*x)/normitus,{x,a,Infinity}]

m={{-f,1/g,g,0},{h*f,I*k/g,-I*k*g,0},{0,g,1/g,-f},{0,I*k*g,-I*k/g,-h*f}}
Det[m]//Factor

Sironta symmetrisestä kuopasta

Luentomoniste s. 37 - 42

a=1;
tekstisymm={Graphics[Text["V = \!\(\*SubscriptBox[\(V\), \(0\)]\)",{2.2`,1.5`}]],Graphics[Text["V = 0",{0,1.5`}]],Graphics[Text["V = \!\(\*SubscriptBox[\(V\), \(0\)]\)",{-2.2`,1.5`}]],Graphics[Text["-a",{-a,-0.2`}]],Graphics[Text["a",{a,-0.2`}]],Graphics[Text["E > \!\(\*SubscriptBox[\(V\), \(0\)]\)",{1,3.7`}]],Graphics[Text["I",{-2.2`,0.5`}]],Graphics[Text["III",{2.2`,0.5`}]],Graphics[Text["II",{0,2.5`}]]};
Show[{Graphics[{Thickness[0.01`],Line[{{-a,0},{a,0}}],Line[{{a,0},{a,3}}],Line[{{-a,0},{-a,3}}],Line[{{-a,3},{-a-2,3}}],Line[{{a,3},{a+2,3}}]}],Graphics[Line[{{-1.5`,3.5`},{1.5`,3.5`}}]],Graphics[Circle[{-0.8`,3.5`},0.1`]],Graphics[Arrow[{-1,3.8`},{-0.6`,3.8`},HeadScaling->Relative]],tekstisymm},AxesLabel->{x,V},Axes->True,Ticks->False,Background->RGBColor[0.6`,0.8`,0.8`],PlotRange->{{-3 a,3 a},{-1,4}},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva16.eps",%77,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Määrittämällä aaltofunktion kertoimet saadaan laskettua heijastumiskerroin R ja läpäisykerroin T.

Ratkaistaan kertoimet A, B, C ja D

Ratkaistaan neljän yhtälön yhtälöryhmä, jossa on neljä tuntematonta (A, B, C ja D) käyttäen matriiseja.

Tässä f = (e^ika), g = (e^(iκa)), h = κ

m={{1/f,f,-1/g,-g},{k/f,-k f,-h/g,h g},{0,0,g,1/g},{0,0,h g,-h/g}};
b={0,0,f,k f};
MatrixForm[m]
MatrixForm[b]
kertoimet=LinearSolve[m,b]//Simplify

Ratkaistaan kertoimet  R ja T

Heijastus- ja läpäisykertoimet ovat oskilloivia funktioita. 
R = (((sin^2)(2κa))/(4γ(γ-1)+(sin^2)(2κa))), 	T = ((4γ(γ-1))/(4γ(γ-1)+(sin^2)(2κa)))
Helposti nähdään, että R + T = 1.
Piirretään heijastus- ja läpäisykertoimet γ:n funktiona (γ = (E/(Subscript[V, 0])))

Clear[a,k,h]
R:=(((Sin[2 h a])^2)/(4 e (e-1)+((Sin[2 h a])^2)))
T:=((4 e (e-1))/(4 e (e-1)+((Sin[2 h a])^2)))
v0=2;
a=3;
h=(Sqrt[e v0]);
tx=Table[{n,n,0.03`},{n,1,4,1}];
ty=Table[{n,n,0.03`},{n,0,1,0.2`}];
kuva=Plot[{R,T},{e,1.`,4},PlotRange->All,PlotStyle->{Hue[0],Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{γ,P},Ticks->{tx,ty},DisplayFunction->Identity,BaseStyle->{FontSize->16}];

teksti={Graphics[Text["T",{2,0.9}]],Graphics[Text["R",{2,0.1}]]};

Show[{kuva,teksti},DisplayFunction->$DisplayFunction]

Kuvassa punainen kuvaa heijastuskerrointa ja sininen läpäisykerrointa.

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuva18.eps",%731,"EPS"];

SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Sironnan aaltofunktion reaaliosa symmetrisessä potentiaalikuopassa.

Clear[k,a,h,Ah,Bh,Ch,Dh,u,x]
Ah[k_,h_,a_]:=-1/(4k h)*E^(2I(k-h)a)*(-(k+h)^2+(k-h)^2*E^(4I h a))
Bh[k_,h_,a_]:=I/(2 k h)*Sin[2 h a](h^2-k^2)
Ch[k_,h_,a_]:=1/(2h)*E^(I(k-h)a)(h+k)
Dh[k_,h_,a_]:=1/(2h)*E^(I(k+h)a)(h-k)
a=10
ene=1
h=Sqrt[ene]
v0=ene-0.1
k=h*Sqrt[1-v0/ene]
u[x_]:=Ah[k,h,a]*E^(I k x)+Bh[k,h,a]E^(-I k x)/;x≤-a
u[x_]:=Ch[k,h,a]*E^(I h x)+Dh[k,h,a]E^(-I h x)/;-a<x<a
u[x_]:=E^(I k x)/;x≥a
Plot[Re[u[x]],{x,-5a,5a}]

kuva=Plot[Re[u[x]],{x,-5 a,5 a},PlotStyle->Hue[0.69`],DisplayFunction->Identity,BaseStyle->{FontSize->10}];

Show[{kuva,Graphics[{Thickness[0.01`],Line[{{-a,0},{a,0}}],Line[{{a,0},{a,3}}],Line[{{-a,0},{-a,3}}],Line[{{-a,3},{-a-4 a,3}}],Line[{{a,3},{a+4 a,3}}]}]},AxesLabel->{x,u},Axes->True,Ticks->False,Background->RGBColor[0.6`,0.8`,0.8`],PlotRange->{{-5 a,5 a},{-4,3}},DisplayFunction->$DisplayFunction,BaseStyle->{FontSize->16}]

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuva17.eps",%618,"EPS"];

SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Sironta potentiaalivallista

Varsinaisesti vasta Kvanttimekaniikka II - kurssilla

a=1;
tekstivall={Graphics[Text["V = 0",{1.5`,1.5`}]],Graphics[Text["V = \!\(\*SubscriptBox[\(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}},BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuvavalli.eps",%116,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

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,BaseStyle->{FontSize->10}];

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

Show[{kuva1,teksti},DisplayFunction->$DisplayFunction,BaseStyle->{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.

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva19.eps",%131,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Tarkastellaan seuraavaksi heijastus- ja läpäisykertoimia, kun a=4 ja V0=1.
Piirretään ensin kertoimet hiukkasen energian funktiona, kun hiukkasen energia≥V0.

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,BaseStyle->{FontSize->10}];

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

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

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva20a.eps",%142,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Piirretään seuraavaksi kertoimet, kun hiukkasen energia ≤ V0.

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,BaseStyle->{FontSize->10}];

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

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

Show[{kuva3,kuva2,teksti},DisplayFunction->$DisplayFunction,BaseStyle->{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.

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva20b.eps",%157,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva20c.eps",%158,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

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)*4u/alf[k,a,u]
Ch[k_,u_,a_]:=2I Sin[k a](1-u^2)/alf[k,a,u]
alf[k_,a_,u_]:=2I(1+u^2)Sin[k a]-4u 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,BaseStyle->{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,BaseStyle->{FontSize->16}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuvaz.eps",%176,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Diracin Delta-funktio

Havainnollistetaan Diracin delta-funktion "piikkimäisyyttä". Kasvattamalla L:n arvoa havaitaan, että funktion kuvaaja "piikittyy"

L=10;
tx=Table[{n,n,0.03`},{n,-30,30,10}];
ty=Table[{n,n,0.03`},{n,-2,100,2}];
Plot[((Sin[L x])/x),{x,-3 L,3 L},PlotRange->All,PlotStyle->{Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,δ},Ticks->{tx,ty},BaseStyle->{FontSize->10}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuvaDirac.eps",%183,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Ortogonaalipolynomeja

Hermiten polynomit

Diffenrantiaaliyhtälön (Subscript[H, n])''-2ξ(Subscript[H, n])'+2n(Subscript[H, n]) = 0 ratkaisut ovat Hermiten polynomeja. Ratkaistaan ensin ko. DY.

Clear[h,hn,u]
n=2;
rat=DSolve[h''[x]-2 x *h'[x] + 2 n*h[x] ==0,h[x],x]

Asetetaan ratkaisussa kertoimet C[1]=1 ja C[2]=0. Piirretään harmoonisen oskillaattorin aaltofunktion kuvaaja u(ξ) = (Subscript[H, n])(ξ)(e^(-(1/2)(ξ^2))).

hn=h[x]/.rat/.{C[1]->4,C[2]->0};
tx=Table[{n,n,0.03`},{n,-6,6,3}];
ty=Table[{n,n,0.03`},{n,-1,1,0.5`}];
Plot[((hn (E^(-((x^2)/2))))/(Sqrt[(2^n) n! (Sqrt[π])])),{x,-6,6},PlotRange->All,PlotStyle->{Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,u},Ticks->{tx,ty},BaseStyle->{FontSize->20}]

SetDirectory[SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"]];
Export["kuvaHerm3.eps",%%,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Piirretään seuraavaksi harmoonisen oskillaattorin kvanttimekaaninen todennäköisyysjakauma n:n arvolla 2.

Clear[n,x]
HermiteH[20,x]

n=55;
tx=Table[{n,n,0.03`},{n,-10,10,5}];
ty=Table[{n,n,0.03`},{n,0,0.4`,0.1`}];
prop=Plot[{(1/(π (Sqrt[2 n-(x^2)]))),(((((HermiteH[n,x])/(Sqrt[(2^n) n! (Sqrt[π])]))))^2) (E^(-(x^2)))},{x,-(Sqrt[2 n-1]),(Sqrt[2 n-1])},PlotRange->All,PlotStyle->{Hue[0.88`],Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{x,(Subscript[P, n])},Ticks->{tx,ty},BaseStyle->{FontSize->20}]

SetDirectory[SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"]];
Export["kuva23.eps",%%,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Yksidimensioinen harmooninen oskillaattori

Clear[a]
n=2;
rat=DSolve[u''[x]+(n+1/2-x^2-a)u[x] ==0,u[x],x]

Legendren polynomit

Differentiaaliyhtälön (1-(z^2))(Subscript[P, l])''(z)-2z(Subscript[P, l])'(z)+l(l+1)(Subscript[P, l])(z) = 0 ratkaisut ovat Legendren polynomeja.
Ratkaistaan ensin yo. differentiaaliyhtälö.

Clear[P,l,Pl]
rat=DSolve[(1-z^2)*P''[z]-2 z *P'[z]+l(l+1)*P[z]==0,P[z],z]

Sijoitetaan sitten arvot l=10, C[1]=1 ja C[2]=0 ja piirretään polynomin kuvaaja.

l=10;
Pl:=P[z]/.rat/.{C[1]->1,C[2]->0}
tx=Table[{n,n,0.03`},{n,-1,1,0.5`}];
ty=Table[{n,n,0.03`},{n,-0.5`,1,0.5`}];
Plot[Pl,{z,-1,1},PlotStyle->{Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{z,(Subscript[P, l])},Ticks->{tx,ty},BaseStyle->{FontSize->20}]

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuvaLeg1.eps",%%,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Verrataan saatua kuvaajaa Mathematican kirjastosta löytyvän Legendren funktion kuvaajaan.

tx=Table[{n,n,0.03`},{n,-1,1,0.5`}];
ty=Table[{n,n,0.03`},{n,-0.5`,1,0.5`}];
Plot[Abs[LegendreP[10,0,z]],{z,-1,1},PlotStyle->{Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{z,(Subscript[P, l])},Ticks->{tx,ty},BaseStyle->{FontSize->20}]

Havaitaan, että kuvaajat ovat yhtenevät.

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuvaLeg2.eps",%219,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Pallofunktiot

Pallofunktiot määritellään assosioitujen Legendren polynomien avulla. Piirretään pallofunktion normi arvoilla l=4 ja m=1, t saa arvot 0->π.

Clear[x]
l=4;
m=1;
tx=Table[{n,n,0.03`},{n,0,3,1.`}];
ty=Table[{n,n,0.03`},{n,0,0.6`,0.3`}];
sy[t_,p_]=SphericalHarmonicY[l,m,t,p];
Plot[Abs[sy[t,0]],{t,0,π},PlotStyle->{Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],AxesLabel->{z,"\[VerticalSeparator]\!\(\*SuperscriptBox[SubscriptBox[\(Y\), \(1\)], \(4\)]\)\[VerticalSeparator]"},Ticks->{tx,ty},BaseStyle->{FontSize->20}]

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuvapallo.eps",%%,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\6.0"];

Piirretään pallofunktion normi myös 3-ulotteisesti, kun t saa arvot 0->π ja p 0->2π.

p=.
SphericalPlot3D[Evaluate[Abs[SphericalHarmonicY[l,m,t,p]]],{t,0,π},{p,0,2 π},ViewPoint->{1.3`,1.4`,1},PlotPoints->50,Lighting->Automatic,Background->RGBColor[0.6`,0.8`,0.8`]]

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuva27.eps",%%,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

l=4
m=1
r=Abs[SphericalHarmonicY[l,m,t,0]]
zc=r Cos[t];
xc=r Sin[t];
tx=Table[{n,n,0.03`},{n,-0.3`,0.3`,0.3`}];
ty=Table[{n,n,0.03`},{n,-0.2`,0.2`,0.2`}];
ParametricPlot[{xc,zc},{t,0,2 π},AspectRatio->Automatic,PlotStyle->{Hue[0.65`]},Background->RGBColor[0.6`,0.8`,0.8`],Frame->False,FrameLabel->{x,z},RotateLabel->False,Ticks->{tx,ty},AxesLabel->{x,z},BaseStyle->{FontSize->15}]

SetDirectory["D:\\Mikko\\opetus\\kvmI_uusi"];
Export["kuva28.eps",%%,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

<<VectorAnalysis`

Clear[r]
r2xRule=Thread[{r,thet,phi}->CoordinatesFromCartesian[{x,y,z},Spherical]];
n=3;
l=2;
m=0;
k=n-l-1;
a=2*l+1;
Rhydro=r^l*LaguerreL[k,a,2*r/n]*Sqrt[k!/(2*n*Gamma[n+l+1])*(2/n)^(2*l+3)]*E^(-r/n);
psi=Rhydro*SphericalHarmonicY[l,m,thet,0];

Piirretään seuraavaksi vetyatomin todennäköisyystiheys etäisyydellä x atomin ytimestä.

dim=20;
ContourPlot[Evaluate[((Abs[psi])^2)]/.r2xRule/.{y->0},{x,-dim,dim},{z,-dim,dim},PlotPoints->20,AspectRatio->Automatic,ContourStyle->None,Background->RGBColor[0.6`,0.8`,0.8`],Frame->True,FrameLabel->{x,z},RotateLabel->True,BaseStyle->{FontSize->15}]

Aaltopaketti

Havainnollistetaan vapaan aaltopaketin leviämistä animaation avulla. Aaltopakettina on käytetty Gaussin aaltopakettia.

Clear[G,x,t,a,hbar,m,k0]
G[x_,t_]:=Sqrt[(2/(π a^2))]*(1/(Sqrt[1+((4hbar^2t^2)/(m^2a^4))]))*Exp[-((2a^2(x-((hbar k0)/m)t)^2)/(a^4+((4hbar^2t^2)/(m^2))))]

a=1;hbar=1;k0=2;m=1;

Animate[Plot[G[x,t],{x,- t-10, t+10},Axes->False,PlotRange->{{-2,10},{0,1}},Background->RGBColor[0.6,0.8,0.8]],{t,0,2.5,0.01}]

Interferenssi

Yksöisrakokoe

Clear[b,θ]

Show[Graphics[{Line[{{-1,3},{-1,1}}],Line[{{-1,-1},{-1,-3}}],Line[{{-1.25`,0},{3,0}}],Line[{{2,4},{2,-4}}],Line[{{-1,0},{2,2}}],Line[{{2.2`,2},{2.4`,2}}],Arrow[{2.3`,0},{2.3`,2},HeadScaling->Relative],Text[x,{2.5`,1}],Text[(Subscript[r, 0]),{0.5`,1.5`}],Arrow[{0.3`,-2},{-1,-2},HeadScaling->Relative],Arrow[{0.7`,-2},{2,-2},HeadScaling->Relative],Text[L,{0.5`,-2}],Line[{{-1.4`,1},{-1.6`,1}}],Line[{{-1.4`,-1},{-1.6`,-1}}],Arrow[{-1.5`,0.5`},{-1.5`,1},HeadScaling->Relative],Arrow[{-1.5`,-0.5`},{-1.5`,-1},HeadScaling->Relative],Text[b,{-1.5`,0}],Circle[{-1,0},0.7`,{0,(π/6)}],Text[Θ,{0.15`,0.3`}],Arrow[{-3,2},{-2,2},HeadScaling->Relative],Arrow[{-3,1},{-2,1},HeadScaling->Relative],Arrow[{-3,0},{-2,0},HeadScaling->Relative],Arrow[{-3,-1},{-2,-1},HeadScaling->Relative],Arrow[{-3,-2},{-2,-2},HeadScaling->Relative]}],BaseStyle->{FontSize->17},Background->RGBColor[0.6`,0.8`,0.8`]]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva34.eps",%90,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Clear[i,beta,x,k,El,eps0,c,b,L,i0]

Kaksoisrakokoe

Clear[L,x,b,a,θ]
Show[Graphics[{Line[{{-1,0.6`},{-1,-0.6`}}],Line[{{-1,1.4`},{-1,3}}],Line[{{-1,-1.4`},{-1,-3}}],Line[{{-1.25`,0},{3,0}}],Line[{{2,4},{2,-4}}],Line[{{-1,0},{2,2}}],Line[{{2.2`,2},{2.4`,2}}],Line[{{-1,1},{2,2}}],Line[{{-1,-1},{2,2}}],Arrow[{2.3`,0},{2.3`,2},HeadScaling->Relative],Text[x,{2.5`,1}],Text[(Subscript[r, 0]),{0.5`,1.5`}],Arrow[{0.3`,-2},{-1,-2},HeadScaling->Relative],Arrow[{0.7`,-2},{2,-2},HeadScaling->Relative],Text[L,{0.5`,-2}],Line[{{-1.4`,1},{-1.6`,1}}],Line[{{-1.4`,-1},{-1.6`,-1}}],Arrow[{-1.5`,0.5`},{-1.5`,1},HeadScaling->Relative],Arrow[{-1.5`,-0.5`},{-1.5`,-1},HeadScaling->Relative],Text[a,{-1.5`,0}],Text[b,{-1,1}],Text[b,{-1,-1}],Circle[{-1,0},0.7`,{0,(π/6)}],Text[Θ,{0,0.28`}],Arrow[{-3,2},{-2,2},HeadScaling->Relative],Arrow[{-3,1},{-2,1},HeadScaling->Relative],Arrow[{-3,0},{-2,0},HeadScaling->Relative],Arrow[{-3,-1},{-2,-1},HeadScaling->Relative],Arrow[{-3,-2},{-2,-2},HeadScaling->Relative]}],BaseStyle->{FontSize->17},Background->RGBColor[0.6`,0.8`,0.8`]]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva36.eps",%107,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Clear[i,beta,x,k,El,eps0,c,b,L,i0,a]

b=10^-6;
a=2b;
L=500;
k=10^9;
c=3*10^8;
eps0=8.854*10^-12;
El=0.001;
i[x_]:=8 eps0 c El^2/(k^2x^2)*Sin[0.5 k b x/L]^2*Cos[0.5 k a x/L]^2
Plot[i[x],{x,-2,2},Background->RGBColor[0.6,0.8,0.8],Ticks->False]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva37.eps",%120,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Sironta potentiaaliportaasta

Havainnollistetaan Gaussin aaltopaketin siroamista potentiaaliportaasta animaation avulla.

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/2m)]

K0=18;k0=22;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))

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

Quantum rattle

Tutkitaan yksinkertaisen aaltopaketin aikakehitystä, kun oletetaan, että se on äärettömässä potentiaalikuopassa ja että sen tilaa kuvaa perustilan ja ensimmäisen viritetyn tilan lineaarinen superpositio.

Clear[norm,L,a,m,n]
schroedingerD[V_][psi_]:=hamiltonian[V][psi]-Energy psi
phi[n_,x_]:=norm[n] Sin[((n π x)/L)]
hamiltonian[V_][psi_]:=-(((h^2) (∂_({x,2}))psi)/(2 m))+V psi
ExpandAll[((schroedingerD[0][phi[n,x]])/(phi[n,x]))==0]

e[n_]=Energy/.Solve[%,Energy][[1]]
(((h^2) (n^2) (π^2))/(2 (L^2)))
norm[n_]=norm[n]/.Solve[(∫_0^L)((phi[n,x])^2)\[DifferentialD]x==1/.Sin[m_Integer n π]->0,norm[n]][[2]]

a[n_]:=(1/(Sqrt[2]))
a[n_,t_]:=a[n] (E^(-((I e[n] t)/h)))
psi[x_,t_]=(∑_(n=1)^2)a[n,t] phi[n,x]

ExpandAll[I h (∂_t)psi[x,t]==hamiltonian[0][psi[x,t]]]

psi[0,t]==psi[L,t]==0

psisq[x_,t_]=Conjugate[psi[x,t]] psi[x,t]//Expand//ComplexExpand

psi==(∑_(n=nmin)^nmax)a[n,t] phi[n,x]

(∫_0^L)psisq[x,t]\[DifferentialD]x

(∑_(n=1)^2)Conjugate[a[n,t]] a[n,t]

Expand[(∫_0^(L/2))psisq[x,t]\[DifferentialD]x]

(∫_0^L)Conjugate[psi[x,t]] hamiltonian[0][psi[x,t]]\[DifferentialD]x==(∑_(n=1)^2)Conjugate[a[n,t]] a[n,t] e[n]==(1/2) (e[1]+e[2])

(∑_(n=1)^2)Conjugate[a[n,t]] a[n,t] e[n]==(∑_(n=1)^2)((a[n])^2) e[n]

Piirretään perustilan todennäköisyystiheys.

tx=Table[{n,n,0.03`},{n,0,1,0.2`}];
ty=Table[{n,n,0.03`},{n,0,2,0.5`}];
Plot[((Abs[phi[1,x]])^2)/.L->1,{x,0,1},PlotStyle->Hue[0.69`],AxesLabel->{" x",""},Background->RGBColor[0.6`,0.8`,0.8`],Epilog->Line[{{1,0},{1,4}}],BaseStyle->{FontSize->16},Ticks->{tx,ty}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva38.eps",%16,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Piirretään ensimmäisen viritetyn tilan todennäköisyystiheys.

tx=Table[{n,n,0.03`},{n,0,1,0.2`}];
ty=Table[{n,n,0.03`},{n,0,2,0.5`}];
Plot[((Abs[phi[2,x]])^2)/.L->1,{x,0,1},PlotStyle->Hue[0.69`],AxesLabel->{" x",""},Background->RGBColor[0.6`,0.8`,0.8`],Epilog->Line[{{1,0},{1,4}}],BaseStyle->{FontSize->16},Ticks->{tx,ty}]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva39.eps",%22,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Piirretään näiden kahden tilan superpositiotilan aikakehitys.

psisqPlot[t_]:=Plot[Evaluate[N[psisq[x,t]/.{h->1,L->1,m->1}]],{x,0,1},PlotRange->{0,4},AxesLabel->{" x",""},Background->RGBColor[0.6`,0.8`,0.8`],Ticks->{{{0,0},{0.5`,0.5`},{1,1}},{{0,0},{2,2},{4,4}}},Epilog->{Text["t = "<>ToString[t],{0.5`,3.7`},{-1,0}],{Line[{{1,0},{1,4}}]}},DisplayFunction->Identity];
Show[GraphicsGrid[Table[{psisqPlot[t],psisqPlot[t+0.04`]},{t,0,0.2`,0.08`}]],Spacings->{Scaled[0.`],Scaled[0.2`]},DisplayFunction->$DisplayFunction]

SetDirectory["C:/Documents and Settings/tuorilaj/My Documents/kvmi"];
Export["kuva40.eps",%27,"EPS"];
SetDirectory["C:\\Program Files\\Wolfram Research\\Mathematica\\4.1"];

Havainnollistetaan sama animaatiolla.

Animate[psisqPlot[t],{t,0,1.23,0.01}]