6. Quantum Mechanics

Legal Notice, Disclaimer, and Book Ordering Information:

Null

Setup

\(Clear["Global`*"]; 
Off[General::spell]; 
Off[General::spell1]; 
    \)

Needs["Calculus`VectorAnalysis`"]

Needs["Graphics`PlotField3D`"]

<< "D:\Mma\Inits\ch6init.m"

Clear["Global`*"];

6.2 Problems

6.2.1  One Dimensional Schrödinger Equation

Problem 4:  Particle propagating towards a rectangular potential.

Consider a particle of energy E>0 propagates from the left (x < -a) toward a rectangular well or barrier described by V[x] = V0 if -a< x<+a and V[x] = 0 otherwise.  If V0>0, the potential describes a barrier; if V0<0, the potential describes a well.  The wave to the left (x < -a) of the potnetial has incoming and reflected components. Set the amplitude of the incoming wave to 1 and let R be the amplitude of the reflected wave.   The wave to the right (x  > a) of the potnetial has only a transmitted component; let its amplitude be T.  The wave in the potential has two components; call them A and B.

Part (a)  Write the general form of the wave function to the left, to the right, and in the center of the well.

ψL[x_] = waveExp[x,k1,1,R]

ψR[x_] = waveExp[x,k1,T,0]

ψW[x_] = waveExp[x,k2,A,B]

kRule = {k1 -> Sqrt[2 m (En    )]/ℏ
		,k2 -> Sqrt[2 m (En - V)]/ℏ
		}//PowerExpand

Part (b)  Use the  boundary conditions to evaluate the wave amplitudes.

eq1 = {(ψL[ x] - ψW[ x] == 0)/.{x -> -a}
	  ,(ψW[ x] - ψR[ x] == 0)/.{x -> +a}
	  ,(ψL'[x] - ψW'[x] == 0)/.{x -> -a}
	  ,(ψW'[x] - ψR'[x] == 0)/.{x -> +a}}

ABRTrule = Solve[eq1,{A,B,R,T}]//Flatten//Map[Together,#,{2}]&//ExpToTrig//Simplify

Part (c)    The coefficients of transmission T and reflection R are defined as thethe ratios of transmitted and reflected currents  to the incident current.  Find the transmission and reflection coefficients.  Verify that T + R = 1 .

SetCoordinates[Cartesian[x,y,z]]

incFlux = flux[ψL[x][[1]] ]

refFlux = flux[ψL[x][[2]] ]

tnsFlux = flux[ψR[x]]

RR = refFlux[[1]]/incFlux[[1]]//Abs

TT  =  tnsFlux[[1]]/incFlux[[1]] // Abs

\({TT, RR} = 
      \({T\ Conjugate[T], R\ Conjugate[R]}
		 /. ABRTrule\)

          		 /. {Conjugate -> conjugate}
	 // Simplify\)

TT + RR == 1 // Simplify

Part (d)  Plot R and T as a function of En for the case of a potential well (V0<0) and for a potential barrier (V0>0).

values={ℏ->1,m->1,a->1};

Clear[plotOperator]

plotOperator[Potential_, EnRange_] :=
Plot[
	Evaluate[{RR,TT}/.kRule/.V->Potential/.values]
	,EnRange
	,AxesLabel->{FontForm["En"  ,{"Courier-Bold",10}]
				,FontForm["RR, TT",{"Courier-Bold",10}]}
	,PlotStyle->{Dashing[{0.1,0.0}],Dashing[{0.02,0.02}]}];

plotOperator[-40, {En, 1, 40}];

plotOperator[1, {En, 0.01, 0.99}];

Part (e)  Use Plot3D to plot the reflection and transmission curves as a function of the energy En and potential Vo.

pt1 =Plot3D[
		Evaluate[#/.kRule/.ABRTrule/.values]
		,{En,0.01,10}
		,{V,-20,-0.1}
		,AxesLabel->{"Energy","V","RR, TT"}
		,DisplayFunction->Identity
		]& /@ {TT,RR};

Show[GraphicsArray[pt1]];

Part (f)  Plot the real part of the wave for the complete range of x.

\(\(plotOp[wave_, Energy_, V0_, gap_, xrange_]\  := 
			
      Plot[Re[\(\(wave /. ABRTrule\)

                			\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \  /. kRule\)

              					\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \  //. {
                m -> 1, ℏ -> 1, En -> Energy, a -> 2, V -> V0}\ ]

          			\ \ \ \ \ \ \ \ \ \ \ \ \ \ \  // Evaluate
		, xrange

        		, PlotStyle -> {Dashing[{0.03, gap}]}
		, 
        AxesOrigin -> {0, 0}
		, DisplayFunction -> Identity
	]; \)\)

wavePlot1[En_,V0_,xmin_,xmax_]:=
	Show[{plotOp[ψL[x],En,V0,0.0,{x,xmin,-2}]
		 ,plotOp[ψR[x],En,V0,0.04,{x,2,xmax}]
		 ,plotOp[ψW[x],En,V0,0.02,{x,-2,2}]
		 ,Graphics[
		 	{Line[{{-2,Sign[V0]},{+2,Sign[V0]}}]
		 	,Line[{{-2,Sign[V0]},{-2,0}}]
		 	,Line[{{+2,Sign[V0]},{+2,0}}] }]
		 }
	,DisplayFunction->$DisplayFunction];

wavePlot1[1, -12, -12, 12];

Part (g)  Animate the time dependence of the real part of the wave as it propagates through a barrier (V0>0 and 0<En<V0).

Clear[timePlot]

timePlot[time_,wave_,Energy_,V0_,gap_,xrange_] :=
	Plot[Evaluate[Re[Exp[-I Energy time]*wave
		/.ABRTrule/.kRule
		/.{m->1,ℏ->1,En->Energy,a->2,V->V0} ] ]
		,xrange
		,Axes->None
		,PlotStyle->{Dashing[{0.05,gap}]}
		,DisplayFunction->Identity];

tnumber=16;
timestep=2 π/tnumber;
V0=1.1;
Energy=1;
Do[Show[{timePlot[time,ψL[x],Energy,V0,0,{x,-10,-2}]
		,timePlot[time,ψW[x],Energy,V0,0.05,{x,-2,2}]
		,timePlot[time,ψR[x],Energy,V0,0.02,{x, 2,10}]}
	,DisplayFunction->$DisplayFunction]
	,{time,0,2 π - timestep,timestep}]

tnumber=12;
timestep=2 π/tnumber;
V0=1.2;
Energy=1;
Do[Show[{timePlot[time,ψL[x],Energy,V0,0,{x,-10,-2}]
		,timePlot[time,ψW[x],Energy,V0,0.05,{x,-2,2}]
		,timePlot[time,ψR[x],Energy,V0,0.02,{x, 2,10}]}
	,DisplayFunction->$DisplayFunction]
	,{time,0,2 π - timestep,timestep}]