Legal Notice, Disclaimer, and Book Ordering Information:

(* Legal Notice, Disclaimer, and Book Ordering Information:

Last Modified: FIO January 1, 1995

Mathematica For Physics
Robert L. Zimmerman and Fredrick I. Olness
MathSource Number: 0206-862 

ISBN 0-201-53796-6
For ordering information, call 1-800-822-6339
Addison-Wesley Publishing Company

Communication with the authors:
Fredrick I. Olness:  olness@mail.physics.smu.edu
Robert L. Zimmerman: bob@zim.uoregon.edu

Copyright 1995, Addison-Wesley Publishing Company, Inc. The material in
this file may be distributed freely  so long as the content remains
unchanged, and the copyright and  reference notices are included. The
publisher grants permission for the noncommercial use of these programs
and program segments.  All other uses require the prior written consent
of the publisher.    

All rights are reserved with regard to the  material in the
"Mathematica For Physics" text, and may not be reproduced, stored in a
retrieval system, or transmitted,  in any form or by any means,
electronic, mechanical, photocopying,  recording, or otherwise, without
the prior written permission  of the publisher. 

The programs and applications presented in this book have been included
for  their instructional value. They have been tested with care but are
not  guaranteed for any particular purpose. The publisher does not
offer any  warranties or representations, nor does it accept any
liabilities with  respect to the programs or applications. 

 *)

Chapter 6, Section 1, Problem 2: 
Particle bound in a Finite Potential Well   
(Modified 9/25/95. Original was scrambled. Book is correct)

<<mainDir:subDir:ch6init.m  (* Mac  Version *)

<<mainDir/subDir/ch6init.m  (* Unix Version *)

Solution

Clear["Global`*"];

psiW[x_]=  waveTrig[x,ki,A,B]

kRule= {k -> Sqrt[2 m(En - V)]/hbar} //PowerExpand;

kiRule= {ki -> k} /.kRule //.{V->-V0, En->-Wn}

waveExp[x,k,c1,c2]

psiL[x_]= waveExp[x,I k0,0,C]     (* x < -a *)

psiR[x_]= waveExp[x,I k0,D,0]     (* x > a *)

k0Rule = ( {k0->-I k} //. kRule
                      //.{V->0, En->-Wn}
                      //PowerExpand  
          )

eq2= {  (psiL[ x]-psiW[ x]==0)  /. {x->-a}, 
        (psiW[ x]-psiR[ x]==0)  /. {x->+a},
        (psiL'[x]-psiW'[x]==0)  /. {x->-a},
        (psiW'[x]-psiR'[x]==0)  /. {x->+a}  };

eq3= Reduce[eq2,A];
Short[eq3,4]

eq4= Reduce[{eq2, A==0, C !=0, k0 !=0}//Flatten ,B]

symSol= Solve[eq4,{A,B,C}][[1]]

symRel= 
  Select[eq4,((!FreeQ[#,Cos[a ki]])&&(!FreeQ[#,k0]))& ]

symEn= Thread[symRel/(ki Cos[a ki]),Equal]

eq5= Reduce[{eq2, B==0, C !=0, k0 !=0}//Flatten,A]

asymSol= Solve[eq5 ,{A,B,C}]

asymRel= Select[eq5,((!FreeQ[#,Cos[a ki]])&&(!FreeQ[#,k0]))& ]

asymEn=  Thread[asymRel/(ki Sin[a ki]),Equal]

kRule2  =  {kiRule ,k0Rule} //Flatten

nRule= Wn-> V0- n^2 hbar^2 Pi^2/(8 a^2 m) ;

eq6 =symEn/.kRule2/.nRule//PowerExpand

values={a->1, m->1, hbar->1, V0->{100,200,500, Infinity} };

plot1= 
Plot[ {ArcTan[eq6[[1]]],ArcTan[eq6[[2]]]}
           /.values 
           //Flatten 
           //Evaluate
       ,{n,0.01,9}
       ,Frame->True
       ,FrameTicks->{  {{1,"n=1"},{3,"n=3"},{5,"n=5"}
                                 ,{7,"n=7"},{9,"n=9"}}
                      ,{0,0.5,1,1.5}  }
       ,PlotRange->{0,2}
       ,DisplayFunction->Identity
    ];

text ={
 Text[FontForm["V0=Inf",{"Courier-Bold",10}],{2,1.7  }],
 Text[FontForm["V0=500",{"Courier-Bold",10}],{5.7,1.4}],
 Text[FontForm["V0=200",{"Courier-Bold",10}],{7.6,1  }],
 Text[FontForm["V0=100",{"Courier-Bold",10}],{7.7,0.7}]};

Show[{plot1,Graphics[text]}, DisplayFunction->$DisplayFunction];

eq7 =asymEn /.kRule2 /.nRule //PowerExpand

Plot[ {ArcTan[eq7[[1]]],ArcTan[eq7[[2]]]}
         /.values 
         //Flatten
         //Evaluate
      ,{n,0.01,9}
      ,Frame->True
      ,FrameTicks->{ {{2,"n=2"},{4,"n=4"}
                     ,{6,"n=6"},{8,"n=8"}}
                    ,{0,.5,1,1.5}  }
      ,PlotRange->{0,2 }
      ,Epilog->Graphics[text][[1]] 
  ];

nValues[eq_, potential_, guess_]:= 
( n /.FindRoot[eq /.{m->1,a->1,hbar->1,V0->potential }
                  //Evaluate
              ,{n,guess}][[1]]  )

symGuess= {0.97,2.9,4.8,6.8,8.7 };

symValues= {nValues[eq6,100,#]
           ,nValues[eq6,200,#]
           ,nValues[eq6,500,#]}& /@ symGuess;

asymGuess=    {1.97,3.9,5.8,7.8  };

asymValues={nValues[eq7,100,#]
           ,nValues[eq7,200,#]
           ,nValues[eq7,500,#]}& /@ asymGuess;

( Partition[ Sort[{symValues,asymValues} //Flatten 
                                         //N[#,3]&  ]
           ,3]
    //TableForm[# ,TableSpacing -> {0,8}
                  ,TableHeadings-> {
                      {"n=1","n=2","n=3","n=4","n=5"
                            ,"n=6","n=7","n=8","n=9"}
                      ,{"V0=100","V0=200","V0=500"}  }   
                ]&
 )

symRules= {kRule2,nRule,symSol,
           {a->1,hbar->1,m->1,V0->100,D->100}}//Flatten; 
           
asymRules= {kRule2,nRule,asymSol,
           {a->1,hbar->1,m->1,V0->100,D->100}}//Flatten;

Clear[sPsi,aPsi];

(*Symmetric*) 
sPsi[x_ /;    x<-1,n0_]:= (psiL[x]//.symRules//.{n->n0});
sPsi[x_ /; -1<=x<1,n0_]:= (psiW[x]//.symRules//.{n->n0});
sPsi[x_ /;    x>=1,n0_]:= (psiR[x]//.symRules//.{n->n0});

(*Asymmetric*) 
aPsi[x_ /;    x<-1,n0_]:= (psiL[x]//.asymRules//.{n->n0});
aPsi[x_ /; -1<=x<1,n0_]:= (psiW[x]//.asymRules//.{n->n0});
aPsi[x_ /;    x>=1,n0_]:= (psiR[x]//.asymRules//.{n->n0});

symEnergy= nValues[eq6,100,#]& /@ symGuess

plotsym= 
Plot[ sPsi[x,#] //.symRules //Evaluate
        ,{x,-2,2}
        ,PlotLabel->  N[#,3]
        ,Axes->None
        ,DisplayFunction->Identity ]& /@ symEnergy;

Show[GraphicsArray[{plotsym[[{1,2,3}]],plotsym[[{4,5}]]}]];

asymEnergy= nValues[eq7,100,#]& /@ asymGuess;
 
plotasym= 
  Plot[ aPsi[x,#] //.asymRules //Evaluate
          ,{x,-2,2}
          ,PlotLabel->N[#,3]
          ,Axes->None
          ,DisplayFunction->Identity]& /@ asymEnergy;

Show[GraphicsArray[{plotasym[[{1,2}]],plotasym[[{3,4}]]}]];