Functions

MakeRow[jj_, dx_, x0_, NN_] := Module[{lrow, rowout,xn},
xn = x0 + jj dx;
lrow = {(-(1/(dx^2))),  ((2/(dx^2))+V[xn]),  (-(1/(dx^2)))};
rowout = Table[0,{kk,1,NN}];
If[jj > 1 && jj < NN,
rowout[[jj-1]] = lrow[[1]];
rowout[[jj]] = lrow[[2]];
rowout[[jj+1]] = lrow[[3]];
];

If[jj == 1,
rowout[[jj]] = lrow[[2]];
rowout[[jj+1]] = lrow[[3]];
];

If[jj == NN,
rowout[[jj-1]] = lrow[[1]];
rowout[[jj]] = lrow[[2]];
]
rowout //. Null -> 1
]

Solver[p_, a_, NN_, NT_, OT_] := Module[{x0, xf, dx, Omat,OP,UP, Psi, Psi0, nreps, Pout,j, Ptab,AA,dt},
x0 = -20.0;
xf = 20.0;
dx = (xf - x0)/(NN+1);
dt = .005;
nreps = {h -> 1, m -> 1/2, b -> -10};
Psi0 = Exp[I p x/h] (2 a/Pi)^(1/4)  Exp[-a(x - b)^2];
Omat = Table[N[MakeRow[jj,dx, x0, NN]],{jj,1,NN}];
OP = DiagonalMatrix[Table[1,{jj,1,NN}]] - (dt/I) Omat;
UP = Inverse[OP];
Print["Starting"];
Psi= N[Table[Psi0 /. nreps,{x,x0+dx,xf-dx,dx}]];
Pout = {};
For[j = 1, j≤ NT, j++,
If[Mod[j-1,OT] ==0,
Ptab = Table[{x0 + jj dx, Psi[[jj]] Conjugate[Psi[[jj]]]},{jj,1,Length[Psi]}];
Pout = Join[Pout,{Ptab}];
];
Psi = UP.Psi;
];
Pout
]

Examples

No Potential

V[x_] := 0

PT = Solver[4, 2, 500, 1000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.5}}],{jj,1,100,2}];

ListAnimate[GTAB]

Larger Barrier

V[x_] := If[x ≥ 0,1000]

PT = Solver[4, 2, 500, 1000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.5}}],{jj,1,100,2}];

ListAnimate[GTAB]

Smaller Barrier

V[x_] := If[x ≥ 0,10]

PT = Solver[4, 2, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.5}}],{jj,1,200,2}];

ListAnimate[GTAB]

Harmonic Potential

V[x_] := If[x > 0, x^2,0]

PT = Solver[4, 2, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.5}}],{jj,1,200,2}];

ListAnimate[GTAB]

Finite Square well

V[x_] := If[x > 0 && x < 5, -100,0]

PT = Solver[4, 2, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Mystery Potential

PT = Solver[4, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Triangle Well Potential

V[x_] :=Module[{ret},
ret = 0.0;
If[x > 0 && x < 5, ret = -x;];
If[x > 5 && x < 10, ret = -(10-x);];
10 ret
]

Plot[V[x],{x,-10,10}]

PT = Solver[4, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Sin(x)/x^3 Potential

Plot[Sin[(x-5)]/(x-5)^3,{x,.001,10}, PlotRange-> {0,100}]

V[x_] :=If[x > 0, Sin[(x-5)]/(x-5)^3]

PT = Solver[4, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Exp[-x^2] Cos[x] Potential

Plot[5 Exp[-10(x-5)^2] Cos[(x-5)],{x,.001,10}, PlotRange->{0,10}]

V[x_] :=If[x > 0,5Exp[-(x-5)^2] Cos[(x-5)]]

PT = Solver[4, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Delta Potential

V[x_] :=If[x ≥ 5 && x ≤ 5.1, -1000,0]

PT = Solver[8, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.025}}],{jj,1,200,2}];

ListAnimate[GTAB]

Linear Step

V[x_] :=If[-2 ≤ x && x ≤ 2, -Abs[x]+2,0]

Plot[V[x],{x,-10,10}]

PT = Solver[4, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Elliptic I

Plot[EllipticK[x/10] - EllipticK[0],{x,0,10}, PlotRange->{0,10}]

V[x_] :=If[x >0 && x < 10,5 (EllipticK[x/10] - EllipticK[0]),0]

PT = Solver[2, 4, 500, 2000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.25}}],{jj,1,200,2}];

ListAnimate[GTAB]

Midterm Potential

V[x_] := 0

PT = Solver[4, 2, 500, 1000,10];

GTAB = Table[ ListPlot[PT[[jj]], PlotJoined-> True,PlotRange-> {{-20,20},{0,.5}}],{jj,1,100,2}];

Map[Print,GTAB]

ListAnimate[GTAB]