Lamb Shift

(* Generic Commands, General Expressions, Generate Tables and Energy Diagrams *)
(* Evaluate this cell first.  Do not evaluate initialization cells. *)

Off[General::spell];
Off[FindRoot::frmp];
(* <<math/Graphics.m;
<<math/pspackage.m;
<<math/RungeKutta.m;
<<math/Tridiagonal.m *)
(* <<LinearAlgebra`Tridiagonal`; *)
solid = GrayLevel[0];
dash = Dashing[{.008,.008}];
dotdash = Dashing[{.013,.008,.003,.008}];
gray1 = GrayLevel[0.1];
gray2 = GrayLevel[0.2];
gray3 = GrayLevel[0.3];
gray4 = GrayLevel[0.4];
gray5 = GrayLevel[0.5];
gray6 = GrayLevel[0.6];
gray7 = GrayLevel[0.7];
gray8 = GrayLevel[0.8];
gray9 = GrayLevel[0.9];
red = RGBColor[1,0,0];
green = RGBColor[0,1,0];
blue = RGBColor[0,0,1];
cyan = RGBColor[0,1,1];
yellow = RGBColor[1,1,0];
magenta = RGBColor[1,0,1];
nodisplay = DisplayFunction->Identity;
display = DisplayFunction->$DisplayFunction;
SetOptions[Plot,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
SetOptions[Plot3D,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
SetOptions[ListPlot,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
SetOptions[ListPlot3D,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
SetOptions[ListDensityPlot,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
SetOptions[ParametricPlot,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
SetOptions[DensityPlot,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
beeptable = Table[N[Sin[Pi t/0.2]^2 Sin[1500 t],5],{t,0,0.2,.001 0.2}];
beep := ListPlay[beeptable];

Odd[n_] := (1 - (-1)^n)/2;

Clear[phase,expintlist,expdbydxlist,continuous,expinterpolation3,db];

phase[y_] := 
  Module[{sum},
    Table[
      If[i==1,sum=Arg[y[[1]]],If[i==2,sum=Arg[y[[2]]],sum+=Arg[y[[i]]/y[[i-1]]] ] ],
      {i,Length[y]}]
  ];

expintlist[x_, y_] := 
  Module[{sum},
    Table[
      If[i==1,sum=0,
      (*else*)sum+=(y[[i]]-y[[i-1]])*(x[[i]]-x[[i-1]])/
                   Log[E,y[[i]]/y[[i-1]]]//N],
      {i,Length[y]}]
  ];

expdbydxlist[x_, y_] := 
  Table[
    Which[i==1,y[[i]]/(x[[i+1]]-x[[i]])*Log[E,y[[i+1]]/y[[i]]]//N,
          i>1&&i<Length[y],y[[i]]/(x[[i+1]]-x[[i-1]])*
                           Log[E,y[[i+1]]/y[[i-1]]]//N,
          i==Length[y],y[[i]]/(x[[i]]-x[[i-1]])*
                       Log[E,y[[i]]/y[[i-1]]]//N],
    {i,Length[y]}];

continuous[y_] :=
  Module[{lasty, i},
    Table[
      lasty = If[i==1,y[[i]],
                  If[Abs[y[[i]]-lasty] < Abs[-y[[i]]-lasty],
                     y[[i]],-y[[i]] ] ],
    {i,Length[y]}]
  ];

 expinterpolation3[x_, y_, newx_] :=
  Module[{lown, highn, n, clipx},
    clipx = Min[newx,x[[Length[x]]] ];  (* check for out-of-range *)
    n = 1;
    While[clipx>x[[n]],n++];
    lown = Max[n-1,1];
    highn = Max[n,2];
    If[lown==0 || y[[highn]]==0,0,
    Exp[Log[E,y[[lown]]] + (clipx-x[[lown]])/(x[[highn]]-x[[lown]])*
         Log[E,y[[highn]]/y[[lown]]] ] //N]
  ];

 db[y_] := 20 Log[10,Abs[y] ];

listplot[list_, options___] :=
   ListPlot[Transpose[{xtable,list}],options,Frame->True,Joined->True,
             AspectRatio->0.8,Axes->False,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
             
             
dbydxlistalt[list_] := 
           Module[{diff},Table[
           Which[i==1,diff=(list[[2]]-list[[1]])//N,
                 i>1&&i<Length[list],diff=(list[[i+1]]-list[[i]])//N,
                 i==Length[list],diff=(list[[i]]-list[[i-1]])//N]
           ,{i,1,Length[list]}]];
dbydxlist[list_] := 
           Module[{diff},Table[
           Which[i==1,diff=(list[[2]]-list[[1]])//N,
                 i>1&&i<Length[list],diff=(list[[i+1]]-list[[i-1]])/2//N,
                 i==Length[list],diff=(list[[i]]-list[[i-1]])//N]
           ,{i,1,Length[list]}]];
d2bydx2list[list_] := 
           Module[{diff},Table[
           If[i==1,diff=(-2 list[[i+1]]+list[[i+2]]+list[[i]])//N,
              If[i==Length[list],diff=(-2 list[[i-1]]+list[[i-2]]+list[[i]])//N,
                 diff=(-2 list[[i]]+list[[i-1]]+list[[i+1]])//N]]
           ,{i,1,Length[list]}]];

accelrate[list_] := 
           Module[{diff},Table[
           If[i==1,diff=Abs[list[[i+2]]-list[[i+1]]]-Abs[list[[i+1]]-list[[i]]]//N,
           If[i==Length[list],
                 diff=Abs[list[[i]]-list[[i-1]]]-Abs[list[[i-1]]-list[[i-2]]]//N,
                 diff=Abs[list[[i+1]]-list[[i]]]-Abs[list[[i]]-list[[i-1]]]//N]]
              ,{i,1,Length[list]}]];
              

intlist[list_] := 
           Module[{sum},Table[
           If[i==1,sum=0,sum+=(list[[i]]+list[[i-1]])/2//N]
           ,{i,1,Length[list]}]];

verticalplot[grid_, options___] :=
   MultipleListPlot[Take[Transpose[grid],
              {takexmin*pointdens+1,takexmax*pointdens+1}],options,
   Frame->True,Joined->True,
   PlotRange->{{1,pointdens*h+1},All},AspectRatio->0.8,Axes->False,
   FrameTicks->{Table[{i,(i-1)*h/(pointdens)//N},{i,1,pointdens h+1,
                (pointdens h )/ 5}],
                  Automatic,BaseStyle->{FontFamily->"Helvetica",FontSize->10}}
         ];
verticalplot2[grid_, options___] :=
   MultipleListPlot[Take[Transpose[grid],
              {takexmin*pointdens+1,takexmax*pointdens+1}],options,
   Frame->True,Joined->True,
   PlotRange->{{1,pointdensy*h+1},All},AspectRatio->0.8,Axes->False,
   FrameTicks->{Table[{i,(i-1)*h/(pointdensy)//N},{i,1,pointdensy h+1,
                (pointdensy h )/ 5}],
                  Automatic,BaseStyle->{FontFamily->"Helvetica",FontSize->10}}
         ];

horizontalplot[grid_, options___] :=
   MultipleListPlot[Transpose[Take[Transpose[grid],
              {takexmin*pointdens+1,takexmax*pointdens+1}]],options,
   Frame->True,Joined->True,
   PlotRange->{All,All},AspectRatio->0.8,Axes->False,
   FrameTicks->{Table[{pointdens*(i-takexmin)+1,i},{i,takexmin,takexmax}],
                 Automatic,BaseStyle->{FontFamily->"Helvetica",FontSize->10}}
         ];
surfaceplot[grid_, options___] :=
   ListPlot3D[Transpose[Take[Transpose[grid],
              {takexmin*pointdens+1,takexmax*pointdens+1}]],options,
   BoxRatios->{takexmax-takexmin,h,h},PlotRange->All,
          Ticks->{Table[{pointdens*(i-takexmin)+1,i},{i,takexmin,takexmax}],
                  Table[{i,(i-1)*h/(pointdens-1)//N},
                  {i,1,pointdens h,(pointdens-1) h / 5}],
                  Automatic},ClippingStyle->None,BaseStyle->{FontFamily->"Helvetica",FontSize->10}
         ];

laplacecheckplot[grid_, options___] :=
  ListDensityPlot[-Table[If[j > 1 && j < Length[grid[[1]]] && i > 1 && i < Length[grid],
                Abs[1 + (grid[[i+1,j]] + grid[[i-1,j]] - 2 grid[[i,j]])/
                        (grid[[i,j+1]] + grid[[i,j-1]] - 2 grid[[i,j]])],                
                    0],{i,1,Length[grid]},{j,1,Length[grid[[1]]]}]
               ,AspectRatio->1/10,Mesh->False,PlotRange->{-1,0},
     FrameTicks->{Table[{pointdens*i,i},{i,0,xmax}],
                  Table[{i,i*h/(pointdens+1)//N},{i,0,(pointdens+1) h,(pointdens+1)h/5}]},
          BaseStyle->{FontFamily->"Helvetica",FontSize->10},options];

laplacecheck2[grid_] :=
     Table[If[j > 1 && j < Length[grid[[1]]] && i > 1 && i < Length[grid],
                grid[[i+1,j]] + grid[[i-1,j]] +
                        grid[[i,j+1]] + grid[[i,j-1]] - 4 grid[[i,j]],                
                    0],{i,1,Length[grid]},{j,1,Length[grid[[1]]]}];


gridplot[grid_, options___] :=
ListDensityPlot[grid,options,AspectRatio->1/10,Mesh->False,PlotRange->{-1,0},
FrameTicks->{Table[{pointdens*i,i},{i,0,xmax}],
                  Table[{i,i*h/(pointdens+1)//N},{i,0,(pointdens+1) h,
                  (pointdens+1) h/5}]},BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
                  
sliceplot[list_, options___] :=
   ListPlot[Take[list,
              {takexmin*pointdens+1,takexmax*pointdens+1}],options,
   Frame->True,Joined->True,
   PlotRange->{All,All},AspectRatio->0.8,Axes->False,
   FrameTicks->{Table[{pointdens*(i-takexmin)+1,i},{i,takexmin,takexmax}],
                 Automatic,BaseStyle->{FontFamily->"Helvetica",FontSize->10}}
         ];

verticalintgrid[grid_] := 
           Module[{sum},Table[CompoundExpression[
              Do[
                If[i==1,sum=0,sum+=(grid[[i,j]]+grid[[i-1,j]])/2//N],
                {i,1,Length[grid]}];
              sum]
           ,{j,1,Length[grid[[1]]]}]];
           
argplot[grid_, options___] := 
        ListPlot[Transpose[{Re[grid],Im[grid]}],options,Joined->True,
                AspectRatio->Automatic,PlotRange->All,Frame->True,Axes->False,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
argpointplot[grid_, options___] := Show[
        ListPlot[Transpose[{Re[grid],Im[grid]}],Joined->True,PlotRange->All,BaseStyle->{FontFamily->"Helvetica",FontSize->10}
                 nodisplay],
        ListPlot[Transpose[{Re[grid],Im[grid]}],PlotRange->All,nodisplay,
             PlotStyle->PointSize[0.015],BaseStyle->{FontFamily->"Helvetica",FontSize->10}],options,display,
             AspectRatio->Automatic,PlotRange->All,Frame->True,Axes->False,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];
listpointplot[list_, options___] := Show[
        ListPlot[list,Joined->True,PlotRange->All,BaseStyle->{FontFamily->"Helvetica",FontSize->10}
                 nodisplay],
        ListPlot[list,PlotRange->All,nodisplay,
             PlotStyle->PointSize[0.015],BaseStyle->{FontFamily->"Helvetica",FontSize->10}],options,display,
             AspectRatio->Automatic,PlotRange->All,Frame->True,Axes->False,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];

complexlistplot[list_, options___] :=
     Show[ListPlot[Re[list],Joined->True,nodisplay,BaseStyle->{FontFamily->"Helvetica",FontSize->10}],
     ListPlot[Im[list],Joined->True,PlotStyle->gray3,nodisplay,BaseStyle->{FontFamily->"Helvetica",FontSize->10}],
     options,display,AspectRatio->0.8,Frame->True,Axes->False,PlotRange->All];
complexlistpointplot[list_, options___] :=
     Show[ListPlot[Re[list],Joined->True,nodisplay,BaseStyle->{FontFamily->"Helvetica",FontSize->10}],
     ListPlot[Re[list],nodisplay,PlotStyle->PointSize[0.015],BaseStyle->{FontFamily->"Helvetica",FontSize->10}],
     ListPlot[Im[list],Joined->True,PlotStyle->gray3,nodisplay,BaseStyle->{FontFamily->"Helvetica",FontSize->10}],
     ListPlot[Im[list],PlotStyle->{PointSize[0.015],gray3},nodisplay,BaseStyle->{FontFamily->"Helvetica",FontSize->10}],
     options,display,AspectRatio->0.8,Frame->True,Axes->False,PlotRange->All,BaseStyle->{FontFamily->"Helvetica",FontSize->10}];

ydb[array_] := Transpose[{Transpose[array][[1]],db[Transpose[array][[2]]]}];
yphase[array_] := Transpose[{Transpose[array][[1]],phase[Transpose[array][[2]]]}];
yre[array_] := Transpose[{Transpose[array][[1]],Re[Transpose[array][[2]]]}];
yim[array_] := Transpose[{Transpose[array][[1]],Im[Transpose[array][[2]]]}];

(******************************************************************** 
expinterpolation :  this program returns a value at a given
                    position, interpolated at a given position from a
                    given sampled function.  The sampled function must
                    be given in terms of its magnitude (dB) and phase.
                    the phase must be continuous, i.e. have been unwrapped
                    using a program like  phaseclean().  this variation
                    assumes x values are equally spaced.                  
********************************************************************) 
expinterpolation[xtable_, maglist_, phaselist_, x_] :=
   Module[{numpoints, dx, posn, magdb1, magdb2, magdb,phase1,phase2,
           phaseval,returnval},
   CompoundExpression[
     numpoints = Length[xtable];
     dx = (xtable[[numpoints]] - xtable[[1]])/(numpoints-1);
     posn = (x - xtable[[1]])/dx + 1;
     If[posn >= numpoints,magdb = maglist[[Floor[posn] ]],
          CompoundExpression[
            magdb1 = maglist[[Floor[posn] ]];
            magdb2 = maglist[[Floor[posn]+1 ]];
            magdb = magdb1 + (magdb2 - magdb1)*(posn-Floor[posn])]];
     If[posn >= numpoints,phaseval = phaselist[[Floor[posn] ]],
          CompoundExpression[
            phase1 = phaselist[[Floor[posn] ]];
            phase2 = phaselist[[Floor[posn]+1 ]] ;
            phaseval = phase1 + (phase2 - phase1)*(posn-Floor[posn])]];
     returnval = 10^(magdb/20)*Exp[I phaseval]//N;
     (* Print["x = ",x,"     value = ",returnval]; *)
     Return[returnval]
     ]];

(******************************************************************** 
expinterpolation2 :  this program returns a value at a given
                    position, interpolated at a given position from a
                    given sampled function.  The sampled function must
                    be given in terms of its magnitude (dB) and phase.
                    the phase must be continuous, i.e. have been unwrapped
                    using a program like  phaseclean().  this particular
                    variation does not assume equally spaced x values.                   
********************************************************************) 
expinterpolation2[xtable_, maglist_, phaselist_, x_] :=
   Module[{magdb1, magdb2, magdb,phase1,phase2,
           phaseval,returnval, lown, highn, n, clipx},
   CompoundExpression[
     clipx = Min[x,xtable[[Length[xtable]]] ];  (* check for out-of-range *)
     n = 1;
     While[clipx>xtable[[n]],n++];
     lown = Max[n-1,1];
     highn = Max[n,2];
     
     magdb1 = maglist[[lown]];
     magdb2 = maglist[[highn]];
     magdb = magdb1 + (magdb2 - magdb1)*(clipx-xtable[[lown]])/
                       (xtable[[highn]]-xtable[[lown]]);
     
     phase1 = phaselist[[lown]];
     phase2 = phaselist[[highn]] ;
     phaseval = phase1 + (phase2 - phase1)*(clipx-xtable[[lown]])/
                       (xtable[[highn]]-xtable[[lown]]);
     
     returnval = 10^(magdb/20)*Exp[I phaseval]//N;
     (* Print["x = ",x,"     value = ",returnval]; *)
     Return[returnval]
     ]];

(******************************************************************** 
lininterpolation :  this program returns a value at a given
                    position, interpolated at a given position from a
                    given sampled function.  does not assume equally 
                    spaced x values.                   
********************************************************************) 
lininterpolation[xtable_, list_, x_] :=
   Module[{returnval, lown, highn, n, clipx},
   CompoundExpression[
     clipx = Min[x,xtable[[Length[xtable]]] ];  (* check for out-of-range *)
     n = 1;
     While[clipx>xtable[[n]],n++];
     lown = Max[n-1,1];
     highn = Max[n,2];
     
     returnval = list[[lown]] + (list[[highn]]-list[[lown]])*
                    (clipx-xtable[[lown]])/(xtable[[highn]]-xtable[[lown]])//N;
     (* Print["x = ",x,"     value = ",returnval]; *)
     Return[returnval]
     ]];



(* may be able to use these somehow to save smaller files *)
round[j_] :=  N[If[Re[j]==0,0,
              Round[10^6 MantissaExponent[N[Re[j]]][[1]]]/10^6 *
              10^MantissaExponent[ N[Re[j]] ][[2]] ] +
              If[Im[j]==0,0,
              I*Round[10^6 MantissaExponent[N[Im[j]]][[1]]]/10^6 *
              10^MantissaExponent[N[Im[j]]][[2]] ] ];

roundlist[list_] := Table[round[list[[i]]],{i,1,Length[list]}];
roundarray[array_] := Table[roundlist[array[[i]]],{i,1,Length[array]}];

(* Schrodinger solution *)
ψSchrodinger[{n_, l_, ml_}, r_, θ_,ϕ_] := ((2/(n (Subscript[a, 0])))^(3/2))Sqrt[ (n-l-1)!/((2n)((n+l )!)^1 ) ] Exp[-r/(n (Subscript[a, 0]))] ((2r)/(n (Subscript[a, 0])))^l LaguerreL[n - l - 1, 2 l + 1, ((2 r)/(n (Subscript[a, 0])))]SphericalHarmonicY[l, ml, θ,ϕ];
ψSchrodingerRadial[{n_, l_, ml_}, r_, θ_,ϕ_] := ((2/(n (Subscript[a, 0])))^(3/2))Sqrt[ (n-l-1)!/((2n)((n+l )!)^1 ) ] Exp[-r/(n (Subscript[a, 0]))] ((2r)/(n (Subscript[a, 0])))^l LaguerreL[n - l - 1, 2 l + 1, ((2 r)/(n (Subscript[a, 0])))];
ψSchrodingerAngular[{n_, l_, ml_}, r_, θ_,ϕ_] := SphericalHarmonicY[l, ml, θ,ϕ];

CheckNormRadialSchrodinger[{n_, l_, ml_}, r_, θ_,ϕ_] := Module[{norm,ff},
		ff = ψSchrodingerRadial[{n, l, ml}, r, θ,ϕ];
		norm = Simplify[ Integrate[(ff^2 )  r^2 ,{r,0,Infinity}],Re[(Subscript[a, 0]) ]>0];
		norm
		];

CheckEqnRadialSchrodinger[{n_, l_, ml_}, r_, θ_,ϕ_] := Module[{eqn,ff},
		ff = ψSchrodingerRadial[{n, l, ml}, r, θ,ϕ];
		eqn = Simplify[r^2 D[ff,{r,2}] + 2 r D[ff,r] - (l(l+1) + (r/(n (Subscript[a, 0])))^2 - 2 (r/ (Subscript[a, 0])) ) ff ];	
		eqn
		];


normSchrodinger[{n_, l_, ml_}, r_, θ_,ϕ_]  := Integrate[ψSchrodinger[{n,l,ml}, r,  θ,ϕ] ψSchrodinger[{n,l,ml}, r,  θ,-ϕ]  r^2 Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];

eqnSchrodinger[{n_, l_, ml_}, r_, θ_,ϕ_]  := Module[{E, V, ψ, eqn},
E = -m (q^4)/(8 (Subscript[ϵ, 0])^2 4 Pi^2 hbar^2 n^2);
V = -q^2/(4 Pi (Subscript[ϵ, 0]) r);
ψ = ψSchrodinger[{n,l,ml}, r,  θ,ϕ];
eqn = Simplify[(-hbar^2/(2 m)Laplacian[ψ,{r,  θ,ϕ},"Spherical"] +V ψ - E ψ)/. (Subscript[a, 0])->4*Pi*(Subscript[ϵ, 0])*(hbar^2)/(m*(q^2))];
eqn
];

(* Dirac Solution, taken literally from Landau and Lifshitz *)

(* EnergyDirac[n_, j_] := Simplify[(m c ^2)/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]]; *)
EnergyDirac[n_, j_] := Simplify[(m c ^2)( n-(j+1/2)+Sqrt[(j+1/2)^2-α^2] )/Sqrt[(α^2)+(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]];  (* equivalent, but easier for Mathematica to simplify *)


f[r_, n_, E_, kappa_] := Module[{lambda, rho, gamma, nr, term1, nr2},
		lambda = Simplify[m c^2 Sqrt[1 - (E/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		rho = 2 lambda r;
		gamma = Sqrt[kappa^2 - α^2];
		nr = n-Abs[kappa];
		nr2 =Simplify[( α E / (lambda hbar c) - gamma )/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		(* Print["nr = ",nr,"              nr2 = ",nr2,"    = ",N[(nr2/. α->1.0000000000000000000000000000000/137.0000000000000000000000000000000),20]];*)
		term1 = Simplify[(gamma + nr)/(E/(m c^2))];  (* the  Z α m / lambda term *)
		ff = Simplify[(2 lambda)^(3/2)/Gamma[2 gamma+1]Sqrt[((m c^2+E)Gamma[2 gamma + nr + 1])/ (4m c^2 term1 (term1 - kappa)nr!)   ]
		(2 lambda r)^(gamma-1) Exp[- lambda r]
		 ((term1 - kappa)Hypergeometric1F1 [-nr,2 gamma+1,2 lambda r]- nr Hypergeometric1F1 [1-nr,2 gamma+1,2 lambda r])];
		(* Print["ff = ",ff]; *)
		ff];

g[r_, n_, E_, kappa_] := Module[{lambda, rho, gamma, nr, term1},
		lambda = Simplify[m c^2 Sqrt[1 - (E/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		rho = 2 lambda r;
		gamma = Sqrt[kappa^2 - α^2];
		nr = n-Abs[kappa];
		term1 = Simplify[(gamma + nr)/(E/(m c^2))];  (* the  Z α m / lambda term *)
		gg = Simplify[-(2 lambda)^(3/2)/Gamma[2 gamma+1]Sqrt[((m c^2-E)Gamma[2 gamma + nr + 1])/(4m c^2 term1 (term1 - kappa)nr!)   ]
		(2 lambda r)^(gamma-1) Exp[- lambda r] 
		((term1 - kappa)Hypergeometric1F1 [-nr,2 gamma+1,2 lambda r]+ nr Hypergeometric1F1 [1-nr,2 gamma+1,2 lambda r])];
		gg];


fNoGamma[r_, n_, E_, kappa_] := Module[{lambda, rho, gamma, nr, term1},
		lambda = Simplify[m c^2 Sqrt[1 - (E/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		rho = 2 lambda r;
		gamma = Sqrt[kappa^2 - α^2];
		nr = n-Abs[kappa];
		term1 = Simplify[(gamma + nr)/(E/(m c^2))];  (* the  Z α m / lambda term *)
		ff = Simplify[Sqrt[((m c^2+E)) /  (m c^2)](2 lambda r)^(gamma-1) Exp[- lambda r]
		 ((term1 - kappa)Hypergeometric1F1 [-nr,2 gamma+1,2 lambda r]- nr Hypergeometric1F1 [1-nr,2 gamma+1,2 lambda r])];
		ff];
gNoGamma[r_, n_, E_, kappa_] := Module[{lambda, rho, gamma, nr, term1},
		lambda = Simplify[m c^2 Sqrt[1 - (E/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		rho = 2 lambda r;
		gamma = Sqrt[kappa^2 - α^2];
		nr = n-Abs[kappa];
		term1 = Simplify[(gamma + nr)/(E/(m c^2))];  (* the  Z α m / lambda term *)
		gg = Simplify[-Sqrt[((m c^2-E))/  (m c^2)](2 lambda r)^(gamma-1) Exp[- lambda r] 
		((term1 - kappa)Hypergeometric1F1 [-nr,2 gamma+1,2 lambda r]+ nr Hypergeometric1F1 [1-nr,2 gamma+1,2 lambda r])];
		gg];

CheckNormfg[r_, n_, E_, kappa_] := Module[{norm,ff,gg},
		ff = Simplify[f[r, n, E, kappa]/. {hbar->(Subscript[a, 0]) α c m}];
		gg = Simplify[g[r, n, E, kappa]/. {hbar->(Subscript[a, 0]) α c m}];
		(* Print["ff = ",ff];
		Print["gg = ",gg]; *)
		norm = Simplify[ Integrate[(ff^2 + gg^2)  r^2 ,{r,0,Infinity}],Re[(Subscript[a, 0]) ]>0];
		norm
		];

Checkfg[r_, n_, E_, kappa_] := Module[{eqn1, eqn2,eqn,ff,gg, V, helper, lambda, gamma, nr},
		ff = fNoGamma[r, n, E, kappa];
		gg = gNoGamma[r, n, E, kappa];
		V =  - (Subscript[a, 0])α^2 m c^2/ r ;

		lambda = Simplify[m c^2 Sqrt[1 - (E/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		gamma = Sqrt[kappa^2 - α^2];
		nr = n-Abs[kappa];
		
		helper = (2 lambda r)^(gamma-1) Exp[- lambda r]; 
		
		term1 = (D[ff,r]/helper)/.{hbar->(Subscript[a, 0]) α c m};
		term2 = (ff (1 + kappa)/r /helper) /.{hbar->(Subscript[a, 0]) α c m};
		(* term3 =  -((E  + (m c^2) -V) gg / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m}; *)
		term3 =  -((E) gg / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m};
		term4 =  -(( (m c^2) ) gg / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m};
		term5 =  -((-V) gg / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m};
		
		term11 = (D[gg,r]/helper)/.{hbar->(Subscript[a, 0]) α c m};
		term12= (gg (1 - kappa)/r /helper) /.{hbar->(Subscript[a, 0]) α c m};
		(* term13 =  ((E  - (m c^2) -V) ff / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m}; *)
		term13 =  ((E ) ff / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m};
		term14 =  ((-(m c^2)) ff / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m};
		term15 =  (( -V) ff / (hbar  c)/ helper)/.{hbar->(Subscript[a, 0]) α c m};
		
		(*
		Print["                          kappa  = ",kappa];
		Print["                             nr  = ",nr];
		Print[" "];
		Print["                             eqn1:     df/dr + (",(1+kappa),") f/r - (",Simplify[((E  + (m c^2) -V) / (hbar  c))/. {hbar->(Subscript[a, 0]) α c m}],") g == 0"];
		Print["                             eqn2:     dg/dr + (",(1-kappa),") g/r + (",Simplify[((E  - (m c^2) -V) / (hbar  c))/. {hbar->(Subscript[a, 0]) α c m}],") f == 0"];
		Print[" "];
		Print["                              f  = ",Simplify[ff]/.{hbar->(Subscript[a, 0]) α c m}];
		Print["                              g  = ",Simplify[gg]/.{hbar->(Subscript[a, 0]) α c m}];
		
		Print[" "];
		Print["                              term1 = ",Simplify[term1],"  = ",Simplify[term1]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term2 = ",Simplify[term2],"  = ",Simplify[term2]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term3 = ",Simplify[term3],"  = ",Simplify[term3]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term4 = ",Simplify[term4],"  = ",Simplify[term4]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term5 = ",Simplify[term5],"  = ",Simplify[term5]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                      term1+2+3+4+5 = ",Simplify[term1 + term2 + term3+ term4+ term5 ],"  = ",
Simplify[term1 + term2 + term3+ term4+ term5]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N,"         should be zero"];
		
		Print["                              term11 = ",Simplify[term11],"  = ",Simplify[term11]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term12 = ",Simplify[term12],"  = ",Simplify[term12]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term13 = ",Simplify[term13],"  = ",Simplify[term13]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term14 = ",Simplify[term14],"  = ",Simplify[term14]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                              term15 = ",Simplify[term15],"  = ",Simplify[term15]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N];
		Print["                  term11+12+13+14+15 = ",Simplify[term11 + term12 + term13+ term14+ term15 ],"  = ",Simplify[term11 + term12 + term13+ term14+ term15]/.{α->1/137,r->1,(Subscript[a, 0])->1}//N,"         should be zero"]; 
		
		(* Print["                             g/f = ",Simplify[Sqrt[Simplify[gg^2/ff^2]/.{hbar->(Subscript[a, 0]) α c m}]]]; *)
		

		*)
		
		eqn1 = (D[ff,r] + ff (1 + kappa)/r  - (E  + (m c^2) -V) gg / (hbar  c));   (* as written in Landau and Lifshitz *)
		(* eqn1 = (D[ff,r] + ff (1 + kappa)/r  + (E  + (m c^2) -V) gg / (hbar  c)); *)     (* consistent with Dr. Zhang's notes *)
		eqn2 = (D[gg,r] + gg (1 - kappa)/r  + ( E  - (m c^2) -V) ff / (hbar c) );
		eqn = MatrixForm[Simplify[{eqn1/helper, eqn2/helper}/. {hbar->(Subscript[a, 0]) α c m}]];
		eqn
		];

SphericalHarmonicYLandau[l_, m_, θ_,ϕ_] :=  Module[{value},
value = Simplify[((-1)^((m+Abs[m])/2)) (I^l)((-1)^m )Sqrt[(2l + 1)*((l-Abs[m])!) / (4 Pi ((l + Abs[m])!)    )]LegendreP[l ,Abs[m ], Cos[ θ]] Exp[I m ϕ],θ>0 && θ<Pi];
(* includes (-1)^m term (Condon-Shortley phase), to match table in Landau and Lifshitz *)
(* value = ((-1)^m )value;  *)(* Condon-Shortley phase to match table in Landau and Lifshitz *)
 (* If[ Mod[m,2]≠ 0, value = -value]; *) (* hack to match table in Landau and Lifshitz, flip sign if m is odd *)
 value]
  (* note:  for l=0, m=+/-1, requires (-1)! , which is not defined - I had to explicitly handle that case in the code below *)

SphericalHarmonicYLandauStar[l_, m_, θ_,ϕ_] :=  Module[{value},
value = Simplify[((-I)^(m+Abs[m]+l)) ((-1)^m )Sqrt[(2l + 1)*((l-Abs[m])!) / (4 Pi ((l + Abs[m])!)    )]LegendreP[l ,Abs[m ], Cos[ θ]] Exp[-I m ϕ],θ>0 && θ<Pi];
(* includes (-1)^m term (Condon-Shortley phase), to match table in Landau and Lifshitz *)
(* value = ((-1)^m )value;  *)(* Condon-Shortley phase to match table in Landau and Lifshitz *)
 (* If[ Mod[m,2]≠ 0, value = -value]; *) (* hack to match table in Landau and Lifshitz, flip sign if m is odd *)
 value]


ψ1Dirac[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] :=  Module[{},
		(* Print["        f = ",f[r,n, E,kappa]/.{hbar->(Subscript[a, 0]) α c m}];
		Print["j,mj term = ",If [j==(l+1/2),Sqrt[(j+mj)/(2j) ],(-Sqrt[(j-mj  + 1)/(2j + 2) ]) ]]; *)
		f[r,n, E,kappa] If [j==(l+1/2),If[ j+mj==0 ,0,Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandau[l, mj-1/2, θ,ϕ] ], 
		If[ j-mj+1==0 ,0,(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandau[l, mj-1/2, θ,ϕ]] ]];
ψ2Dirac[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] :=  
		f[r,n, E,kappa] If [j==(l+1/2),If[ j-mj == 0,0,Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandau[l, mj+1/2, θ,ϕ]],
		If[ j+mj+1==0,0,Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandau[l, mj+1/2, θ,ϕ] ] ];
ψ3Dirac[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] := Module[{lprime},
		lprime = 2j-l;
		(-1)^(1/2(1+l-lprime))g[r,n, E,kappa] If [j==(lprime+1/2),If[ j+mj==0 ,0,If[j+mj==0,0,Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandau[lprime, mj-1/2, θ,ϕ]]], 
		If[ j-mj+1==0 ,0,(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandau[lprime, mj-1/2, θ,ϕ]] ]];
ψ4Dirac[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] := Module[{lprime},
		lprime = 2j-l;
		(-1)^(1/2(1+l-lprime))g[r,n,E,kappa] If [j==(lprime+1/2),If[j-mj==0,0,Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandau[lprime, mj+1/2, θ,ϕ]],
		If[j+mj+1==0,0,Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandau[lprime, mj+1/2, θ,ϕ]]  ]];
ψDirac[{n_, l_, mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{E},
		(* E = (m c ^2)/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]; *)
		E = EnergyDirac[n, j];  (* use the better simplified version *)
		{ψ1Dirac[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m},
		ψ2Dirac[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m},
		ψ3Dirac[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m},
		ψ4Dirac[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m}}];

ψ1DiracStar[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] :=  Module[{},
		(* Print["        f = ",f[r,n, E,kappa]/.{hbar->(Subscript[a, 0]) α c m}];
		Print["j,mj term = ",If [j==(l+1/2),Sqrt[(j+mj)/(2j) ],(-Sqrt[(j-mj  + 1)/(2j + 2) ]) ]]; *)
		f[r,n, E,kappa] If [j==(l+1/2),If[ j+mj==0 ,0,Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandauStar[l, mj-1/2, θ,ϕ] ], 
		If[ j-mj+1==0 ,0,(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandauStar[l, mj-1/2, θ,ϕ]] ]];
ψ2DiracStar[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] :=  
		f[r,n, E,kappa] If [j==(l+1/2),If[ j-mj == 0,0,Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandauStar[l, mj+1/2, θ,ϕ]],
		If[ j+mj+1==0,0,Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandauStar[l, mj+1/2, θ,ϕ] ] ];
ψ3DiracStar[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] := Module[{lprime},
		lprime = 2j-l;
		(-1)^(1/2(1+l-lprime))g[r,n, E,kappa] If [j==(lprime+1/2),If[ j+mj==0 ,0,If[j+mj==0,0,Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandauStar[lprime, mj-1/2, θ,ϕ]]], 
		If[ j-mj+1==0 ,0,(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandauStar[lprime, mj-1/2, θ,ϕ]] ]];
ψ4DiracStar[{n_, l_, mj_, j_,E_, kappa_}, r_, θ_,ϕ_] := Module[{lprime},
		lprime = 2j-l;
		(-1)^(1/2(1+l-lprime))g[r,n,E,kappa] If [j==(lprime+1/2),If[j-mj==0,0,Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandauStar[lprime, mj+1/2, θ,ϕ]],
		If[j+mj+1==0,0,Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandauStar[lprime, mj+1/2, θ,ϕ]]  ]];
ψDiracStar[{n_, l_, mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{E},
		(* E = (m c ^2)/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]; *)
		E = EnergyDirac[n, j];  (* use the better simplified version *)
		{ψ1DiracStar[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m},
		ψ2DiracStar[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m},
		ψ3DiracStar[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m},
		ψ4DiracStar[{n, l, mj, j, E, kappa}, r, θ,ϕ]/.{hbar->(Subscript[a, 0]) α c m}}];

normDirac2[{n_, l_, mj_, j_, kappa_}, r_, θ_,ϕ_]  := Module[{ψ,ψstar,c1,c2,c3,c4, ψ1, ψ2, ψ3, ψ4, ψ1star, ψ2star, ψ3star, ψ4star},
ψ =  ψDirac[{n, l, mj, j, kappa}, r,  θ,ϕ];
ψstar =  ψDiracStar[{n, l, mj, j, kappa}, r,  θ,ϕ]; 

ψ1 = ψ[[1]];
ψ2 = ψ[[2]];
ψ3 = ψ[[3]];
ψ4 = ψ[[4]];
ψ1star = ψstar[[1]];
ψ2star = ψstar[[2]];
ψ3star = ψstar[[3]];
ψ4star = ψstar[[4]];

c1 = Integrate[ψ1star ψ1   r^2 Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
c2 = Integrate[ψ2star ψ2   r^2 Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
c3 = Integrate[ψ3star ψ3   r^2 Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
c4 = Integrate[ψ4star ψ4   r^2 Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}]; 
c1 = Simplify[c1,Re[(Subscript[a, 0]) ]>0]; 
c2 = Simplify[c2,Re[(Subscript[a, 0]) ]>0]; 
c3 = Simplify[c3,Re[(Subscript[a, 0]) ]>0]; 
c4 = Simplify[c4,Re[(Subscript[a, 0]) ]>0]; 
norm = Simplify[c1 + c2 + c3 + c4];
norm
];

ddx[{f_},r_,θ_,ϕ_] := Sin[θ] Cos [ϕ]D[f,r] + Cos[θ] Cos [ϕ]/r D[f,θ] - Sin [ϕ]/(r Sin[θ])D[f,ϕ];
ddy[{f_},r_,θ_,ϕ_] := Sin[θ] Sin [ϕ]D[f,r] + Cos[θ] Sin [ϕ]/r D[f,θ] + Cos [ϕ]/(r Sin[θ])D[f,ϕ];
ddz[{f_},r_,θ_,ϕ_] := Cos[θ] D[f,r]                - Sin[θ] /r D[f,θ];

eqnDirac[{n_, l_, ml_, mj_, j_, kappa_}, r_, θ_,ϕ_]  := 
	Module[{E,ψ,V,ψ1,ψ2,ψ3,ψ4, helper},
		(* E = (m c ^2)/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]; *)
		E = EnergyDirac[n, j];  (* use the better simplified version *)
		ψ = ψDirac[{n,l,mj, j, kappa}, r,  θ,ϕ];

		(* Print[ψ ]; *)
		V = -hbar^2/(m (Subscript[a, 0])r); 
		
		ψ1 = Simplify[ψ[[1]]];
		ψ2 = Simplify[ψ[[2]]];
		ψ3 = Simplify[ψ[[3]]];
		ψ4 = Simplify[ψ[[4]]];
		(* Print[ψ1 ];
		Print[ψ2 ];
		Print[ψ3 ];
		Print[ψ4 ]; *)
		
		eqn1 = Simplify[(1/(m c^2)(-E ψ1 - c I hbar (ddx[{ψ4},r,θ,ϕ]-I ddy[{ψ4},r,θ,ϕ] + ddz[{ψ3},r,θ,ϕ] ) + V ψ1 + m c^2 ψ1))/.{hbar->(Subscript[a, 0]) α c m}/. α-> 1/137 ];
		eqn2 = Simplify[(1/(m c^2)(-E ψ2 - c I hbar (ddx[{ψ3},r,θ,ϕ]+I ddy[{ψ3},r,θ,ϕ] - ddz[{ψ4},r,θ,ϕ] ) + V ψ2 + m c^2 ψ2))/.{hbar->(Subscript[a, 0]) α c m}/. α-> 1/137];
		eqn3 = Simplify[(1/(m c^2)(-E ψ3 - c I hbar (ddx[{ψ2},r,θ,ϕ]-I ddy[{ψ2},r,θ,ϕ] + ddz[{ψ1},r,θ,ϕ] ) + V ψ3 - m c^2 ψ3))/.{hbar->(Subscript[a, 0]) α c m} /. α-> 1/137 ];
		eqn4 = Simplify[(1/(m c^2)(-E ψ4 - c I hbar (ddx[{ψ1},r,θ,ϕ]+I ddy[{ψ1},r,θ,ϕ] - ddz[{ψ2},r,θ,ϕ] ) + V ψ4 - m c^2 ψ4))/.{hbar->(Subscript[a, 0]) α c m} /. α-> 1/137]; 
		
		{eqn1,eqn2,eqn3,eqn4}
];

eqnKleinGordon[{n_, l_, ml_, mj_, j_, kappa_}, r_, θ_,ϕ_]  := 
	Module[{E,ψ,V,ψ1,ψ2,ψ3,ψ4, helper},
		(* E = (m c ^2)/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]; *)
		E = EnergyDirac[n, j];  (* use the better simplified version *)
		ψ = ψDirac[{n,l,mj, j, kappa}, r,  θ,ϕ];

		(* Print[ψ ]; *)
		V = -hbar^2/(m (Subscript[a, 0])r); 
		
		ψ1 = Simplify[ψ[[1]]];
		ψ2 = Simplify[ψ[[2]]];
		ψ3 = Simplify[ψ[[3]]];
		ψ4 = Simplify[ψ[[4]]];
		(* Print[ψ1 ];
		Print[ψ2 ];
		Print[ψ3 ];
		Print[ψ4 ]; *)
			
eqn1 = Simplify[(1/(m^2c^4)(((E-V  )^2 - m^2 c^4) ψ1 + c^2  hbar^2 ((ddx[{ψ1},r,θ,ϕ])^2+(ddy[{ψ1},r,θ,ϕ])^2 + (ddz[{ψ1},r,θ,ϕ] )^2) ))/.{hbar->(Subscript[a, 0]) α c m}/. α-> 1/137.035999 ];
eqn2 = Simplify[(1/(m^2c^4)(((E-V  )^2 - m^2 c^4) ψ2 + c^2  hbar^2 ((ddx[{ψ2},r,θ,ϕ])^2+(ddy[{ψ2},r,θ,ϕ])^2 + (ddz[{ψ2},r,θ,ϕ] )^2) ))/.{hbar->(Subscript[a, 0]) α c m}/. α-> 1/137.035999];
eqn3 = Simplify[(1/(m^2c^4)(((E-V  )^2 - m^2 c^4) ψ3 + c^2  hbar^2 ((ddx[{ψ3},r,θ,ϕ])^2+(ddy[{ψ3},r,θ,ϕ])^2 + (ddz[{ψ3},r,θ,ϕ] )^2) ))/.{hbar->(Subscript[a, 0]) α c m}/. α-> 1/137.035999 ];
eqn4 = Simplify[(1/(m^2c^4)(((E-V  )^2 - m^2 c^4) ψ4 + c^2  hbar^2 ((ddx[{ψ4},r,θ,ϕ])^2+(ddy[{ψ4},r,θ,ϕ])^2 + (ddz[{ψ4},r,θ,ϕ] )^2) ))/.{hbar->(Subscript[a, 0]) α c m}/. α-> 1/137.035999 ];
		
		{eqn1,eqn2,eqn3,eqn4}
];



(* Dirac Solution, Independent components, relative to Schrodinger *)

ψDiracRadial[{n_, l_, ml_,mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff},
		ff = Simplify[f[r, n, EnergyDirac[n, j], kappa]/.{hbar->(Subscript[a, 0]) α c m}];
		ff];


Clear[ψDiracSpinor1,ψDiracSpinor1,ψDiracSpinor1,ψDiracSpinor1];
ψDiracSpinor1[{n_, l_, ml_,mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
		  Module[{lprime},
		lprime = 2j-l; 
                  (* If [j==(l+1/2),Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandau[l, mj-1/2, θ,ϕ],
       		(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandau[l, mj-1/2, θ,ϕ]] *)
		If [j==(l+1/2),If[ j+mj==0 ,0,Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandau[l, mj-1/2, θ,ϕ] ], 
		    If[ j-mj+1==0 ,0,(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandau[l, mj-1/2, θ,ϕ]] ]
                  ];
ψDiracSpinor2[{n_, l_, ml_,mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
		  Module[{lprime},
		lprime = 2j-l; 
                  (* If [j==(l+1/2),Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandau[l, mj+1/2, θ,ϕ],
		Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandau[l, mj+1/2, θ,ϕ]  ] *)
		If [j==(l+1/2),If[ j-mj == 0,0,Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandau[l, mj+1/2, θ,ϕ]],
		If[ j+mj+1==0,0,Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandau[l, mj+1/2, θ,ϕ] ] ]
                  ];
ψDiracSpinor3[{n_, l_, ml_,mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
		  Module[{lprime},
		lprime = 2j-l; 
                  (* If [j==(lprime+1/2),Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandau[lprime, mj-1/2, θ,ϕ], 
		(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandau[lprime, mj-1/2, θ,ϕ] ] *)
		If [j==(lprime+1/2),If[ j+mj==0 ,0,If[j+mj==0,0,Sqrt[(j+mj)/(2j) ]SphericalHarmonicYLandau[lprime, mj-1/2, θ,ϕ]]], 
		If[ j-mj+1==0 ,0,(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicYLandau[lprime, mj-1/2, θ,ϕ]] ]
                  ];
ψDiracSpinor4[{n_, l_, ml_,mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
		  Module[{lprime},
		lprime = 2j-l; 
                  (* If [j==(lprime+1/2),Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandau[lprime, mj+1/2, θ,ϕ],
		Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandau[lprime, mj+1/2, θ,ϕ]  ] *)
		If [j==(lprime+1/2),If[j-mj==0,0,Sqrt[(j-mj)/(2j) ]SphericalHarmonicYLandau[lprime, mj+1/2, θ,ϕ]],
		If[j+mj+1==0,0,Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicYLandau[lprime, mj+1/2, θ,ϕ]]  ]
                  ];

ψDiracAngular[{n_, l_, ml_,mj_, j_, kappa_, form_}, r_, θ_,ϕ_] :=    
	Module[{E, lambda, rho, gamma, nr,lprime, term1},
		E = EnergyDirac[n, j];  (* use the better simplified version *)
		lambda = Simplify[m c^2 Sqrt[1 - (E/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
		rho = 2 lambda r;
		gamma = Sqrt[kappa^2 - α^2];
		nr = n-Abs[kappa];
		term1 = Simplify[(gamma + nr)/(E/(m c^2))];  (* the  Z α m / lambda term *)

		lprime = 2j-l;
		energyTerm = Sqrt[1 + 1/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2] ];
		energyTerm2 = Sqrt[1 + Sqrt[(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]/Sqrt[((n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2+(α^2))] ];
		energyTerm3 = Sqrt[1 - 1/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2] ];
		energyTerm4 = Sqrt[1 - Sqrt[(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2]/Sqrt[((n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2+(α^2))] ];
		(* ψDiracSpinor1 = If [j==(l+1/2),Sqrt[(j+mj)/(2j) ]SphericalHarmonicY[l, mj-1/2, θ,ϕ],
		(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicY[l, mj-1/2, θ,ϕ]];
		ψDiracSpinor2 = If [j==(l+1/2),Sqrt[(j-mj)/(2j) ]SphericalHarmonicY[l, mj+1/2, θ,ϕ],
		Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicY[l, mj+1/2, θ,ϕ]  ];
		ψDiracSpinor3 = If [j==(lprime+1/2),Sqrt[(j+mj)/(2j) ]SphericalHarmonicY[lprime, mj-1/2, θ,ϕ], 
		(-Sqrt[(j-mj  + 1)/(2j + 2) ])SphericalHarmonicY[lprime, mj-1/2, θ,ϕ] ];
		ψDiracSpinor4 = If [j==(lprime+1/2),Sqrt[(j-mj)/(2j) ]SphericalHarmonicY[lprime, mj+1/2, θ,ϕ],
		Sqrt[(j+mj +1)/(2j+2) ]SphericalHarmonicY[lprime, mj+1/2, θ,ϕ]  ]; *)
		FtermPlus = ((term1- kappa)Hypergeometric1F1 [-nr,2 gamma+1,2 lambda r]+ nr Hypergeometric1F1 [1-nr,2 gamma+1,2 lambda r]);
	         FtermMinus = ((term1 - kappa)Hypergeometric1F1 [-nr,2 gamma+1,2 lambda r]- nr Hypergeometric1F1 [1-nr,2 gamma+1,2 lambda r]);
		ψSpinorDenominator = If [ mj==1/2,ψDiracSpinor1[{n, l, ml,mj, j, kappa}, r, θ,ϕ],  ψDiracSpinor2[{n, l, ml,mj, j, kappa}, r, θ,ϕ]];
		(* ψSpinor1 = ψDiracSpinor1[{n, l, ml,mj, j, kappa}, r, θ,ϕ]/ ψSpinorDenominator;
		ψSpinor2 = ψDiracSpinor2[{n, l, ml,mj, j, kappa}, r, θ,ϕ] / ψSpinorDenominator;
		ψSpinor3 = ψDiracSpinor3[{n, l, ml,mj, j, kappa}, r, θ,ϕ] / ψSpinorDenominator;
		ψSpinor4 = ψDiracSpinor4[{n, l, ml,mj, j, kappa}, r, θ,ϕ] / ψSpinorDenominator; *)
		ψSpinor1Minus = ψDiracSpinor1[{n, l, ml,ml-1/2, j, kappa}, r, θ,ϕ];
		ψSpinor2Minus = ψDiracSpinor2[{n, l, ml,ml-1/2, j, kappa}, r, θ,ϕ] ;
		ψSpinor3Minus = ψDiracSpinor3[{n, l, ml,ml-1/2, j, kappa}, r, θ,ϕ] ;
		ψSpinor4Minus = ψDiracSpinor4[{n, l, ml,ml-1/2, j, kappa}, r, θ,ϕ] ;
		ψSpinorMinus = MatrixForm[{ψSpinor1Minus,ψSpinor2Minus,ψSpinor3Minus,ψSpinor4Minus}];
		ψSpinor1Plus = ψDiracSpinor1[{n, l, ml,ml+1/2, j, kappa}, r, θ,ϕ];
		ψSpinor2Plus = ψDiracSpinor2[{n, l, ml,ml+1/2, j, kappa}, r, θ,ϕ] ;
		ψSpinor3Plus = ψDiracSpinor3[{n, l, ml,ml+1/2, j, kappa}, r, θ,ϕ] ;
		ψSpinor4Plus = ψDiracSpinor4[{n, l, ml,ml+1/2, j, kappa}, r, θ,ϕ] ;
		ψSpinorPlus = MatrixForm[{ψSpinor1Plus,ψSpinor2Plus,ψSpinor3Plus,ψSpinor4Plus}];
		ψ34Normalizer =  (Refine[(-1)^(1/2(1+l-lprime))Simplify[(energyTerm4*energyTerm2)],Assumptions->α>0]/Simplify[(energyTerm2^2)]  (- FtermPlus) / FtermMinus  );
		M = {{ψSpinor1Plus,ψSpinor2Plus,ψSpinor3Plus,ψSpinor4Plus},{ψSpinor1Minus,ψSpinor2Minus,ψSpinor3Minus,ψSpinor4Minus}};
		(* N1= Simplify[RowReduce[M]]; *) (* NOPE, don't do this *)
		N1 =  M;
		ψSpinor1 = If[mj==ml-1/2,N1[[2,1]],N1[[1,1]]];
		ψSpinor2 = If[mj==ml-1/2,N1[[2,2]],N1[[1,2]]];
		ψSpinor3 = If[mj==ml-1/2,N1[[2,3]],N1[[1,3]]];
		ψSpinor4 = If[mj==ml-1/2,N1[[2,4]],N1[[1,4]]];
		 (* Print["n=",n,"   l=",l,"   ml=",ml,"   j=",j,"   mj=",mj]; *)
		(*
		Print[ "      ψDiracSpinor1 = ",ψDiracSpinor1[{n, l, ml,mj, j, kappa}, r, θ,ϕ]];
		Print[ "      ψDiracSpinor2 = ",ψDiracSpinor2[{n, l, ml,mj, j, kappa}, r, θ,ϕ]];
		Print[ "      ψDiracSpinor3 = ",ψDiracSpinor3[{n, l, ml,mj, j, kappa}, r, θ,ϕ]];
		Print[ "      ψDiracSpinor4 = ",ψDiracSpinor4[{n, l, ml,mj, j, kappa}, r, θ,ϕ]];
		Print[ "       ψSpinorMinus = ",ψSpinorMinus, "       ψSpinorPlus = ",ψSpinorPlus];
		*)
		(*
		Print ["     M = ",MatrixForm[M], "      N = ",MatrixForm[N1]]; 
		Print ["N = ",MatrixForm[N1]]; 
		*)
		(*
        Print[N1[[1,1]],"  ",N1[[1,2]],"  ",N1[[1,3]],"  ",N1[[1,4]]];
  	  Print[N1[[2,1]],"  ",N1[[2,2]],"  ",N1[[2,3]],"  ",N1[[2,4]]];
  	  Print[ "           ψSpinor1 = ",ψSpinor1];
		Print[ "           ψSpinor2 = ",ψSpinor2];
		Print[ "           ψSpinor3 = ",ψSpinor3];
		Print[ "           ψSpinor4 = ",ψSpinor4];
		Print[ "      ψ34Normalizer = ",ψ34Normalizer]; 
		*)

		If[form==0,{MatrixForm[{ψSpinor1,ψSpinor2}],ψ34Normalizer*MatrixForm[{ ψSpinor3, ψSpinor4}]} , 
                                                MatrixForm[{ψSpinor1,ψSpinor2, ψ34Normalizer*ψSpinor3, ψ34Normalizer*ψSpinor4}]]   
	     
	];

ψDiracRadialModifier[{n_, l_, ml_,mj_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff},
		ff = Simplify[ψDiracRadial[{n, l, ml,mj, j, kappa}, r,  θ,ϕ]/  ψSchrodingerRadial[{n,l,ml}, r,  θ,ϕ],{Element[α,Reals],Re[α]>0,Re[α]<1}];
		ff];

ψDiracAngularModifier[{n_, l_, ml_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff, gg,down, up, both},
		ff = ψDiracAngular[{n, l, ml,ml-1/2, j, kappa,1}, r,  θ,ϕ][[1]];
		gg= ψDiracAngular[{n, l, ml,ml+1/2, j, kappa,1}, r,  θ,ϕ][[1]];
		(* Print["ff = ",ff,"         gg = ",gg]; *)
		down = Simplify[ff/  ψSchrodingerAngular[{n,l,ml}, r,  θ,ϕ],{Element[α,Reals],Re[α]>0,Re[α]<1}];
		up = Simplify[gg/  ψSchrodingerAngular[{n,l,ml}, r,  θ,ϕ],{Element[α,Reals],Re[α]>0,Re[α]<1}];
		{MatrixForm[down],MatrixForm[up]}];

ψDiracAngularModifierCanonical[{n_, l_, ml_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff, gg,M,N1,both},
		ff = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[1,1]];
		gg = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[2,1]];
		(* Print["ff = ",ff,"        gg = ",gg]; *)
		M = {gg,ff};
		N1= Simplify[RowReduce[M]]; 
		(* Print["M = ",M,"        N1 = ",N1]; *)
		both = {MatrixForm[{N1[[2,1]],N1[[2,2]],N1[[2,3]],N1[[2,4]]}] ,MatrixForm[{N1[[1,1]],N1[[1,2]],N1[[1,3]],N1[[1,4]]}] };
		both];

ψDiracAngularModifierCanonicalFull[{n_, l_, ml_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff, gg,M,N1,all},
		ff = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[1,1]];
		gg = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[2,1]];
		(* Print["ff = ",ff,"        gg = ",gg]; *)
		M = {gg,ff};
		N1= Simplify[RowReduce[M]]; 
		(* Print["M = ",M,"        N1 = ",N1]; *)
		all = {MatrixForm[{N1[[2,1]],N1[[2,2]],N1[[2,3]],N1[[2,4]]}] ,MatrixForm[{N1[[1,1]],N1[[1,2]],N1[[1,3]],N1[[1,4]]}] ,       MatrixForm[{N1[[2,3]],N1[[2,4]],N1[[2,1]],N1[[2,2]]}] ,MatrixForm[{N1[[1,3]],N1[[1,4]],N1[[1,1]],N1[[1,2]]}]};
		all];

ψDiracAngularModifierCanonicalFullWithB[{n_, l_, ml_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff, gg,M,N1,all, gamma, term3, B1},
		ff = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[1,1]];
		gg = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[2,1]];
		(* Print["ff = ",ff,"        gg = ",gg]; *)
		gamma = Sqrt[kappa^2 - α^2];
		M = {gg,ff};
		N1= Simplify[RowReduce[M]]; 
		(* Print["M = ",M,"        N1 = ",N1]; *)
		term3 = N1[[1,3]];
		B1 = Simplify[term3 / (I Cos[θ])];
		all = {MatrixForm[{N1[[2,1]],N1[[2,2]],Simplify[N1[[2,3]]/B1] B ,Simplify[N1[[2,4]]/B1] B}] ,MatrixForm[{N1[[1,1]],N1[[1,2]],Simplify[N1[[1,3]]/B1] B,Simplify[N1[[1,4]]/B1] B}] ,       MatrixForm[{Simplify[N1[[2,3]]/B1] B,Simplify[N1[[2,4]]/B1] B,N1[[2,1]],N1[[2,2]]}] ,MatrixForm[{Simplify[N1[[1,3]]/B1] B,Simplify[N1[[1,4]]/B1] B,N1[[1,1]],N1[[1,2]]}]};
		all];

ψDiracAngularModifierCanonicalFullB[{n_, l_, ml_, j_, kappa_}, r_, θ_,ϕ_] :=  
	Module[{ff, gg,M,N1,all, gamma, term3, B1},
		ff = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[1,1]];
		gg = ψDiracAngularModifier[{n, l, ml, j, kappa}, r,  θ,ϕ][[2,1]];
		(* Print["ff = ",ff,"        gg = ",gg]; *)
		gamma = Sqrt[kappa^2 - α^2];
		M = {gg,ff};
		N1= Simplify[RowReduce[M]]; 
		(* Print["M = ",M,"        N1 = ",N1]; *)
		term3 = N1[[1,3]];
		B1 = Simplify[term3 / (I Cos[θ])];
		B1];

eqnDiracGeneral[{ψ_, n_, l_, ml_, mj_, j_, kappa_}, r_, θ_,ϕ_]  := 
	Module[{E,V,ψ1,ψ2,ψ3,ψ4},
		E = (m c ^2)/Sqrt[1+(α^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-α^2])^2];
		V = -hbar^2/(m (Subscript[a, 0])r); 
		
		eqn1 = Simplify[(-E ψ1 - c I hbar (ddx[{ψ4},r,θ,ϕ]-I ddy[{ψ4},r,θ,ϕ] + ddz[{ψ3},r,θ,ϕ] ) + V ψ1 + m c^2 ψ1)/.{hbar->(Subscript[a, 0]) α c m} ];
		eqn2 = Simplify[(-E ψ2 - c I hbar (ddx[{ψ3},r,θ,ϕ]+I ddy[{ψ3},r,θ,ϕ] - ddz[{ψ4},r,θ,ϕ] ) + V ψ2 + m c^2 ψ2)/.{hbar->(Subscript[a, 0]) α c m}];
		eqn3 = Simplify[(-E ψ3 - c I hbar (ddx[{ψ2},r,θ,ϕ]-I ddy[{ψ2},r,θ,ϕ] + ddz[{ψ1},r,θ,ϕ] ) + V ψ3 - m c^2 ψ3)/.{hbar->(Subscript[a, 0]) α c m} ];
		eqn4 = Simplify[(-E ψ4 - c I hbar (ddx[{ψ1},r,θ,ϕ]+I ddy[{ψ1},r,θ,ϕ] - ddz[{ψ2},r,θ,ϕ] ) + V ψ4 - m c^2 ψ4)/.{hbar->(Subscript[a, 0]) α c m}]; 
		
		{eqn1,eqn2,eqn3,eqn4}
];

(* Checks and Comparisons between solutions *)
ratioCheck[{a_,b_}]:= Module[{},
ratio = Quiet[a/b];
ratio];


RatioVector2[{n_, l_, ml_}, r_, θ_,ϕ_] :=  
	Module[{kappa,j},
		If[Mod[(l+Abs[ml]),2]==0, 
			j=l+1/2; kappa = -(l+1),
			j=Abs[l-1/2]; kappa = l];
		mjplus = ml+1/2;
		mjminus = ml - 1/2;
		term1 = ψDiracRadial[{n,l,ml,mj,j,kappa}, r,  θ,ϕ];
		FullSolution1Minus1= Expand[term1*Simplify[ψDiracAngular[{n,l,ml,mjminus,j, kappa,1}, r,  θ,ϕ]][[1,1]]];
		FullSolution1Minus2= Expand[term1*Simplify[ψDiracAngular[{n,l,ml,mjminus,j, kappa,1}, r,  θ,ϕ]][[1,2]]];
		FullSolution1Minus3= Expand[term1*Simplify[ψDiracAngular[{n,l,ml,mjminus,j, kappa,1}, r,  θ,ϕ]][[1,3]]];
		FullSolution1Minus4= Expand[term1*Simplify[ψDiracAngular[{n,l,ml,mjminus,j, kappa,1}, r,  θ,ϕ]][[1,4]]];
		FullSolution1Minus = Simplify[{FullSolution1Minus1, FullSolution1Minus2,FullSolution1Minus3,FullSolution1Minus4}](*/.{α->1/137,r->10^-10,(Subscript[a, 0])->10^-10}//N*);

		term2 = term1;
		FullSolution1Plus1= Expand[term2*Simplify[ψDiracAngular[{n,l,ml,mjplus,j, kappa,1}, r,  θ,ϕ]][[1,1]]];
		FullSolution1Plus2= Expand[term2*Simplify[ψDiracAngular[{n,l,ml,mjplus,j, kappa,1}, r,  θ,ϕ]][[1,2]]];
		FullSolution1Plus3= Expand[term2*Simplify[ψDiracAngular[{n,l,ml,mjplus,j, kappa,1}, r,  θ,ϕ]][[1,3]]];
		FullSolution1Plus4= Expand[term2*Simplify[ψDiracAngular[{n,l,ml,mjplus,j, kappa,1}, r,  θ,ϕ]][[1,4]]];
		FullSolution1Plus =Simplify[{FullSolution1Plus1, FullSolution1Plus2,FullSolution1Plus3,FullSolution1Plus4}](*/.{α->1/137,r->10^-10,(Subscript[a, 0])->10^-10}//N*);
		
		FullSolution2Minus = Simplify[ψDirac[{n,l,mjminus,j, kappa}, r,  θ,ϕ]](*/.{α->1/137,r->10^-10,(Subscript[a, 0])->10^-10}//N*);
		FullSolution2Plus = Simplify[ψDirac[{n,l,   mjplus,j, kappa}, r,  θ,ϕ]](*/.{α->1/137,r->10^-10,(Subscript[a, 0])->10^-10}//N*);
		(*
                Print[FullSolution1Minus[[3]],"       ",FullSolution2Minus[[3]] ];
                Print[FullSolution1Minus[[4]],"       ",FullSolution2Minus[[4]] ]; *)


		Simplify[Refine[Simplify[MatrixForm[{{ratioCheck[{FullSolution1Minus[[1]],FullSolution2Minus[[1]]}],ratioCheck[{FullSolution1Plus[[1]],FullSolution2Plus[[1]]}]},
					{ratioCheck[{FullSolution1Minus[[2]],FullSolution2Minus[[2]]}],ratioCheck[{FullSolution1Plus[[2]],FullSolution2Plus[[2]]}]},
					{ratioCheck[{FullSolution1Minus[[3]],FullSolution2Minus[[3]]}],ratioCheck[{FullSolution1Plus[[3]],FullSolution2Plus[[3]]}]},
					{ratioCheck[{FullSolution1Minus[[4]],FullSolution2Minus[[4]]}],ratioCheck[{FullSolution1Plus[[4]],FullSolution2Plus[[4]]}]}
				}]],Assumptions->α>0    ]/.{α->1/137,r->10^-10,(Subscript[a, 0])->10^-10}]
		
		];

SelfEnergyCarver[{n_, l_, mj_, j_, kappa_}, r_, θ_,ϕ_]  := Module[{ψ,ψstar,c1,c2,c3,c4, ψ1, ψ2, ψ3, ψ4, ψ1star, ψ2star, ψ3star, ψ4star, selfEnergy},
ψ =  ψDirac[{n, l, mj, j, kappa}, r,  θ,ϕ];
ψstar =  ψDiracStar[{n, l, mj, j, kappa}, r,  θ,ϕ]; 
(* Print["       ψ = ",ψ];
Print["   ψstar = ",ψstar]; *)
ψ1 = ψ[[1]];
ψ2 = ψ[[2]];
ψ3 = ψ[[3]];
ψ4 = ψ[[4]];
ψ1star = ψstar[[1]];
ψ2star = ψstar[[2]];
ψ3star = ψstar[[3]];
ψ4star = ψstar[[4]];

c1 = q^3 / (4 Pi Epsilon0)Integrate[ψ1star ψ1 r Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
c2 = q^3 / (4 Pi Epsilon0)Integrate[ψ2star ψ2 r Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
c3 = q^3 / (4 Pi Epsilon0)Integrate[ψ3star ψ3 r Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
c4 = q^3 / (4 Pi Epsilon0)Integrate[ψ4star ψ4 r Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}]; 
(* Print["       c1 = ",c1]; *)
(* Print["       c2 = ",c2];
Print["       c3 = ",c3];
Print["       c4 = ",c4]; *)
c1 = Simplify[c1,Re[(Subscript[a, 0]) ]>0]; 
c2 = Simplify[c2,Re[(Subscript[a, 0]) ]>0]; 
c3 = Simplify[c3,Re[(Subscript[a, 0]) ]>0]; 
c4 = Simplify[c4,Re[(Subscript[a, 0]) ]>0]; 
selfEnergy = Simplify[c1 + c2 + c3 + c4];
selfEnergy
];

SelfEnergyCarverTEST[{n_, l_, mj_, j_, kappa_}, r_, θ_,ϕ_]  := Module[{ψ,ψstar,c1,c2,c3,c4, ψ1, ψ2, ψ3, ψ4, ψ1star, ψ2star, ψ3star, ψ4star, selfEnergy},
ψ =  ψDirac[{n, l, mj, j, kappa}, r,  θ,ϕ];
ψstar =  ψDiracStar[{n, l, mj, j, kappa}, r,  θ,ϕ]; 

ψ1 = ψ[[1]];
ψ2 = ψ[[2]];
ψ3 = ψ[[3]];
ψ4 = ψ[[4]];
ψ1star = ψstar[[1]];
ψ2star = ψstar[[2]];
ψ3star = ψstar[[3]];
ψ4star = ψstar[[4]];

c1 = q^3 / (4 Pi Epsilon0)Integrate[ψ1star ψ1 r Sin[θ],{ϕ,0,2 π},{θ,0,π},{r,0,Infinity}];
Print["       c1 = ",c1];

];

(*PHYSICAL PARAMETERS*)
h=6.62606896*10^(-34);                                                                                                                                          (*Planck's constant in J s*)
hbar=h/(2 Pi);                                                                                                                                                               (*reduced Planck's constant in J s*)
e=1.60217653*10^(-19);                                                                                                                                           (*charge on electron in Coulombs*)
m=9.10938215*10^(-31);                                                                                                                                           (*mass of electron in kg*)
c=299792458;                                                                                                                                                                  (*speed of light in m/s*)
(Subscript[μ, 0])=4 Pi 10^(-7);                                                                                                                                                             (*magnetic constant in N/Ampere^2*)
w0=m c^2/hbar;                                                                                                                                                              (*w0 in rad/s*)
(Subscript[ϵ, 0])=8.854187817620*10^(−12);                                                                                                                                (*permittivity of free space,in F/m*)
mp=1.67262178*10^(-27);                                                                                                                                         (*mass of proton in kg*)
rp=0.8768*10^(-15);                                                                                                                                                     (*radius of proton in m*)
μ=mp/m;                                                                                                                                                                            (* proton-to-electron mass ratio *)
mr = mp m/(mp + m);                                                                                                                                                     (* reduced mass of the electron *)
mt = mp +m;                                                                                                                                                                      (* total mass of electron plus proton *)
a0=4*Pi*((Subscript[ϵ, 0]))*(hbar^2)/(mr*(e^2));                                                                                                             (*first Bohr radius in meters*)
rc = a0/μ;                                                                                                                                                                        (* cutoff radius *)
R00 = 2/a0^(3/2);                                                                                                                                                       (* Radial normalization factor for Hydrogen ground state *)
R20 = 1/(2 Sqrt[2] a0^(3/2));                                                                                                                              (* Radial normalization factor for Hydrogen 2S state *)



R=1.00;                                                                                                                                                                              (* atomic spacing in meters *)
A0=((Subscript[μ, 0]) e hbar 8 Sqrt[2])/(Pi mr R a0 81);                                                                                                           (* Vector potential baseline value in kg m/(Coulomb second) *)
alpha=e^2/(4 Pi ((Subscript[ϵ, 0])) hbar c);                                                                                                                                 (* Fine Structure Constant,unitless *)
(Subscript[E, 0])=-mr (e^4)/(8 ((Subscript[ϵ, 0]))^2 h^2);                                                                                                                                (* Schrodinger ground state energy in J (Rydberg constant) *)
Ejn=(Subscript[E, 0])/(n^2)*(1+(alpha^2/n^2)*((n/(j+1/2))-3/4));                                                                  (* Dirac Energy in J *)Ejna=(mr c^2)/Sqrt[1+(alpha^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-alpha^2])^2]-(mr c^2);  (* Dirac Energy in J-alternate form (uses reduced mass) *)

fb[n_,j_]:=   1/Sqrt[1+(alpha^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-alpha^2])^2];               (* Dirac Energy with Barker and Glover (1955) Two-Body Correction *)
Ejnb[n_,j_,l_]:= Module[{kappa,lastterm},
kappa=(((-1))^(j-l+(1/2)))(j+(1/2));  
Print["-------- Ejnb calculation --------------------------------"];
Print["n = ",n,"   j = ",j,"    l = ",l];
Print["kappa = ",kappa];
Print["KroneckerDelta[l,0] = ",KroneckerDelta[l,0]];
lastterm = (((1-KroneckerDelta[l,0])(alpha^4)(mr^3)(c^2))/((kappa (2 l+1))2(n^3)(mp^2)));
Print["lastterm = ",lastterm];
mt (c^2) + (fb[n,j]-1)mr (c^2)- (((((fb[n,j]-1))^2)(mr^2) (c^2))/(2 mt))+(((1-KroneckerDelta[l,0])(alpha^4)(mr^3)(c^2))/((kappa (2 l+1))2(n^3)(mp^2)))-mt (c^2)
];

LambShiftHz = 1057.85*10^6;                                                                                                                                 (* measured Lamb Shift in Hz, from Mohr 1975 (1057.864), 
                                                                                        Niering 2000 (1057.85), Karshenboim 2005 summary *)
transition1S2SHz = 2.466061413187035*^15;                                                                                                    (* Transition frequency for 1S-2S transition in Hz from Parthey 2011*)

hydrogenDeuteriumIsotopeShiftHz = 670994334606 ;                                                                                   (*  E1s2sD - E1s2sH from Parthey 2010 *)
transition1S2SHzDeuterium = transition1S2SHz+hydrogenDeuteriumIsotopeShiftHz;
GroundStateShiftHz = 8172.874*10^6;                                                                                                               (* 1S shift in Hydrogen from Weitz 1995 *)
GroundStateShiftHzDeuterium = 8183.807*10^6;                                                                                            (* 1S shift in Deuterium from Weitz 1995 *)
LambShiftHzDeuterium = 1059.36*10^6;                                                                                                              (* measured Lamb Shift in Hz in Deuterium, 
                                                                                         from Wijngaarden and Drake, 1977 *)


R00val = R00;
R20val = R20;
a0val = a0;
hbarval = hbar;
mval = m;
rcval = rc;
μval = μ;
mrval = mr;
cval = c;

(* Schrodinger Levels *)

nmax = 5;

EnergyArray = Table[- mr (e^4)/(8 (Subscript[ϵ, 0])^2 h^2 (n^2))  ,{n,1,nmax}];
EnergyEVArray = EnergyArray / e;
omegaArray = EnergyArray / hbar; 
fArray = omegaArray / (2 Pi); 

w1 = omegaArray[[1]];
w2 = omegaArray[[2]];
w21 = w2 - w1;  (* frequency difference is all that matters, no absolute zero reference for frequency relevant in this problem *)
f21 = w21 / (2 Pi);
T21 = 1/f21;

Print["a0   = ",a0," meters"];
Print["w0   = ",w0," rad / s"];
Print["EnergyArray = ",EnergyArray," J"];
Print["EnergyEVArray = ",EnergyEVArray," eV"];
Print["omegaArray = ",omegaArray," rad/s"];
Print["fArray = ",fArray," Hz"];
Print["w2   = ",w2," rad / s"];
Print["w1   = ",w1," rad / s"];
Print["w21  = ",w21," rad / s"];
Print["f21  = ",f21," cycle / s"];
Print["T21  = ",T21," s"];

line1 = {{1,EnergyEVArray[[1]]},{2,EnergyEVArray[[1]]}};
lineArray = Table[{{1,EnergyEVArray[[i]]},{Min[nmax,i+1],EnergyEVArray[[i]]}},{i,1,nmax}];
arrowArray = Table[
   Table[Graphics[{Arrowheads[0.025],Arrow[{{j + .2*i,EnergyEVArray[[j]]},{j + .2*i,EnergyEVArray[[i+1]]}}]}],{i,j,nmax-1}]
   ,{j,1,nmax-1}];
plot1 = ListPlot[lineArray,Frame->True, FrameTicks->{False,True},AspectRatio->0.8, Axes->{False,True},Joined->True,
             PlotRange->{0,-14}];
Show[plot1, arrowArray,AspectRatio->2,ImageSize->{250,500}]

(* Schrodinger and Dirac, using conventional reduced mass *)
nmax=3;
EnergyArray=Table[((Subscript[E, 0])/(n^2)),{n,1,nmax}];
EnergyEVArray=(EnergyArray/e);
omegaArray=(EnergyArray/hbar);
fArray=(omegaArray/(2 π));
EnergyArray12=Table[Ejna/. j->(1/2),{n,1,nmax}];
EnergyEVArray12=(EnergyArray12/e);
EnergyEVArrayDiff12=Table[EnergyEVArray12[[n]]-EnergyEVArray[[n]],{n,1,nmax}];
omegaArray12=(EnergyArray12/hbar);
fArray12=(omegaArray12/(2 π));
EnergyArray32=Table[Ejna/. j->(3/2),{n,2,nmax}];
EnergyEVArray32=(EnergyArray32/e);
EnergyEVArrayDiff32=Table[EnergyEVArray32[[n-1]]-EnergyEVArray[[n]],{n,2,nmax}];
omegaArray32=(EnergyArray32/hbar);
fArray32=(omegaArray32/(2 π));
EnergyArray52=Table[Ejna/. j->(5/2),{n,3,nmax}];
EnergyEVArray52=(EnergyArray52/e);
EnergyEVArrayDiff52=Table[EnergyEVArray52[[n-2]]-EnergyEVArray[[n]],{n,3,nmax}];
omegaArray52=(EnergyArray52/hbar);
fArray52=(omegaArray52/(2 π));
EnergyArray12a=Table[Ejna/. j->(1/2),{n,1,nmax}];
EnergyEVArray12a=(EnergyArray12a/e);
EnergyEVArrayDiff12a=Table[EnergyEVArray12a[[n]]-EnergyEVArray[[n]],{n,1,nmax}];
EnergyArray32a=Table[Ejna/. j->(3/2),{n,2,nmax}];
EnergyEVArray32a=(EnergyArray32a/e);
EnergyEVArrayDiff32a=Table[EnergyEVArray32a[[n-1]]-EnergyEVArray[[n]],{n,2,nmax}];
EnergyArray52a=Table[Ejna/. j->(5/2),{n,3,nmax}];
EnergyEVArray52a=(EnergyArray52a/e);
EnergyEVArrayDiff52a=Table[EnergyEVArray52a[[n-2]]-EnergyEVArray[[n]],{n,3,nmax}];
w1=omegaArray[[1]];
w2=omegaArray[[2]];
w21=w2-w1;
f21=(w21/(2 π));
f21Dirac = fArray12[[2]]-fArray12[[1]];
T21=(1/f21);
Print["a0   = ",a0," meters"];
Print["w0   = ",w0," rad / s"];
Print["EnergyArray = ",EnergyArray," J"];
Print["EnergyEVArray = ",N[EnergyEVArray,8]," eV"];
Print["EnergyEVArray12 = ",N[EnergyEVArray12,8]," eV"];
Print["EnergyEVArray32 = ",N[EnergyEVArray32,8]," eV"];
Print["EnergyEVArray52 = ",N[EnergyEVArray52,8]," eV"];
Print["EnergyEVArrayDiff12 = ",N[EnergyEVArrayDiff12,8]," eV"];
Print["EnergyEVArrayDiff32 = ",N[EnergyEVArrayDiff32,8]," eV"];
Print["EnergyEVArrayDiff52 = ",N[EnergyEVArrayDiff52,8]," eV"];
Print["EnergyEVArray12a = ",N[EnergyEVArray12a,8]," eV"];
Print["EnergyEVArray32a = ",N[EnergyEVArray32a,8]," eV"];
Print["EnergyEVArray5a2 = ",N[EnergyEVArray52a,8]," eV"];
Print["omegaArray = ",omegaArray," rad/s"];
Print["fArray12 = ",N[fArray12,8]," Hz"];
Print["fArray32 = ",N[fArray32,8]," Hz"];
Print["fArray52 = ",N[fArray52,8]," Hz"];
Print["w2   = ",w2," rad / s"];
Print["w1   = ",w1," rad / s"];
Print["w21  = ",w21," rad / s"];
Print["f21  = ",InputForm[f21]," cycle / s   (Schrodinger using conventional reduced mass)"];
Print["T21  = ",T21," s"];
Print["f21Dirac  = ",InputForm[f21Dirac]," cycle / s   (Dirac using conventional reduced mass)"];
Print["FineStructureSplitting  = ",fArray32[[1]]-fArray12[[2]]," Hz  -- the size of fine structure splitting f2p3/2-f2p1/2"];
Print["FineStructureSplitting  = ",(fArray32[[1]]-fArray12[[2]])/fArray[[1]]," (Subscript[E, 0])  (fine structure splitting as a fraction of Schrodinger ground state energy"];
Print["FineStructureSplitting  = ",(fArray32[[1]]-fArray12[[2]])/fArray[[1]] EnergyEVArray[[1]]," eV  (fine structure splitting in eV)"];
Print["LambShift  = ",LambShiftHz ," Hz   -- Lamb Shift in Hz, f2s1/2-f2p1/2"];
Print["LambShift = ",LambShiftHz/fArray[[1]] ," (Subscript[E, 0])    (Lamb Shift as a fraction of Schrodinger ground state energy)"];
Print["LambShift = ",LambShiftHz/fArray[[1]]EnergyEVArray[[1]] ," eV    (Lamb Shift in eV)"];
Print["LambShift = ",LambShiftHz h / e  ," eV    (Lamb Shift in eV - LS*h/e)"];
Print["Transition1S2S = ",InputForm[transition1S2SHz]  ," Hz    (1S-2S transition frequency in Hz, measured by Parthey 2011) "];
Print["Transition1S2S = ",transition1S2SHz  h / e," eV    (1S-2S transition frequency in eV) "];
Print["\n\n"];


plotBottom=-17;
plotRight = 8;
aspectRatio = 0.81;
lineArray=Table[{{1,EnergyEVArray[[i]]},{nmax,EnergyEVArray[[i]]}},{i,1,nmax}];
arrowArray=Table[Table[Graphics[{Arrowheads[0.025],Arrow[{{j+.333 i,EnergyEVArray[[j]]},{j+.333 i,EnergyEVArray[[i+1]]}}]}],{i,j,nmax-1}],{j,1,nmax-1}];
plot1=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}},FrameLabel->{"Energy (eV)","Energy Levels for Atomic Hydrogen"}];
diffScale=10000;
lineArray=Table[{{3.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]},{4.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]}},{i,1,nmax}];
plot2=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lineArray=Table[{{5.0,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]},{6.0,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]}},{i,2,nmax}];
plot3=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lineArray=Table[{{5.0,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff32[[i-1]]},{6.0,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff32[[i-1]]}},{i,2,nmax}];
plot4=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lineArray=Table[{{6.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff32[[i-1]]},{7.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff32[[i-1]]}},{i,3,nmax}];
plot5=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lineArray=Table[{{6.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff52[[i-2]]},{7.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff52[[i-2]]}},{i,3,nmax}];
plot6=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lambshiftplot = 0.06;
lineArray=Table[{{3.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]+(5-2i)lambshiftplot},{4.5,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]+(5-2i)lambshiftplot}},{i,1,2}];
plot7=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},PlotStyle->{{Blue,Dashing[Tiny]},{Purple,Dashing[Tiny]}},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lineArray=Table[{{3.02,EnergyEVArray[[i]]},{3.48,EnergyEVArray[[i]]+diffScale EnergyEVArrayDiff12[[i]]}},{i,1,3}];
plot8=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},PlotStyle->{Gray},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];
lineArray=Table[{{3.02,EnergyEVArray[[2]]},{3.48,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[i]]}},{i,1,1}];
plot9=ListPlot[lineArray,Frame->True,FrameTicks->{False,True},PlotStyle->{Gray},AspectRatio->aspectRatio,Axes->{False,True},Joined->True,PlotRange->{{0.8,plotRight},{0,plotBottom}}];


text01=Graphics[Text["n=1",{1.1,EnergyEVArray[[1]]+.24}]];
text02=Graphics[Text["n=2",{1.1,EnergyEVArray[[2]]+.24}]];
text03=Graphics[Text["n=3",{1.1,EnergyEVArray[[3]]+.24}]];
text04=Graphics[Text["1 S 1/2",{4.75,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]}]];
text05=Graphics[Text["2 S 1/2",{4.75,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]}]];
text06=Graphics[Text["3 S 1/2",{4.75,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]}]];
text07=Graphics[Text["2 P 1/2",{6.25,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]}]];
text08=Graphics[Text["3 P 1/2",{6.25,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]}]];
text09=Graphics[Text["2 P 3/2",{6.25,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[1]]}]];
text10=Graphics[Text["3 P 3/2",{6.25,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+.2}]];
text11=Graphics[Text["3 D 3/2",{7.75,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]}]];
text12=Graphics[Text["3 D 5/2",{7.75,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+.25}]];
text13=Graphics[Text["Energy shifts magnified 10000X",{6.75,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]}]];
text14=Graphics[Text["Levels split based on j, even/oddness of ml",{6.75,-0.35+EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]}]];
text14a=Graphics[Text["Arrows represent spin-down / spin-up states",{6.75,-0.70+EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]}]];
text15a=Graphics[Text["Schrodinger",{2,-.5}]];
text15b=Graphics[Text["Dirac",{5.5,-.5}]];
(* text16=Graphics[{Gray,Text["(degenerate with 2 S 1/2)",{7.06,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]}]}];
text17a=Graphics[{Gray,Text["(Lamb Shift",{4.0,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+.6}]}];
text17b=Graphics[{Gray,Text["breaks degeneracy)",{4.0,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+.3}]}];
*)
text18a=Graphics[{Gray,Text["(Subscript[E, 1]) = -13.6 eV",{2.6,-13.9}]}];
text18b=Graphics[{Gray,Text["(Subscript[E, 2]) = -3.4 eV",{2.6,-3.7}]}];
text18c=Graphics[{Gray,Text["(Subscript[E, 3]) = -1.5 eV",{2.6,-1.28}]}];
text19a=Graphics[{Gray,Text["Lamb Shift = 4.375 μeV",{4.3,-5.5}]}];
text19b=Graphics[{Gray,Text["                     = 1057.85 MHz",{4.3,-5.9}]}];
text20=Graphics[{Gray,Text["Fine Structure Splitting = 45.28 μeV",{6.05,-5.5}]}];
text21=Graphics[{Gray,Text["(Ground State Shift)",{4.0,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+.4}]}];
text22a=Graphics[{Gray,Text["1S-2S Transition = 10.2 eV",{4.2,-9.5}]}];
text22b=Graphics[{Gray,Text["                                                     = 2 466 061 413 187 035 Hz",{4.2,-9.9}]}];
arrowTop=-.5;
arrowBottom=-0.1;
arrowTop2=0.1;
arrowBottom2=.5;
arrowSpacing=0.07;
arrowHeadSize=0.010;
arrow01=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{3.6,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowBottom},{3.6,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowTop}}]}];
arrow02=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{3.6+arrowSpacing,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowTop},{3.6+arrowSpacing,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowBottom}}]}];
arrow03=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{3.6,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowBottom},{3.6,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowTop}}]}];
arrow04=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{3.6+arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowTop},{3.6+arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowBottom}}]}];
arrow05=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{3.6,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowBottom},{3.6,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowTop}}]}];
arrow06=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{3.6+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowTop},{3.6+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowBottom}}]}];
arrow07=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowBottom},{5.1+arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowTop}}]}];
arrow08=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+2 arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowTop},{5.1+2 arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+arrowBottom}}]}];
arrow09=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowBottom},{5.1+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowTop}}]}];
arrow10=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowTop},{5.1+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff12[[3]]+arrowBottom}}]}];
arrow11=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2},{5.1,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2}}]}];
arrow12=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2},{5.1+arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2}}]}];
arrow13=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+2 arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2},{5.1+2 arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2}}]}];
arrow14=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+3 arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2},{5.1+3 arrowSpacing,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2}}]}];
arrow15=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2},{5.1,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2}}]}];
arrow16=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2},{5.1+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2}}]}];
arrow17=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2},{5.1+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2}}]}];
arrow18=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.1+3 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop2},{5.1+3 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom2}}]}];
arrow19=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom},{6.6+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop}}]}];
arrow20=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop},{6.6+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom}}]}];
arrow21=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+3 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom},{6.6+3 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop}}]}];
arrow22=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+4 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowTop},{6.6+4 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff32[[2]]+arrowBottom}}]}];
arrow23=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowBottom2},{6.6,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowTop2}}]}];
arrow24=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowTop2},{6.6+arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowBottom2}}]}];
arrow25=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowBottom2},{6.6+2 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowTop2}}]}];
arrow26=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+3 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowTop2},{6.6+3 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowBottom2}}]}];
arrow27=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+4 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowBottom2},{6.6+4 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowTop2}}]}];
arrow28=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{6.6+5 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowTop2},{6.6+5 arrowSpacing,EnergyEVArray[[3]]+diffScale EnergyEVArrayDiff52[[1]]+arrowBottom2}}]}];

arrow29=Graphics[{Gray,Arrowheads[{-arrowHeadSize*0.8,arrowHeadSize*0.8}],Arrow[{{5.7,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]},{5.7,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff32[[1]]}}]}];
arrow30=Graphics[{Gray,Arrowheads[{arrowHeadSize*0}],Arrow[{{5.3,-5.3},{5.7,-3.7}}]}];
arrow31=Graphics[{Gray,Arrowheads[{arrowHeadSize*0}],Arrow[{{3.85,-5.3},{4.2,-3.9}}]}];
arrow32=Graphics[{Gray,Arrowheads[{-arrowHeadSize*0.8,arrowHeadSize*0.8}],Arrow[{{3.48,EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+3*lambshiftplot-.04},{3.48,EnergyEVArray[[2]]+diffScale EnergyEVArrayDiff12[[2]]+lambshiftplot+.04}}]}];
arrow33=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.27+4 arrowSpacing,-0.97+EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowBottom2},{5.27+4 arrowSpacing,-0.97+EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowTop2}}]}];
arrow34=Graphics[{Arrowheads[arrowHeadSize],Arrow[{{5.27+5 arrowSpacing,-0.97+EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowTop2},{5.27+5 arrowSpacing,-0.97+EnergyEVArray[[1]]+diffScale EnergyEVArrayDiff12[[1]]+arrowBottom2}}]}];

Show[plot1,arrowArray,plot2,plot3,plot4,plot5,plot6,plot7, plot8, (* plot9,*)text01,text02,text03,text04,text05,text06,text07,text08,text09,text10,text11,text12,text13,text14,text14a,text15a,text15b,(* text16,text17a, text17b,*) text18a, text18b,text18c,text19a, text19b,text20,text21,text22a, text22b,arrow01,arrow02,arrow03,arrow04,arrow05,arrow06,arrow07,arrow08,arrow09,arrow10,arrow11,arrow12,arrow13,arrow14,arrow19,arrow20,arrow15,arrow16,arrow17,arrow18,arrow21,arrow22,arrow23,arrow24,arrow25,arrow26,arrow27,arrow28,arrow29,arrow30,arrow31,arrow32,arrow33,arrow34,AspectRatio->aspectRatio,ImageSize->{800,600}]

Print["\n\n"];

Clear[a0,hbar,c, mr,μ, alpha, e, m, mp, mt];

Print[" "];
Print["Simplest states for Dirac Lyman-Alpha Transition and Lamb Shift:"];
Print[" "];
Print["1S 1/2 :                   ",Simplify[ψDiracRadial[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ],Re[α]>0(* {Element[α,Reals],Re[α]>0,Re[α]<1}*)],"  ",{ ψDiracAngular[{1, 0, 0,-1/2, 1/2, -1, 1}, r, θ,ϕ],ψDiracAngular[{1, 0, 0,1/2, 1/2, -1, 1}, r, θ,ϕ]},"              Energy = ",EnergyDirac[1,1/2]];
Print[" "];
(* Print["2P 1/2 DIRAC (components):         ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]}];
Print[" "]; *)
Print["2S 1/2 :                   ",Simplify[ψDiracRadial[{2,0,0,1/2,1/2,-1}, r,  θ,ϕ],Re[α]>0(* {Element[α,Reals],Re[α]>0,Re[α]<1}*)],"  ",{ ψDiracAngular[{2, 0, 0,-1/2, 1/2, -1, 1}, r, θ,ϕ],ψDiracAngular[{2, 0, 0,1/2, 1/2, -1, 1}, r, θ,ϕ]},"              Energy = ",EnergyDirac[2,1/2]];
Print[" "];
Print["2P 3/2 (ml=-1) :            ",ψDiracRadial[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, -1,-3/2, 3/2, -2, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, -1,-1/2, 3/2, -2, 1}, r, θ,ϕ]},"           Energy = ",EnergyDirac[2,3/2]];
Print[" "];
Print["2P 3/2 (ml=1) :            ",ψDiracRadial[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 1,1/2, 3/2, -2, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 1,3/2, 3/2, -2, 1}, r, θ,ϕ]},"           Energy = ",EnergyDirac[2,3/2]];
Print[" "];
Print[" "];
Print["2P 1/2 (ml=0) :            ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]},"           Energy = ",EnergyDirac[2,1/2]];
Print[" "];
Print[" "];

(* General Expressions for Hydrogen Wavefunctions (Schrodinger and Dirac), with parameter tables *)

Print[" "];
Print["          Simplest states for Dirac Lyman-Alpha Transition (for α=0)                                     Schrodinger solution + Pauli spinors:"];
Print[" "];

diracAngularDown = ψDiracAngular[{1, 0, 0,-1/2, 1/2, -1, 1}, r, θ,ϕ]/.α->0;
diracAngularUp = ψDiracAngular[{1, 0, 0,1/2, 1/2, -1, 1}, r, θ,ϕ]/.α->0;
schrodingerAngular = ψSchrodingerAngular[{1,0,0}, r,  θ,ϕ];

spinorDown1 = diracAngularDown[[1,1]]/schrodingerAngular;
spinorDown2 = diracAngularDown[[1,2]]/schrodingerAngular;
spinorUp1 = diracAngularUp[[1,1]]/schrodingerAngular;
spinorUp2 = diracAngularUp[[1,2]]/schrodingerAngular;
spinorDown = MatrixForm[{spinorDown1,spinorDown2}];
spinorUp = MatrixForm[{spinorUp1,spinorUp2}];

Print["1S 1/2 :                   ",Simplify[ψDiracRadial[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ]/.α->0(* {Element[α,Reals],Re[α]>0,Re[α]<1}*)],"  ",{ ψDiracAngular[{1, 0, 0,-1/2, 1/2, -1, 1}, r, θ,ϕ]/.α->0,ψDiracAngular[{1, 0, 0,1/2, 1/2, -1, 1}, r, θ,ϕ]/.α->0},"                                       ",ψSchrodingerRadial[{1,0,0}, r,  θ,ϕ],"  ",ψSchrodingerAngular[{1,0,0}, r,  θ,ϕ],"                     ",{ spinorDown,spinorUp}];
Print[" "];
(* Print["2P 1/2 DIRAC (components):         ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]}];
Print[" "]; *)

diracAngularDown = ψDiracAngular[{2, 1, -1,-3/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0;
diracAngularUp = ψDiracAngular[{2, 1, -1,-1/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0;
schrodingerAngular = ψSchrodingerAngular[{2,1,-1}, r,  θ,ϕ];

spinorDown1 = diracAngularDown[[1,1]]/schrodingerAngular;
spinorDown2 = diracAngularDown[[1,2]]/schrodingerAngular;
spinorUp1 = diracAngularUp[[1,1]]/schrodingerAngular;
spinorUp2 = diracAngularUp[[1,2]]/schrodingerAngular;
spinorDown = MatrixForm[{spinorDown1,spinorDown2}];
spinorUp = MatrixForm[{spinorUp1,spinorUp2}];
Print["2P 3/2 (ml=-1) :            ",ψDiracRadial[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ]/.α->0,"  ",{ ψDiracAngular[{2, 1, -1,-3/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0,ψDiracAngular[{2, 1, -1,-1/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0},"                 ",ψSchrodingerRadial[{2,1,-1}, r,  θ,ϕ],"  ",ψSchrodingerAngular[{2,1,-1}, r,  θ,ϕ],"       ",{ spinorDown,spinorUp}];
Print[" "];

diracAngularDown = ψDiracAngular[{2, 1, 1,1/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0;
diracAngularUp = ψDiracAngular[{2, 1, 1,3/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0;
schrodingerAngular = ψSchrodingerAngular[{2,1,1}, r,  θ,ϕ];

spinorDown1 = diracAngularDown[[1,1]]/schrodingerAngular;
spinorDown2 = diracAngularDown[[1,2]]/schrodingerAngular;
spinorUp1 = diracAngularUp[[1,1]]/schrodingerAngular;
spinorUp2 = diracAngularUp[[1,2]]/schrodingerAngular;
spinorDown = MatrixForm[{spinorDown1,spinorDown2}];
spinorUp = MatrixForm[{spinorUp1,spinorUp2}];
Print["2P 3/2 (ml=1) :            ",ψDiracRadial[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ]/.α->0,"  ",{ ψDiracAngular[{2, 1, 1,1/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0,ψDiracAngular[{2, 1, 1,3/2, 3/2, -2, 1}, r, θ,ϕ]/.α->0},"                 ",ψSchrodingerRadial[{2,1,1}, r,  θ,ϕ],"  ",ψSchrodingerAngular[{2,1,1}, r,  θ,ϕ],"       ",{ spinorDown,spinorUp}];
Print[" "];
Print[" "];

Print[" "];
Print["          Simplest states for Dirac Lyman-Alpha Transition (expressed relative to Schrodinger)"];
Print[" "];

Print["1S 1/2 :                ",ψSchrodingerRadial[{1,0,0}, r,  θ,ϕ],"          ",ψSchrodingerAngular[{1,0,0}, r,  θ,ϕ],"          ",ψDiracRadialModifier[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ],"          ", ψDiracAngularModifier[{1,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
(* Print["2P 1/2 DIRAC (components):         ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]}];
Print[" "]; *)

Print["2P 3/2 (ml=-1) :       ",ψSchrodingerRadial[{2,1,-1}, r,  θ,ϕ],"   ",ψSchrodingerAngular[{2,1,-1}, r,  θ,ϕ],"         ",ψDiracRadialModifier[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ],"             ",ψDiracAngularModifier[{2,1,-1,3/2,-2}, r,  θ,ϕ] ];
Print[" "];

Print["2P 3/2 (ml=1) :       ",ψSchrodingerRadial[{2,1,1}, r,  θ,ϕ],"   ",ψSchrodingerAngular[{2,1,1}, r,  θ,ϕ],"         ",
ψDiracRadialModifier[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ],"             ",ψDiracAngularModifier[{2,1,1,3/2,-2}, r,  θ,ϕ]];
Print[" "];
Print[" "];

Print[" "];
Print["          Simplest states for Dirac Lyman-Alpha Transition (expressed relative to Schrodinger, canonical form)"];
Print[" "];

Print["1S 1/2 :                     ",ψSchrodinger[{1,0,0}, r,  θ,ϕ],"           ",ψDiracRadialModifier[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ],"        ", ψDiracAngularModifierCanonical[{1,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
(* Print["2P 1/2 DIRAC (components):         ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]}];
Print[" "]; *)
Print["2S 1/2 :                     ",ψSchrodinger[{2,0,0}, r,  θ,ϕ],"           ",ψDiracRadialModifier[{2,0,0,1/2,1/2,-1}, r,  θ,ϕ],"        ", ψDiracAngularModifierCanonical[{2,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
Print["2P 3/2 (ml=-1) :       ",ψSchrodinger[{2,1,-1}, r,  θ,ϕ],"          ",ψDiracRadialModifier[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ],"              ",ψDiracAngularModifierCanonical[{2,1,-1,3/2,-2}, r,  θ,ϕ] ];
Print[" "];

Print["2P 3/2 (ml=1) :       ",ψSchrodinger[{2,1,1}, r,  θ,ϕ],"          ",    ψDiracRadialModifier[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ],"              ",ψDiracAngularModifierCanonical[{2,1,1,3/2,-2}, r,  θ,ϕ]];
Print[" "];
Print[" "];

Print["2P 1/2 (ml=0) :       ",ψSchrodinger[{2,1,0}, r,  θ,ϕ],"          ",    ψDiracRadialModifier[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"              ",ψDiracAngularModifierCanonical[{2,1,0,1/2,1}, r,  θ,ϕ]];
Print[" "];
Print[" "];

Print[" "];
Print["          Simplest states for Dirac Lyman-Alpha Transition (expressed relative to Schrodinger, canonical form, showing positive and negative energy solutions)"];
Print[" "];
Print["                                                                                                                        E > 0                            E < 0 "];
Print[" "];

Print["1S 1/2 :                     ",ψSchrodinger[{1,0,0}, r,  θ,ϕ],"           ",ψDiracRadialModifier[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ],"        ", ψDiracAngularModifierCanonicalFull[{1,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
(* Print["2P 1/2 DIRAC (components):         ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]}];
Print[" "]; *)
Print["2S 1/2 :                     ",ψSchrodinger[{2,0,0}, r,  θ,ϕ],"           ",ψDiracRadialModifier[{2,0,0,1/2,1/2,-1}, r,  θ,ϕ],"        ", ψDiracAngularModifierCanonicalFull[{2,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
Print["2P 3/2 (ml=-1) :       ",ψSchrodinger[{2,1,-1}, r,  θ,ϕ],"          ",ψDiracRadialModifier[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ],"              ",ψDiracAngularModifierCanonicalFull[{2,1,-1,3/2,-2}, r,  θ,ϕ] ];
Print[" "];

Print["2P 3/2 (ml=1) :       ",ψSchrodinger[{2,1,1}, r,  θ,ϕ],"          ",    ψDiracRadialModifier[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ],"              ",ψDiracAngularModifierCanonicalFull[{2,1,1,3/2,-2}, r,  θ,ϕ]];
Print[" "];
Print[" "];

Print["2P 1/2 (ml=0) :       ",ψSchrodinger[{2,1,0}, r,  θ,ϕ],"          ",    ψDiracRadialModifier[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"              ",ψDiracAngularModifierCanonicalFull[{2,1,0,1/2,1}, r,  θ,ϕ]];
Print[" "];
Print[" "];

Print[" "];
Print["          Simplest states for Dirac Lyman-Alpha Transition (expressed relative to Schrodinger, canonical form, showing positive and negative energy solutions)"];
Print[" "];
Print["                                                                         E > 0                             E < 0 "];
Print[" "];

Print["1S 1/2 :                     ",ψSchrodinger[{1,0,0}, r,  θ,ϕ],"           ","A","   ", ψDiracAngularModifierCanonicalFullWithB[{1,0,0,1/2,-1}, r,  θ,ϕ],"          ","A = ",ψDiracRadialModifier[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ],"     B = ",ψDiracAngularModifierCanonicalFullB[{1,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
(* Print["2P 1/2 DIRAC (components):         ",ψDiracRadial[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"  ",{ ψDiracAngular[{2, 1, 0,-1/2, 1/2, 1, 1}, r, θ,ϕ],ψDiracAngular[{2, 1, 0,1/2, 1/2, 1, 1}, r, θ,ϕ]}];
Print[" "]; *)

Print["2P 3/2 (ml=-1) :       ",ψSchrodinger[{2,1,-1}, r,  θ,ϕ],"     ","A","   ",ψDiracAngularModifierCanonicalFullWithB[{2,1,-1,3/2,-2}, r,  θ,ϕ] ,"             ","A = ",ψDiracRadialModifier[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ],"           B = ",ψDiracAngularModifierCanonicalFullB[{2,1,-1,3/2,-2}, r,  θ,ϕ]];
Print[" "];

Print["2P 3/2 (ml=1) :       ",ψSchrodinger[{2,1,1}, r,  θ,ϕ],"      ","A","   ",   ψDiracAngularModifierCanonicalFullWithB[{2,1,1,3/2,-2}, r,  θ,ϕ],"             ","A = ", ψDiracRadialModifier[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ],"           B = ",ψDiracAngularModifierCanonicalFullB[{2,1,1,3/2,-2}, r,  θ,ϕ]];
Print[" "];
Print[" "];
Print["2S 1/2 :                     ",ψSchrodinger[{2,0,0}, r,  θ,ϕ],"  ","A","   ", ψDiracAngularModifierCanonicalFullWithB[{2,0,0,1/2,-1}, r,  θ,ϕ],"          ","A = ",ψDiracRadialModifier[{2,0,0,1/2,1/2,-1}, r,  θ,ϕ],"     B = ",ψDiracAngularModifierCanonicalFullB[{2,0,0,1/2,-1}, r,  θ,ϕ]];
Print[" "];
Print["2P 1/2 (ml=0) :         ",ψSchrodinger[{2,1,0}, r,  θ,ϕ],"       ","A","   ",ψDiracAngularModifierCanonicalFullWithB[{2,1,0,1/2,1}, r,  θ,ϕ],"            ","A = ", ψDiracRadialModifier[{2,1,0,1/2,1/2,1}, r,  θ,ϕ],"            ","     B = ",ψDiracAngularModifierCanonicalFullB[{2,1,0,1/2,1}, r,  θ,ϕ]];
Print[" "];
Print[" "];

(* Plot the A and B functions *)
val1=ψDiracRadialModifier[{1,0,0,1/2,1/2,-1}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
val2=ψDiracRadialModifier[{2,0,0,1/2,1/2,-1}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
val3=ψDiracRadialModifier[{2,1,-1,-3/2,3/2,-2}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
val4=ψDiracRadialModifier[{2,1,1,3/2,3/2,-2}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
val5=-ψDiracRadialModifier[{2,1,0,1/2,1/2,1}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
plot1 = Plot[{val1,val2,val3,val4,val5},{r,0,10},Frame->True,PlotRange->{0.99,1.01},AspectRatio->0.8,PlotLabel->"A(r) vs. r/(Subscript[a, 0])",Axes->False];
val6=ψDiracAngularModifierCanonicalFullB[{1,0,0,1/2,-1}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
val7=ψDiracAngularModifierCanonicalFullB[{2,0,0,1/2,-1}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};val8=ψDiracAngularModifierCanonicalFullB[{2,1,-1,3/2,-2}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};val9=ψDiracAngularModifierCanonicalFullB[{2,1,1,3/2,-2}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};val10=-ψDiracAngularModifierCanonicalFullB[{2,1,0,1/2,1}, r,  θ,ϕ]/.{α->1/137.04,(Subscript[a, 0])->1};
plot2 = Plot[{val6,val7,val8,val9,val10},{r,0,10},Frame->True,PlotRange->{0.,0.01}, AspectRatio->0.8,PlotLabel->"B(r) vs. r/(Subscript[a, 0])",Axes->False];
Show[GraphicsRow[ {plot1,plot2}]]

nmax = 3;
DisplayElements2 = {};
Do [
Do[
DisplayElements = {};
Do[ AppendTo[DisplayElements," "]   ,{i,1,nmax-l-1}];
Do[
If[Mod[(l+Abs[ml]),2]==0,
    j=l+1/2,
    j=Abs[l-1/2]];
mjplus = ml+1/2;
mjminus = ml - 1/2;
AppendTo[DisplayElements,ψSchrodinger[{n,l,ml}, r,  θ,ϕ]]; 
,{ml,-l,l}];
Do[ AppendTo[DisplayElements," "]   ,{i,1,nmax-l-1}];
AppendTo[DisplayElements2,DisplayElements];
,{l,0,n-1}];
AppendTo[DisplayElements2,{" "}];
AppendTo[DisplayElements2,{" "}];

,{n,1,nmax}];
Print[Grid[DisplayElements2]];

Sqrt[1-Sqrt[1-alpha^2]]/(Sqrt[2]alpha)

Print[InputForm[Sqrt[1-Sqrt[1-alpha^2]]/(Sqrt[2]alpha)/.alpha->1/137.05999]]

Print[InputForm[1/(2(1-alpha^2/8))/.alpha->1/137.05999]]

(* Full Table of Parameters *)

DisplayElements = {{"n","l","ml","j","mj-","mj+","kappa","nr","lprime","glead","n-l-1","2l+1","LaguerreL","LegendreP","Energy","lambda","rho","gamma","F(-nr;b;z)","F(1-nr;b;z)","U(-nr;b;z)","U(1-nr;b;z)"}};
Do [
Do[
Do[
If[Mod[(l+Abs[ml]),2]==0,
    j=l+1/2; kappa = -(l+1),
    j=Abs[l-1/2]; kappa = l];
mjplus = ml+1/2;
mjminus = ml - 1/2;
nr = n - Abs[kappa];
lprime = 2j-l;
glead = (-1)^(1/2(1 + l - lprime));
lambda = Simplify[m c^2 Sqrt[1 - (EnergyDirac[n,j]/(m c^2))^2]/(hbar c)/. {hbar->(Subscript[a, 0]) α c m},Re[α]>0];
rho = 2 lambda r;
gamma = Sqrt[kappa^2 - α^2];		
AppendTo[DisplayElements,{n,l,ml,j,mjminus,mjplus,kappa,nr,lprime,glead,n-l-1,2l+1,LaguerreL[n - l - 1, 2 l + 1, x],LegendreP[l,ml,x],EnergyDirac[n,j],lambda,rho,gamma,Hypergeometric1F1 [-nr,b,z],If[nr==0,0,Hypergeometric1F1 [1-nr,b,z]],HypergeometricU [-nr,b,z],If[nr==0,0,HypergeometricU [1-nr,b,z]]
(* MatrixForm[Simplify[ψDirac[{n,l,mjminus,j, kappa}, r,  θ,ϕ]]/.{hbar->a0 alpha c m}],MatrixForm[Simplify[ψDirac[{n,l,mjplus,j, kappa}, r,  θ,ϕ]]/.{hbar->a0 alpha c m}]}] *)  }]; 
,{ml,-l,l}];
,{l,0,n-1}];
,{n,1,3}];
Print[Grid[DisplayElements]];

(* Table of Spherical Harmonics to prove we match Landau table *)

Print["Table of Spherical Harmonics (Landau convention)"];
Print["Y(0,0) = ",Simplify[SphericalHarmonicYLandau[0, 0, θ,ϕ],θ>0 && θ<Pi]]
Print["Y(1,0) = ",Simplify[SphericalHarmonicYLandau[1, 0, θ,ϕ],θ>0 && θ<Pi]]
Print["Y(1,1) = ",Simplify[SphericalHarmonicYLandau[1, 1 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(1,-1) = ",Simplify[SphericalHarmonicYLandau[1, -1 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(2,0) = ",Simplify[SphericalHarmonicYLandau[2, 0, θ,ϕ],θ>0 && θ<Pi]]
Print["Y(2,1) = ",Simplify[SphericalHarmonicYLandau[2, 1 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(2,-1) = ",Simplify[SphericalHarmonicYLandau[2, -1 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(2,2) = ",Simplify[SphericalHarmonicYLandau[2, 2 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(2,-2) = ",Simplify[SphericalHarmonicYLandau[2, -2 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,0) = ",Simplify[SphericalHarmonicYLandau[3, 0, θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,1) = ",Simplify[SphericalHarmonicYLandau[3, 1 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,-1) = ",Simplify[SphericalHarmonicYLandau[3, -1 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,2) = ",Simplify[SphericalHarmonicYLandau[3, 2 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,-2) = ",Simplify[SphericalHarmonicYLandau[3, -2 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,3) = ",Simplify[SphericalHarmonicYLandau[3, 3 , θ,ϕ],θ>0 && θ<Pi]]
Print["Y(3,-3) = ",Simplify[SphericalHarmonicYLandau[3, -3 , θ,ϕ],θ>0 && θ<Pi]]

(* Final Table *)
DisplayElements = {{"n","l","ml","j","mj-","mj+","ψSchrodinger","ψDiracRadial","ψDiracAngular"}};
Do [
Do[
Do[
If[Mod[(l+Abs[ml]),2]==0,
    j=l+1/2; kappa = -(l+1),
    j=Abs[l-1/2]; kappa = l];
mjplus = ml+1/2;
mjminus = ml - 1/2;
nr = n - Abs[kappa];
lprime = 2j-l;
glead = (-1)^(1/2(1 + l - lprime));
AppendTo[DisplayElements,{n,l,ml,j, mjminus, mjplus,ψSchrodinger[{n,l,ml}, r,  θ,ϕ],
ψDiracRadial[{n,l,ml,mj,j,kappa}, r,  θ,ϕ],{ψDiracAngular[{n, l,ml,mjminus, j, kappa, 1}, r, θ,ϕ],ψDiracAngular[{n, l,ml,mjplus, j, kappa, 1}, r, θ,ϕ]}
(* MatrixForm[Simplify[ψDirac[{n,l,mjminus,j, kappa}, r,  θ,ϕ]]/.{hbar->a0 alpha c m}],MatrixForm[Simplify[ψDirac[{n,l,mjplus,j, kappa}, r,  θ,ϕ]]/.{hbar->a0 alpha c m}]}] *)  }]; 
,{ml,-l,l}];
,{l,0,n-1}];
,{n,1,3}];
Print[Grid[DisplayElements]];

(*PHYSICAL PARAMETERS*)
h=6.62606896*10^(-34);                                                                                                                                          (*Planck's constant in J s*)
hbar=h/(2 Pi);                                                                                                                                                               (*reduced Planck's constant in J s*)
e=1.60217653*10^(-19);                                                                                                                                           (*charge on electron in Coulombs*)
m=9.10938215*10^(-31);                                                                                                                                           (*mass of electron in kg*)
c=299792458;                                                                                                                                                                  (*speed of light in m/s*)
(Subscript[μ, 0])=4 Pi 10^(-7);                                                                                                                                                             (*magnetic constant in N/Ampere^2*)
w0=m c^2/hbar;                                                                                                                                                              (*w0 in rad/s*)
(Subscript[ϵ, 0])=8.854187817620*10^(−12);                                                                                                                                (*permittivity of free space,in F/m*)
mp=1.67262178*10^(-27);                                                                                                                                         (*mass of proton in kg*)
rp=0.8768*10^(-15);                                                                                                                                                     (*radius of proton in m*)
μ=mp/m;                                                                                                                                                                            (* proton-to-electron mass ratio *)
mr = mp m/(mp + m);                                                                                                                                                     (* reduced mass of the electron *)
mt = mp +m;                                                                                                                                                                      (* total mass of electron plus proton *)
a0=4*Pi*((Subscript[ϵ, 0]))*(hbar^2)/(mr*(e^2));                                                                                                             (*first Bohr radius in meters*)
rc = a0/μ;                                                                                                                                                                        (* cutoff radius *)
R00 = 2/a0^(3/2);                                                                                                                                                       (* Radial normalization factor for Hydrogen ground state *)
R20 = 1/(2 Sqrt[2] a0^(3/2));                                                                                                                              (* Radial normalization factor for Hydrogen 2S state *)



R=1.00;                                                                                                                                                                              (* atomic spacing in meters *)
A0=((Subscript[μ, 0]) e hbar 8 Sqrt[2])/(Pi mr R a0 81);                                                                                                           (* Vector potential baseline value in kg m/(Coulomb second) *)
alpha=e^2/(4 Pi ((Subscript[ϵ, 0])) hbar c);                                                                                                                                 (* Fine Structure Constant,unitless *)
(Subscript[E, 0])=-mr (e^4)/(8 ((Subscript[ϵ, 0]))^2 h^2);                                                                                                                                (* Schrodinger ground state energy in J (Rydberg constant) *)
Ejn=(Subscript[E, 0])/(n^2)*(1+(alpha^2/n^2)*((n/(j+1/2))-3/4));                                                                  (* Dirac Energy in J *)Ejna=(mr c^2)/Sqrt[1+(alpha^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-alpha^2])^2]-(mr c^2);  (* Dirac Energy in J-alternate form (uses reduced mass) *)

fb[n_,j_]:=   1/Sqrt[1+(alpha^2)/(n-(j+1/2)+Sqrt[(j+1/2)^2-alpha^2])^2];               (* Dirac Energy with Barker and Glover (1955) Two-Body Correction *)
Ejnb[n_,j_,l_]:= Module[{kappa,lastterm},
kappa=(((-1))^(j-l+(1/2)))(j+(1/2));  
Print["-------- Ejnb calculation --------------------------------"];
Print["n = ",n,"   j = ",j,"    l = ",l];
Print["kappa = ",kappa];
Print["KroneckerDelta[l,0] = ",KroneckerDelta[l,0]];
lastterm = (((1-KroneckerDelta[l,0])(alpha^4)(mr^3)(c^2))/((kappa (2 l+1))2(n^3)(mp^2)));
Print["lastterm = ",lastterm];
mt (c^2) + (fb[n,j]-1)mr (c^2)- (((((fb[n,j]-1))^2)(mr^2) (c^2))/(2 mt))+(((1-KroneckerDelta[l,0])(alpha^4)(mr^3)(c^2))/((kappa (2 l+1))2(n^3)(mp^2)))-mt (c^2)
];

LambShiftHz = 1057.85*10^6;                                                                                                                                 (* measured Lamb Shift in Hz, from Mohr 1975 (1057.864), 
                                                                                        Niering 2000 (1057.85), Karshenboim 2005 summary *)
transition1S2SHz = 2.466061413187035*^15;                                                                                                    (* Transition frequency for 1S-2S transition in Hz from Parthey 2011*)

hydrogenDeuteriumIsotopeShiftHz = 670994334606 ;                                                                                   (*  E1s2sD - E1s2sH from Parthey 2010 *)
transition1S2SHzDeuterium = transition1S2SHz+hydrogenDeuteriumIsotopeShiftHz;
GroundStateShiftHz = 8172.874*10^6;                                                                                                               (* 1S shift in Hydrogen from Weitz 1995 *)
GroundStateShiftHzDeuterium = 8183.807*10^6;                                                                                            (* 1S shift in Deuterium from Weitz 1995 *)
LambShiftHzDeuterium = 1059.36*10^6;                                                                                                              (* measured Lamb Shift in Hz in Deuterium, 
                                                                                         from Wijngaarden and Drake, 1977 *)


R00val = R00;
R20val = R20;
a0val = a0;
hbarval = hbar;
mval = m;
rcval = rc;
μval = μ;
mrval = mr;
cval = c;

psi2p = (1 / (4 Sqrt[2 Pi] a0^(3/2))) (r / a0) Exp[-r / (2 a0)] Cos [theta] Exp[- I w21 t];  (* all frequency difference associated with excited state *)
psi1s = (1 / (Sqrt[Pi] a0^(3/2))) Exp[-r / a0];  (* no time dependence in ground state *)
psipstar = (1 / (4 Sqrt[2 Pi] a0^(3/2))) (r / a0) Exp[-r / (2 a0)] Cos [theta] Exp[+ I w21 t];  (* all frequency difference associated with excited state *)
psisstar = ψ1s;  (* no time dependence *)
psi2pXYZ = ((1 / (4 Sqrt[2 Pi] a0^(3/2))) (r / a0) Exp[-r / (2 a0)] z/r Exp[- I w21 t])/.{r->Sqrt[x^2 + y^2 + z^2]};
psi1sXYZ = ((1 / (Sqrt[Pi] a0^(3/2))) Exp[-r / a0] )/.{r->Sqrt[x^2 + y^2 + z^2]};
psi2p1sXYZ = (1/Sqrt[1 - 2 lambda (1-lambda)])*(lambda * psi1sXYZ + (1-lambda) * psi2pXYZ);
psi1sXYZT0 = psi1sXYZ /.{t->0};
psi2pXYZT0 = psi2pXYZ /.{t->0};
psi2p1sXYZT0 = (1/Sqrt[1 - 2 lambda (1-lambda)])*(lambda * psi1sXYZT0 + (1-lambda) * psi2pXYZT0);

(* Dirac Plane Wave Solution *)

A = {{ E - m c^2,0 ,-c pz , -c(px - I py)},{ 0,E - m c^2 ,-c(px + I py), c pz},{-c pz ,-c(px - I py) ,E + m c^2 ,0 },{ -c(px + I py),c pz ,0 ,E + m c^2 }};
B = {{0},{0},{0},{0}};
Print ["     A = ",MatrixForm[A]]
Print ["     B = ",MatrixForm[B]]
Print["Det[A] = ",Simplify[Det[A]]]
M = Transpose[Join[Transpose[A],Transpose[B]]];
Print ["     M = ",MatrixForm[M]]
M1 = M /. E->(Sqrt[m^2 c^4 + c^2 (px^2 + py^2 + pz^2)]);
(* Print ["    M1 = ",MatrixForm[M1]] *)
n = RowReduce[M1];
Print ["Positive Energy Solutions:"]
Print ["     N = ",MatrixForm[n]]
M2 = M /. E->(-Sqrt[m^2 c^4 + c^2 (px^2 + py^2 + pz^2)]);
(* Print ["    M2 = ",MatrixForm[M2]] *)
n2 = RowReduce[M2];
(* Print ["     N = ",MatrixForm[n2]] *)
M3 = Transpose[Permute[Transpose[M],{3,4,1,2,5}]];
(* Print ["    M3 = ",MatrixForm[M3]] *)
M4 = M3 /. E->(-Sqrt[m^2 c^4 + c^2 (px^2 + py^2 + pz^2)]);
(* Print ["    M4 = ",MatrixForm[M4]] *)
M5 = RowReduce[M4];
(* Print ["    M5 = ",MatrixForm[M5]] *)
M6 = Transpose[Permute[Transpose[M5],{3,4,1,2,5}]];
Print ["Negative Energy Solutions:"]
Print ["    M6 = ",MatrixForm[M6]]

(* verify tricky identities and unit conventions:  hbar = a0 alpha c mr, etc. *)

(* identities in units *)
- ((alpha c hbar )/r)   (* when Eides writes  V(r) = -((Z alpha )/r), it is shorthand for V(r) = -((Z alpha c hbar )/r), where in natural units, c = hbar = 1 *)
-((hbar^2)/(mr a0 r))                  (* In non-relativistic work, I use  V(r) = -((hbar^2)/(mr a0 r)) *)
-((e^2)/(4 Pi (Subscript[ϵ, 0]) r))                 (* equivalent to  V(r) = -((e^2)/(4 Pi (Subscript[ϵ, 0]) r)) *)
hbar                       (* verify identity    hbar = a0 alpha c mr *)
a0 alpha c mr
(Subscript[E, 0])                            (* In non-relativistic work, I use  (Subscript[E, 0]) = -((hbar^2)/(2 mr (a0^2))) *)
-((mr (c^2)(alpha^2))/2)      (* Eides writes E = ((((Z alpha))^2)/2), it is shorthand for E = m (c^2)((((Z alpha))^2)/2)*)

(* --------- evaluate everything above this line before plotting --------- *)

(* plot and animate wavefunction clouds *)

boxSize=7 a0;

densityThreshold = Sqrt[Sqrt[0.5 10^(15)]];
lowerBoundFactor = 0.57;
boxSize = 7 a0;
axisGray = 0;
axisOpacity = 0.5;
pointRange = 30;
plot1 = DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.0, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> True, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, 
              PlotRange -> {-densityThreshold, -lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, 
              ColorFunction -> "PigeonTones"];
plot2 = DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.25, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> True, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, PlotRange -> {-densityThreshold, -lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, ColorFunction -> "PigeonTones"];
plot3 = DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.5, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> True, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, PlotRange -> {-densityThreshold, -lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, ColorFunction -> "PigeonTones"];
plot4 = DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.75, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> True, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, PlotRange -> {-densityThreshold, -lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, ColorFunction -> "PigeonTones"];
plot5 = DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 1.0, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> True, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, PlotRange -> {-densityThreshold, -lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, ColorFunction -> "PigeonTones"];
Show[GraphicsRow[{plot1, plot2, plot3, plot4, plot5}], ImageSize -> {1000, 200}]

ColorData["Gradients"]

densityThreshold = Sqrt[Sqrt[0.5 10^(15)]];
lowerBoundFactor = 0.57;
boxSize = 7 a0;
axisGray = 0;
axisOpacity = 0.5;
pointRange = 30;
plot1 = DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.0, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> False, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, 
              PlotRange -> {densityThreshold, lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, 
              ColorFunction -> "SunsetColors"];
plot2 = DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.25, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> False, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, 
              PlotRange -> {densityThreshold, lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, 
              ColorFunction -> "SunsetColors"];
plot3 = DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.5, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> False, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, 
              PlotRange -> {densityThreshold, lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, 
              ColorFunction -> "SunsetColors"];
plot4 = DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 0.75, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> False, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, 
              PlotRange -> {densityThreshold, lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, 
              ColorFunction -> "SunsetColors"];
plot5 = DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZT0 /. {lambda -> 1.0, x -> 0}]]]), {y, -boxSize, boxSize}, {z, -boxSize, boxSize},
              Axes -> False, AxesStyle -> {GrayLevel[axisGray], Opacity[axisOpacity]}, Ticks -> None, Frame -> False, 
              PlotRange -> {densityThreshold, lowerBoundFactor*densityThreshold}, PlotPoints -> {pointRange, pointRange}, ClippingStyle -> Automatic, 
              ColorFunction -> "SunsetColors"];
Show[GraphicsRow[{plot1, plot2, plot3, plot4, plot5},Dividers->None,Spacings->0], ImageSize -> {1000, 200}]

numsteps = 20;
period = T21;
densityThreshold=Sqrt[Sqrt[0.5 10^(15)]];
boxSize = 7 a0;
lowerBoundFactor = 0.57;
axisGray = 0;
axisOpacity = 0.5;
pointRange = 30;
storedPlots = Table[  
GraphicsRow[{
DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->0.0,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->True,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{-densityThreshold,-lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"PigeonTones"],
DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->0.25,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->True,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{-densityThreshold,-lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"PigeonTones"],
DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZ /.{t->i*period/numsteps,lambda->0.5,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->True,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{-densityThreshold,-lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"PigeonTones"],
DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->0.75,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->True,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{-densityThreshold,-lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"PigeonTones"],
DensityPlot[(-Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->1.0,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->True,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{-densityThreshold,-lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"PigeonTones"]

},ImageSize->{1000,200}],
{i,1,numsteps}];
Style[ListAnimate[storedPlots,30,ControlPlacement->Bottom, ImageSize->{1100,300} ,Alignment->{Center,Center},AppearanceElements->"HideControlsButton", ImageMargins->Tiny, FrameMargins->Tiny], ControlsRendering->"Generic"]

numsteps = 20;
period = T21;
densityThreshold=Sqrt[Sqrt[0.5 10^(15)]];
boxSize = 7 a0;
lowerBoundFactor = 0.57;
axisGray = 0;
axisOpacity = 0.5;
pointRange = 30;
storedPlots = Table[  
GraphicsRow[{
DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZ /.{t->i*period/numsteps,lambda->0.5,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->False,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{densityThreshold,lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"SunsetColors"]
},ImageSize->{200,200}],
{i,1,numsteps}];
Style[ListAnimate[storedPlots,30,ControlPlacement->Bottom, ImageSize->{300,300} ,Alignment->{Center,Center},AppearanceElements->"HideControlsButton", ImageMargins->Tiny, FrameMargins->Tiny], ControlsRendering->"Generic"]

Export["H:\\math\\CarverPhysics\\LambShift\\Animations\\cloud.avi",storedPlots];

numsteps = 20;
period = T21;
densityThreshold=Sqrt[Sqrt[0.5 10^(15)]];
boxSize = 7 a0;
lowerBoundFactor = 0.57;
axisGray = 0;
axisOpacity = 0.5;
pointRange = 30;
storedPlots = Table[  
GraphicsRow[{
DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->0.0,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->False,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{densityThreshold,lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"SunsetColors"],
DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->0.25,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->False,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{densityThreshold,lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"SunsetColors"],
DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZ /.{t->i*period/numsteps,lambda->0.5,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->False,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{densityThreshold,lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"SunsetColors"],
DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->0.75,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->False,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{densityThreshold,lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"SunsetColors"],
DensityPlot[(Sqrt[Sqrt[Abs[psi2p1sXYZ/.{t->i*period/numsteps,lambda->1.0,x->0}]]]),{y,-boxSize,boxSize},{z,-boxSize,boxSize},
           Axes->False,AxesStyle->{GrayLevel[axisGray],Opacity[axisOpacity]},Ticks->None,Frame->False,PlotRange->{densityThreshold,lowerBoundFactor*densityThreshold},PlotPoints->{pointRange,pointRange},ClippingStyle->Automatic,ColorFunction->"SunsetColors"]

},ImageSize->{1000,200}],
{i,1,numsteps}];
Style[ListAnimate[storedPlots,30,ControlPlacement->Bottom, ImageSize->{1100,300} ,Alignment->{Center,Center},AppearanceElements->"HideControlsButton", ImageMargins->Tiny, FrameMargins->Tiny], ControlsRendering->"Generic"]

(* Lamb Shift *)

(* Lamb Shift Definitions *)

(* Table of Bethe Logarithms, from Jentschura and Mohr, 2005 *)
BetheLogarithmk0NLplusOneTable = Transpose[{
{0.298412856×10^1,
0.281176989×10^1,
0.276766361×10^1,
0.274981184×10^1,
0.274082373×10^1,
0.273566421×10^1,
0.273242913×10^1,
0.273026726×10^1,
0.272875117×10^1,
0.272764694×10^1,
0.272681778×10^1,
0.272617934×10^1,
0.272567729×10^1,
0.272527537×10^1,
0.272494860×10^1,
0.272467936×10^1,
0.272445488×10^1,
0.272426577×10^1,
0.272410496×10^1,
0.272396708×10^1
},
{Infinity,
−0.300167086×10^-1,
−0.381902294×10^-1,
−0.419548946×10^-1,
−0.440346956×10^-1,
−0.453121977×10^-1,
−0.461551773×10^-1,
−0.467413520×10^-1,
−0.471657000×10^-1,
−0.474828934×10^-1,
−0.477262681×10^-1,
−0.479171116×10^-1,
−0.480695436×10^-1,
−0.481932338×10^-1,
−0.482949864×10^-1,
−0.483797030×10^-1,
−0.484509878×10^-1,
−0.485115392×10^-1,
−0.485634100×10^-1,
−0.486081845×10^-1
}}];
lnk0[n_,l_]:= BetheLogarithmk0NLplusOneTable[[n,l+1]];
lnk0n200l0=2.72266810;
lnk0n200l1 = -0.0490494865;
(* limiting values from Poquerrusse, 1981 *)
lnk0nInfinityl0=2.7226543;
lnk0nInfinityl1 = -0.0490545;

Clear[V0,V1,ψ1se,ψ1sp];
Crossfade[x_] := Exp[-2x](1+x)/(1-x+2/3 x^3);

LHopital[quotient_, var_, order_] := If[order==0,quotient/.var->0  ,(D[Numerator[quotient],{var,order}]/D[Denominator[quotient],{var,order}])/.var->0];
Group[x_, varlist_] := Sum[Simplify[varlist[[n]]*Coefficient[x,varlist[[n]]]  ] ,{n,1,Length[varlist]}];  (* keeps requested terms, drops all else(!) *)
GroupKeepAll[x_, varlist_] := Module[{requestedTerms,allElse,result},
requestedTerms=Sum[Simplify[varlist[[n]]*Coefficient[x,varlist[[n]]]  ] ,{n,1,Length[varlist]}];  (* keeps requested terms, keeps all else *)
allElse = Simplify[Expand[x]-Expand[requestedTerms]];
(* Print["allElse = ",allElse]; *)
result = requestedTerms+allElse;
result
];
GroupRemainder[x_, varlist_] := Module[{requestedTerms,allElse,result},
requestedTerms=Sum[Simplify[varlist[[n]]*Coefficient[x,varlist[[n]]]  ] ,{n,1,Length[varlist]}];  (* keeps requested terms, keeps all else *)
allElse = Simplify[Expand[x]-Expand[requestedTerms]];
(* Print["allElse = ",allElse]; *)
allElse
];

SimplifyTermByTerm[input_] := If[ToString[Head[input]]=="Plus",Total[Table[Simplify[input[[n]]],{n,1,Length[input]}]], Simplify[input]];
NumberOfAdditiveTerms[input_] := If[ToString[Head[input]]=="Plus",Length[input],1];
SplitIntoAdditiveTerms[input_] := If[ToString[Head[input]]=="Plus",Table[input[[n]],{n,1,Length[input]}],{input}];

ProductOfTerms[input_]:=Module[{product,n},
product=1;
Do[
product *= input[[n]];
,{n,1,Length[input]}];
product
];
SimplifyArgumentGivenExp[input_]:= Module[{},
If[(ToString[Head[input]]=="Power") && (ToString[input[[1]]]=="E"),Exp[Expand[input[[2]]]],input]
];
SimplifyArgumentOfExp[input_]:= Module[{},
If[(ToString[Head[input]]=="Times") ,ProductOfTerms[Table[SimplifyArgumentGivenExp[input[[n]]],{n,1,Length[input]}]],SimplifyArgumentGivenExp[input]]
];
SimplifyAllExponentialArguments[input_]:= Module[{},
If[(ToString[Head[input]]=="Plus") ,Total[Table[SimplifyArgumentOfExp[input[[n]]],{n,1,Length[input]}] ], input]
];

NeglectSmall[x_, varlist_, neglectOrder_] := Module[{coeff, score,scoreTable,maxScore,keepTable,keepers, sumOfTerms,lengthCoeff},
debugLevel = 0;
sumOfTerms=0;
If[debugLevel>0,Print["NeglectSmall:\nx = ",x];]; 
Do[
coeff = Expand[Coefficient[x,varlist[[n]]]];

(* old way *)
(* lengthCoeff = If[Length[coeff]>0,If[ToString[Head[coeff]]== "Plus",Length[coeff],1],If [coeff ≠ 0 || ToString[coeff] == "ε",1,0]]; *)
(* new way *)
lengthCoeff = If[ToString[Head[coeff]]== "Plus",Length[coeff],If[Length[coeff]>0,1 ,If [coeff ≠ 0 || ToString[coeff] == "ε"|| ToString[coeff] == "μ",1,0] ]];

scoreTable = Table[Exponent[If[ lengthCoeff>1,coeff[[i]],coeff],μ]-2  Exponent[If[lengthCoeff>1,coeff[[i]],coeff],ε] ,{i,1,lengthCoeff}];
maxScore = Max[scoreTable];
keepTable = Table[If[scoreTable[[i]]≥ (maxScore-neglectOrder),1,0] ,{i,1,lengthCoeff}];

keepers = Sum[varlist[[n]]*If[ lengthCoeff>1,coeff[[i]],coeff]*keepTable[[i]], {i,1,lengthCoeff}];
sumOfTerms = sumOfTerms + keepers;

If[debugLevel>0,
If[(* lengthCoeff>0 || coeff==ε*)True,Print["    var = ",varlist[[n]],"     coeff = ",coeff,"      lengthCoeff = ",lengthCoeff,"      scoreTable = ",scoreTable,"     maxScore = ",maxScore,"   keepTable = ",keepTable,  "   keepers = ",keepers]]; 
];

,{n,1,Length[varlist]}]; 
Group[sumOfTerms, varlist]
];

SetupPrintMonitor[] := firsttimeprint=True;
PrintMonitor[string_] := Module[{},
If[firsttimeprint==False,NotebookDelete[tempprint]];
firsttimeprint=False;
tempprint = PrintTemporary[string];  
];
ExtendedPartition[array_,rowsize_] := If[Mod[Length[array],rowsize]==0,Partition[array,rowsize],Append[Partition[array,rowsize],Take[array,-Mod[Length[array],rowsize]  ]]];


LHopitalProcess2[input_] := Module[{expRList,order,denominator,numerator,reduction1,reduction2,debugLevel},
debugLevel=0;
If[debugLevel>0,Print["input = ",input]];
If[ToString[input]=="0",
reduction2 = 0;
If[debugLevel>0,Print["reduction = ",reduction2,"\n\n\n"]];
,
(* else *)
expRList = Table[Exponent[input[[n]],1/r],{n,1,Length[input]}];
order=Max[expRList];
denominator = r^order;
numerator = Expand[input*denominator];
reduction1=Simplify[(D[numerator,{r,order}]/D[denominator,{r,order}])/.r->0/.A[0]->0];
reduction2=(D[numerator,{r,order}]/D[denominator,{r,order}])/.r->0/.A[0]->0/.A'[0]->  2 μ/a0/.A''[0]->  -(2 μ/a0 )^2/.A'''[0]->  (2 μ/a0 )^3;
If[debugLevel>0,
Print["expRList = ",expRList,"    order = ",order,"    denominator = ",denominator,"    numerator = ",numerator];
Print["reduction = ",reduction1,"    = ",reduction2,"\n\n\n"];
];
];
reduction2
];

LHopitalProcess[input_] := Module[{sum1,sum2, sum3,sum4,sum5,numterms,termTable,newterm,newterm2, newterm3,newterm4,aexp,appexp,rexp,logexp, order,special1,special2,numtermsSum3,basecoeff,basecoeff2,newsum2,newsum3,debugLevel},
(* computes derivative of a tamed function at the origin *)
(* in some cases, high-order application of L'Hopital's Rule is required *)
(* see 2014-08-30 notes for details of L'Hopital's Rule *)
(* note:  this assumes a particular form of the taming function A[r] = (1-Exp[-2 μ r/a0])  *)
(* This form of taming function is probably only the right one for the 1S case *)
debugLevel=0;
sum1 = 0;
sum2 = 0;
sum3 = 0;
sum4 = 0;
sum5 = 0;
order = 0;
numterms = NumberOfAdditiveTerms[input ];  
termTable = SplitIntoAdditiveTerms[input];
If[debugLevel==1,
Print["\n\n------------------ LHopitalProcess --------------------  "];
Print["input = ",input];
Print["numterms = ",numterms];
Print["termTable = ",termTable];
]

Do [
aexp = Exponent[termTable[[n]] ,A[r] ];
appexp = Exponent[termTable[[n]] ,A''[r] ];
rexp = Exponent[termTable[[n]] ,1/r ];
logexp = Exponent[termTable[[n]] ,Log[2r/a0] ];
If[(rexp==(aexp+1))&&(appexp==0),special1=True,special1=False];
If[(rexp==(aexp+2))||( (rexp==(aexp+1))&&(appexp==1) ),special2=True,special2=False];
newterm = If[logexp==1,0,                        (* log case *)
If[special1==True || special2==True ,   0,                         (* special case for high-order application of L'Hopital's Rule *)
termTable[[n]]/(A[r]/r)^rexp * A'[r]^rexp]];  (* usual rule for non-special cases *)
sum1= sum1+newterm;
newterm2 = If[logexp==1,0,                        (* log case *)
If[special1==True,   termTable[[n]],                         (* special case for high-order application of L'Hopital's Rule *)
0]];  (* usual rule for non-special cases *)
sum2= sum2+newterm2;
newterm3 = If[logexp==1,0,                        (* log case *)
If[special2==True ,   termTable[[n]],                         (* special case for high-order application of L'Hopital's Rule *)
0]];  (* usual rule for non-special cases *)
sum3= sum3+newterm3;
newterm4 = If[logexp==1,If[  aexp>= rexp+logexp,0,termTable[[n]]],                        (* log case *)
0];  (* usual rule for non-special cases *)
sum4= sum4+newterm4;
If[special1==True,order=order+aexp+rexp];
If[debugLevel==1,
Print["n = ",n,"   term = ",termTable[[n]],"   aexp = ",aexp,"   appexp = ",appexp,"   rexp = ",rexp,"   logexp = ",logexp,If[special1==True,"    **SPECIAL 1**",If[special2==True,"    **SPECIAL 2**","               " ]],"   newterm = ",newterm,"   newterm4 = ",newterm4];
];
,{n,1,numterms}];
order = order/4*2/NumberOfAdditiveTerms[sum2 ];
basecoeff = Simplify[sum2/(-A[r]^order/r^(order+1)+ A[r]^(order-1)A'[r]/r^(order) )];
newsum2 = basecoeff*((A'[r])^(order-1))*A''[r]/2;
numtermsSum3 = NumberOfAdditiveTerms[sum3 ];
basecoeff2=0;
newsum3 = LHopitalProcess2[sum3];

If[debugLevel==1,
Print["sum1 = ",sum1,"\nsum2 = ",sum2,"    order = ",order,"    basecoeff = ",basecoeff,"    newsum2 = ",newsum2,"\nsum3 = ",sum3,"   numtermsSum3 = ",numtermsSum3,"    newsum3 = ",newsum3,"\nsum4 = ",sum4]; 
];
sum1 = sum1/.r->0/.A[0]->0/.A'[0]->  2 μ/a0 /.A''[0]->  -(2 μ/a0 )^2;
sum2 = newsum2/.r->0/.A[0]->0/.A'[0]->  2 μ/a0/.A''[0]->  -(2 μ/a0 )^2;
sum3 = newsum3/.r->0/.A[0]->0/.A'[0]->  2 μ/a0/.A''[0]->  -(2 μ/a0 )^2/.A'''[0]->  (2 μ/a0 )^3;
sum5 = sum1+sum2+sum3;  (* +sum4; *) (* not adding in sum4 yet - with triple-log-taming, it is always zero *)
If[debugLevel==1,
Print["sum1 = ",sum1,"\nsum2 = ",sum2,"\nsum3 = ",sum3,"\nsum4 = ",sum4,"\nsum5 = ",sum5]; 
];
sum5
];

LHopitalProcess2General[input_,quantumN_] := Module[{expRList,order,denominator,numerator,reduction1,reduction2,debugLevel},
debugLevel=0;
If[debugLevel>0,Print["input = ",input]];
If[ToString[input]=="0",
reduction2 = 0;
If[debugLevel>0,Print["reduction = ",reduction2,"\n\n\n"]];
,
(* else *)
expRList = Table[Exponent[input[[n]],1/r],{n,1,Length[input]}];
order=Max[expRList];
denominator = r^order;
numerator = Expand[input*denominator];
reduction1=Simplify[(D[numerator,{r,order}]/D[denominator,{r,order}])/.r->0/.A[0]->0];
reduction2=(D[numerator,{r,order}]/D[denominator,{r,order}])/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0)/.A''[0]->  -(2 μ/(quantumN a0) )^2/.A'''[0]->  (2 μ/(quantumN a0) )^3;
If[debugLevel>0,
Print["expRList = ",expRList,"    order = ",order,"    denominator = ",denominator,"    numerator = ",numerator];
Print["reduction = ",reduction1,"    = ",reduction2,"\n\n\n"];
];
];
reduction2
];

LHopitalProcessGeneral[input_, quantumN_] := Module[{sum1,sum2, sum3,sum4,sum5,numterms,termTable,newterm,newterm2, newterm3,newterm4,aexp,appexp,rexp,logexp, order,special1,special2,numtermsSum3,basecoeff,basecoeff2,newsum2,newsum3,debugLevel},
(* computes derivative of a tamed function at the origin *)
(* in some cases, high-order application of L'Hopital's Rule is required *)
(* see 2014-08-30 notes for details of L'Hopital's Rule *)
(* note:  this assumes a particular form of the taming function A[r] = (1-Exp[-2 μ r/a0])  *)
(* This form of taming function is probably only the right one for the 1S case *)
debugLevel=0;
sum1 = 0;
sum2 = 0;
sum3 = 0;
sum4 = 0;
sum5 = 0;
order = 0;
numterms = NumberOfAdditiveTerms[input ];  
termTable = SplitIntoAdditiveTerms[input];
If[debugLevel==1,
Print["\n\n------------------ LHopitalProcess --------------------  "];
Print["input = ",input];
Print["numterms = ",numterms];
Print["termTable = ",termTable];
]

Do [
aexp = Exponent[termTable[[n]] ,A[r] ];
appexp = Exponent[termTable[[n]] ,A''[r] ];
rexp = Exponent[termTable[[n]] ,1/r ];
logexp = Exponent[termTable[[n]] ,Log[2r/(quantumN a0)] ];
If[(rexp==(aexp+1))&&(appexp==0),special1=True,special1=False];
If[(rexp==(aexp+2))||( (rexp==(aexp+1))&&(appexp==1) ),special2=True,special2=False];
newterm = If[logexp==1,0,                        (* log case *)
If[special1==True || special2==True ,   0,                         (* special case for high-order application of L'Hopital's Rule *)
termTable[[n]]/(A[r]/r)^rexp * A'[r]^rexp]];  (* usual rule for non-special cases *)
sum1= sum1+newterm;
newterm2 = If[logexp==1,0,                        (* log case *)
If[special1==True,   termTable[[n]],                         (* special case for high-order application of L'Hopital's Rule *)
0]];  (* usual rule for non-special cases *)
sum2= sum2+newterm2;
newterm3 = If[logexp==1,0,                        (* log case *)
If[special2==True ,   termTable[[n]],                         (* special case for high-order application of L'Hopital's Rule *)
0]];  (* usual rule for non-special cases *)
sum3= sum3+newterm3;
newterm4 = If[logexp==1,If[  aexp>= rexp+logexp,0,termTable[[n]]],                        (* log case *)
0];  (* usual rule for non-special cases *)
sum4= sum4+newterm4;
If[special1==True,order=order+aexp+rexp];
If[debugLevel==1,
Print["n = ",n,"   term = ",termTable[[n]],"   aexp = ",aexp,"   appexp = ",appexp,"   rexp = ",rexp,"   logexp = ",logexp,If[special1==True,"    **SPECIAL 1**",If[special2==True,"    **SPECIAL 2**","               " ]],"   newterm = ",newterm,"   newterm4 = ",newterm4];
];
,{n,1,numterms}];
order = order/4*2/NumberOfAdditiveTerms[sum2 ];
basecoeff = Simplify[sum2/(-A[r]^order/r^(order+1)+ A[r]^(order-1)A'[r]/r^(order) )];
newsum2 = basecoeff*((A'[r])^(order-1))*A''[r]/2;
numtermsSum3 = NumberOfAdditiveTerms[sum3 ];
basecoeff2=0;
newsum3 = LHopitalProcess2General[sum3,quantumN];

If[debugLevel==1,
Print["sum1 = ",sum1,"\nsum2 = ",sum2,"    order = ",order,"    basecoeff = ",basecoeff,"    newsum2 = ",newsum2,"\nsum3 = ",sum3,"   numtermsSum3 = ",numtermsSum3,"    newsum3 = ",newsum3,"\nsum4 = ",sum4]; 
];
sum1 = sum1/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0) /.A''[0]->  -(2 μ/(quantumN a0) )^2;
sum2 = newsum2/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0)/.A''[0]->  -(2 μ/(quantumN a0) )^2;
sum3 = newsum3/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0)/.A''[0]->  -(2 μ/(quantumN a0) )^2/.A'''[0]->  (2 μ/(quantumN a0) )^3;
sum5 = sum1+sum2+sum3;  (* +sum4; *) (* not adding in sum4 yet - with triple-log-taming, it is always zero *)
If[debugLevel==1,
Print["sum1 = ",sum1,"\nsum2 = ",sum2,"\nsum3 = ",sum3,"\nsum4 = ",sum4,"\nsum5 = ",sum5]; 
];
sum5
];

LHopitalProcess3[input_, quantumN_] := Module[{sum1,sum2, sum3,sum4,sum5,numterms,termTable,newterm,newterm2, newterm3,newterm4,aexp,appexp,rexp,logexp, order,special1,special2,numtermsSum3,basecoeff,basecoeff2,newsum2,newsum3,debugLevel},
(* computes the value of a tamed, cleaned-up function at the origin *)
(* used in computing Schrodinger Error at origin *)
debugLevel=1;
sum1 = 0;
sum2 = 0;
sum3 = 0;
sum4 = 0;
sum5 = 0;
order = 0;
numterms = NumberOfAdditiveTerms[input ];  
termTable = SplitIntoAdditiveTerms[input];
If[debugLevel==1,
Print["\n\n------------------ LHopitalProcess3 --------------------  "];
Print["input = ",input];
Print["numterms = ",numterms];
Print["termTable = ",termTable];
]

Do [
aexp = Exponent[termTable[[n]] ,A[r] ];
appexp = Exponent[termTable[[n]] ,A''[r] ];
rexp = Exponent[termTable[[n]] ,1/r ];
logexp = Exponent[termTable[[n]] ,Log[r] ];
If[(rexp==(aexp+1))&&(appexp==0),special1=True,special1=False];
If[(rexp==(aexp+2))||( (rexp==(aexp+1))&&(appexp==1) ),special2=True,special2=False];
newterm = If[logexp==1,0,                        (* log case *)
If[special1==True || special2==True ,   0,                         (* special case for high-order application of L'Hopital's Rule *)
termTable[[n]]]];  (* usual rule for non-special cases *)
sum1= sum1+newterm;
newterm2 = If[logexp==1,0,                        (* log case *)
If[special1==True,   termTable[[n]],                         (* special case for high-order application of L'Hopital's Rule *)
0]];  (* usual rule for non-special cases *)
sum2= sum2+newterm2;
newterm3 = If[logexp==1,0,                        (* log case *)
If[special2==True ,   termTable[[n]],                         (* special case for high-order application of L'Hopital's Rule *)
0]];  (* usual rule for non-special cases *)
sum3= sum3+newterm3;
newterm4 = If[logexp==1,If[  aexp>= rexp+logexp,0,termTable[[n]]],                        (* log case *)
0];  (* usual rule for non-special cases *)
sum4= sum4+newterm4;
If[special1==True,order=order+aexp+rexp];
If[debugLevel==1,
Print["n = ",n,"   term = ",termTable[[n]],"   aexp = ",aexp,"   appexp = ",appexp,"   rexp = ",rexp,"   logexp = ",logexp,If[special1==True,"    **SPECIAL 1**",If[special2==True,"    **SPECIAL 2**","               " ]],"   newterm = ",newterm,"   newterm4 = ",newterm4];
];
,{n,1,numterms}];
newsum2 = LHopital[Simplify[sum2],r,1];
numtermsSum3 = NumberOfAdditiveTerms[sum3 ];
basecoeff2=0;
newsum3 = LHopitalProcess2General[sum3,quantumN];

If[debugLevel==1,
Print["sum1 = ",sum1,"\nsum2 = ",sum2,"    newsum2 = ",newsum2,"\nsum3 = ",sum3,"   numtermsSum3 = ",numtermsSum3,"    newsum3 = ",newsum3,"\nsum4 = ",sum4]; 
];
sum1 = sum1/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0) /.A''[0]->  -(2 μ/(quantumN a0) )^2;
sum2 = newsum2/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0)/.A''[0]->  -(2 μ/(quantumN a0) )^2;
sum3 = newsum3/.r->0/.A[0]->0/.A'[0]->  2 μ/(quantumN a0)/.A''[0]->  -(2 μ/(quantumN a0) )^2/.A'''[0]->  (2 μ/(quantumN a0) )^3;
sum5 = sum1+sum2+sum3;  (* +sum4; *) (* not adding in sum4 yet - with triple-log-taming, it is always zero *)
If[debugLevel==1,
Print["sum1 = ",sum1,"\nsum2 = ",sum2,"\nsum3 = ",sum3,"\nsum4 = ",sum4,"\nsum5 = ",sum5]; 
];
sum5
];

Solve3[referenceRlist_,scaleFactor_]:= Module[{ errorIntegral,EqnToSolve,solutionVariables,Allsolutions,numSolutions,distanceTable,bestindex,c0Approximate2,solutionExplicit,SE,debugLevel},
(* global variables used to output:  solution, c0val *)
If[And@@Map[NumberQ,referenceRlist],  
(* only evaluate if numbers passed in as arguments *)
debugLevel = 0;
Off[Solve::ratnz];
(* debugString = ToString[referenceRlist]; 
Pause[2];*)

(* build up the equations from the reference point list *)
EqnToSolve = ((R1approx1BCEqn/.(μ->μval))==0);       (* start with the R'(0)=0 boundary condition *)                     
Do[
EqnToSolve =  EqnToSolve && ((SEeqnTable[[i]]/.(μ->μval))==0);
,{i,1,numOriginEquations}];
Do[
EqnToSolve =  EqnToSolve && ((NeglectSmall[Group[Expand[a0^2R1approx1EqnExpanded/.r->(referenceRlist[[i]]/scaleFactor)/.a0->a0val/.μ->μval],CList],CList,neglectOrder])==0);
,{i,1,numNonOriginEquations}];
(* debugString = "Equations established."; *)

(* establish the solution variables *)
solutionVariables = Flatten[Append[{ε},Flatten[Take[CD,exponentialDepth]] ] ];
(* debugString = "solutionVariables established."; *)

(* solve the system, choose the appropriate solution *)
Allsolutions = Simplify[Solve[EqnToSolve,solutionVariables]];
(* debugString = "Allsolutions found."; *)
numSolutions=Length[Allsolutions];
If [debugLevel==1,
Print["EqnToSolve  = ",MatrixForm[Table[EqnToSolve[[n]],{n,1,Length[EqnToSolve]}]]];
Print["solutionVariables = ",solutionVariables];
Print["numSolutions = ",numSolutions,"     AllSolutions = ",Allsolutions/.μ->μval];
];
If[numSolutions==1,
solution=Allsolutions[[1]]
,
distanceTable = Table[ Abs[(ε/.(Allsolutions/.μ->μval)[[n]])-(ε/.R1SnumParameters)],{n,1,numSolutions}];
bestindex = Position[distanceTable,Min[distanceTable]][[1,1]];
solution = Allsolutions[[bestindex]];
If [debugLevel==1,
Print["distanceTable = ",distanceTable];
Print["bestindex = ",bestindex];
];
];

If [debugLevel==1,Print["solution = ",solution/.μ->μval]];

If[Element[ε/.solution,Reals],

         (* compute c0 *)
 c0Approximate2=1+((5/4)-(EulerGamma/2)) ε;  (* this is the result of the long computation *)
c0val = c0Approximate2/.solution/.μ->μval;
If [debugLevel==1,
Print["*** Using approximate expression for c0 ***"];
Print["c0Approximate = ",c0Approximate2,"   =  ",InputForm[ c0Approximate2/.solution/.μ->μval]];
Print["c0val = ",InputForm[c0val]];
];
solutionExplicit = ((solution/.μ->μval)/.c0->c0val)//N;
SE  = (SchrodingerError[R1approx1[r, a0, ε]/.solutionExplicit/.c0->c0val/.a0->a0val/.μ->μval/.R00->R00val,(Subscript[E, 0])(1+ε/.solutionExplicit),V1[r]]/.{rc->rcval,a0->a0val,hbar->hbarval,mr->mrval} );
errorIntegral=NIntegrate[SE^2,{r,rminForPlot,a0val}];
,
errorIntegral=100;  (* assign horrible value if energy has become complex *)
];
If [debugLevel==1,
Print["errorIntegral = ",errorIntegral];
Print["\n\n\n\n\n"];
];

debugString = "iteration = "<>ToString[FindMinimumIteration]<>"\nreferenceRlist = \n"<>ToString[referenceRlist]<>"\nerrorIntegral = \n"<>ToString[errorIntegral]<>"\nε = \n"<>ToString[ε/.solution];

FindMinimumIteration++;
(* return value *)
errorIntegral
,
(* otherwise, just return without evaluating *)
Hold[Solve3[referenceRlist,scaleFactor] ]
]
];

normSimplify[x_]:= Module[{x1,x1numerator,x1denominator},
(* Gamma[x+1]/Gamma[x] -> x *)  (* This is the key to the simplification *)
x1=x/.(Gamma[2+2 (Sqrt[1-(α^2)])]/Gamma[1+2 (Sqrt[1-(α^2)])])-> (1+2 (Sqrt[1-(α^2)]))/.(Sqrt[2-2 (α^2)])->((Sqrt[2])(Sqrt[1-(α^2)]));
x1numerator = Expand[Numerator[x1]];
x1denominator = Expand[Expand[Denominator[x1]]/.(Sqrt[1-(Sqrt[1-(α^2)])]) (Sqrt[1+(Sqrt[1-(α^2)])])->α/.(Sqrt[1-(Sqrt[1-(α^2)])])-> (1-(Sqrt[1-(α^2)]))(Sqrt[1+(Sqrt[1-(α^2)])])/α];
x2 = x1numerator/x1denominator;
x2
];

(* Zero-th iteration *)
V0[r_]:= -hbar^2/(mr a0 r);                                                                        (* pure Coulomb potential in zero-th iteration *)
R0[r_] := ψSchrodingerRadial[{1, 0, 0}, r, θ,ϕ]/.(Subscript[a, 0])->a0;  (* electron radial wavefunction for zero-th iteration *)
R00 = 2/a0^(3/2);                                                                                                                                                    (* Radial normalization factor for Hydrogen ground state *)

SchrodingerError[R_, E_, V_] := E R+ hbar^2/(2mr)(D[R,{r,2}] +  2/r D[R,r])- V R;  (* General definition *)
SE0[R_,Ed_] := hbar^2/(2mr)(3D[R,{r,2}] +  (2/(a0 rc) - 1/(a0^2) + 2 mr Ed/(hbar^2))  R)/. r->0;  (* General definition *)
SE1[R_,Ed_] := hbar^2/(2mr)(2D[R,{r,3}] +  ( - 1/(a0^2) + 2 mr Ed/(hbar^2))  D[R,r])/. r->0;  (* General definition *)
SE2[R_,Ed_] := hbar^2/(2mr)(5/3D[R,{r,4}] +  (  2/(a0 rc)    - 1/(a0^2) + 2 m rEd/(hbar^2))  D[R,{r,2}]  -8 R/(a0 rc^3)  )/. r->0;  (* General definition *)

(* First iteration, n=1 *)
rc = a0/μ ;
N1[r_] := μ^(3/2)R0[μ r];                                                                          (* nucleus radial charge density for first iteration *)
V1[r_] := V0[r]*( 1 - Exp[-2 r/rc](1 + r /rc)  );                         (* modified Coulomb potential in first iteration for 1S state *)
V1AtOrigin = -LHopital[V1[r],r,1]/.hbar->hbarval/.a0->a0val/.mr->mrval;

R2[r_] := ψSchrodingerRadial[{2, 0, 0}, r, θ,ϕ]/.(Subscript[a, 0])->a0;  (* electron radial wavefunction for zero-th iteration *)
N2[r_] := μ^(3/2)R2[μ r];                                                                          (* nucleus radial charge density for first iteration *)
V2[r_] := V0[r]*( 1 - Exp[- r/rc](1 + (3/4)(r /rc)+(1/4)(r /rc)^2+(1/8)(r /rc)^3)  );  

(* modified Coulomb potential in first iteration for 2S state *)
V2P0[r_] :=V0[r]*(1+(12/((r /rc)^2)) -Exp[- r/rc]((12/((r /rc)^2))+(12/((r /rc)))+7+(11/4)(r /rc)+(3/4)(r /rc)^2+(1/8)(r /rc)^3));
V2P90[r_] := V0[r]*( 1 - Exp[- r/rc](1 + (3/4)r /(rc)+(1/4)(r /rc)^2+(1/19)(r /rc)^3+(1/128)(r /rc)^4+(1/512)(r /rc)^5-(1/17000)(r /rc)^6-(1/240000)(r /rc)^7+(1/100000)(r /rc)^8+(1/6000000000)(r /rc)^12+(1/100000000000000)(r /rc)^16) );
R20 = 1/(2 Sqrt[2] a0^(3/2));                                                                                                                           (* Radial normalization factor for Hydrogen 2S state *)

(* Modified Dirac Equation, 1S1/2 *)
(* modified Coulomb potential in first iteration for 1S1/2 state *)
(*V1S12[r_]:=V0[r]*(((1+(Sqrt[1-(α^2)]))  )/2)(1-((α^2)/(((1+(Sqrt[1-(α^2)])))^2)))  (1-   (((((2r μ)/a0)))^(1+2 (Sqrt[1-(α^2)]))) ((E^(-((2 r μ)/a0)))+ (2 (Sqrt[1-(α^2)])-((2 r μ)/a0)) ExpIntegralE[-2 (Sqrt[1-(α^2)]),((2 r μ)/a0)])/(2  Gamma[1+2 (Sqrt[1-(α^2)])] (Sqrt[1-(α^2)])));*)

f1S12[r_]:= 2/(a0^(3/2))Exp[- r/a0 ](((((2r )/a0)))^(-1+ (Sqrt[1-(α^2)])))Sqrt[(1+Sqrt[1-α^2])/(Gamma[1+2Sqrt[1-α^2]])];
g1S12[r_]:= -α/(1+Sqrt[1-α^2])f1S12[r];
V1S12[r_]:=V0[r]  (1-   (((((2r μ)/a0)))^(1+2 (Sqrt[1-(α^2)]))) ((E^(-((2 r μ)/a0)))+ (2 (Sqrt[1-(α^2)])-((2 r μ)/a0)) ExpIntegralE[-2 (Sqrt[1-(α^2)]),((2 r μ)/a0)])/(2  Gamma[1+2 (Sqrt[1-(α^2)])] (Sqrt[1-(α^2)])));
V1S12Scaled[r_,s1S12_]:=V0[r]  (1-   (((((2r s1S12 μ)/a0)))^(1+2 (Sqrt[1-(α^2)]))) ((E^(-((2 r s1S12 μ)/a0)))+ (2 (Sqrt[1-(α^2)])-((2 r s1S12 μ)/a0)) ExpIntegralE[-2 (Sqrt[1-(α^2)]),((2 r s1S12 μ)/a0)])/(2  Gamma[1+2 (Sqrt[1-(α^2)])] (Sqrt[1-(α^2)])));
ElectronRho1S12[r_]:=e /(Pi a0^3)Exp[-2 r/a0 ](2 r/a0)^(2(-1+Sqrt[1-α^2])) 2/(Gamma[1+2Sqrt[1-α^2]]) ;
ElectronRho1S12NoSingularity[r_]:=e /(Pi a0^3)Exp[-2 r/a0 ] 2/(Gamma[1+2Sqrt[1-α^2]]);
ElectronRho00 = e /(Pi a0^3) 2/(Gamma[1+2Sqrt[1-α^2]]) ;
Rho1S12[r_]:=e (μ^3)/(Pi a0^3)Exp[-2 μ r/a0 ](2 μ r/a0)^(2(-1+Sqrt[1-α^2])) 2/(Gamma[1+2Sqrt[1-α^2]]) ;
Rho00 = e (μ^3)/(Pi a0^3)2/(Gamma[1+2Sqrt[1-α^2]]) ;
ElectronRhoShiftTerm = (2 r/a0)^(2(-1+Sqrt[1-α^2])) ;



(* gamma definitions *)
gamma0 = (Sqrt[1-(α^2)]);
gamma1 = (Sqrt[((1+(Sqrt[1-(α^2)]) )/(2 ))]);
gamma2 = (( (Sqrt[2-2(Sqrt[1-(α^2)])]))/( α ));
gamma3 = ((gamma2 )/(gamma1 ))(( (1+(Sqrt[2]) (Sqrt[1+(Sqrt[1-(α^2)])])) )/( (1+2 (Sqrt[1-(α^2)]))));
gamma4 =  (Sqrt[(((2+(Sqrt[2+2(Sqrt[1-(α^2)])])) )/((1+(Sqrt[1-(α^2)]))(1+  (Sqrt[2+2(Sqrt[1-(α^2)])]))))]) ((Sqrt[Gamma[2+2 (Sqrt[1-(α^2)])]  ])/(Gamma[1+2 (Sqrt[1-(α^2)])]));

gamma5=((2+(Sqrt[2]) (Sqrt[1+(Sqrt[1-(α^2)])]) )/4);
gamma6=((gamma2 )/gamma5)(( (1+(Sqrt[2]) (Sqrt[1+(Sqrt[1-(α^2)])])))/( (1+2 (Sqrt[1-(α^2)]))));
gamma7 = (-((4(1+2 (Sqrt[1-(α^2)]))(-2+ (Sqrt[2+2(Sqrt[1-(α^2)])])) )/( 3(α^2) )));
gamma8 = (( (Sqrt[2-2 (Sqrt[1-(α^2)])])(-1+ (Sqrt[2+2(Sqrt[1-(α^2)])])))/(α  ));
gamma9 = 2(Sqrt[3])  ((Sqrt[Gamma[2+2 (Sqrt[1-(α^2)])]  ])/(Gamma[1+2 (Sqrt[1-(α^2)])]))(1/((1+2 (Sqrt[1-(α^2)]))(1+(Sqrt[1-(α^2)]))))(Sqrt[(((2+(Sqrt[2+2(Sqrt[1-(α^2)])])) )/((-2+2(Sqrt[2+2(Sqrt[1-(α^2)])]))))]);
gamma10 = (( 6(-1+ (Sqrt[2+2(Sqrt[1-(α^2)])])))/( (1+2 (Sqrt[1-(α^2)])) (1+(Sqrt[1-(α^2)]))));

gamma11 = ((4/(Sqrt[3])))(1/(Sqrt[(-2+2  (Sqrt[2+2(Sqrt[1-(α^2)])]))(2+(Sqrt[2+2(Sqrt[1-(α^2)])]))]))((Sqrt[Gamma[2+2 (Sqrt[1-(α^2)])]  ])/(Gamma[1+2 (Sqrt[1-(α^2)])]));


gammaratioOriginal=gamma9/gamma11;
gammaratioSimplified=((3 (2+(Sqrt[2+2 (Sqrt[1-(α^2)])])) )/(2 (1+(Sqrt[1-(α^2)])) (1+2 (Sqrt[1-(α^2)]))));
Print["gammaratioOriginal = ",gammaratioOriginal," = ",gammaratioOriginal/.α->alpha//N];
Print["gammaratioSimplified = ",gammaratioSimplified," = ",gammaratioSimplified/.α->alpha//N];
gammaratio = gammaratioSimplified;

gamma7 = (-((4(1+2 (Sqrt[1-(α^2)]))(-2+ (Sqrt[2+2(Sqrt[1-(α^2)])])) )/( 3(α^2) )))gammaratio;
gamma8 = (( (Sqrt[2-2 (Sqrt[1-(α^2)])])(-1+ (Sqrt[2+2(Sqrt[1-(α^2)])])))/(α  ))gammaratio;
gamma9 = gamma11;

Clear[gamma11];
gamma11 = (gamma1^4)gamma3+((gamma6 (α^2))/(8 ));

gamma12 = (gamma1^5)(gamma3^2)+(((gamma6^2) (α^2))/(16 ));
gamma13=((3  (gamma6 (α^2)+gamma3 (4-2 (α^2)+4 (Sqrt[1-(α^2)]))))/(8 gamma1 (1+2 (Sqrt[1-(α^2)]))));
gamma14=((  ((gamma3^2) (8-4 (α^2)+8 (Sqrt[1-(α^2)]))+(gamma6^2) (α^2)))/(16(gamma1^2)));
gamma15= -(1/(24 gamma0))(gamma4^2) (-24 Gamma[1+2 (Sqrt[1-(α^2)])]+16 gamma0 gamma13 Gamma[2+2 (Sqrt[1-(α^2)])]-3 gamma0 gamma14 Gamma[3+2 (Sqrt[1-(α^2)])]);
gamma16=((-2(gamma4^2) (-2 (α^4)-12 (1+(Sqrt[1-(α^2)]))+(α^2) (13+7 (Sqrt[1-(α^2)]))) )/( (gamma2^3) (Sqrt[1-(α^2)]) (((1+(Sqrt[1-(α^2)])))^3) (3-2 (α^2)+3 (Sqrt[1-(α^2)]))));
gamma17 = (3(gamma4^2) (gamma6 (α^2) (2 (1+(Sqrt[1-(α^2)]))-(α^2) (2+(Sqrt[1-(α^2)])))+2 gamma3 (8 (1+(Sqrt[1-(α^2)]))+(α^4) (4+(Sqrt[1-(α^2)]))-4 (α^2) (3+2 (Sqrt[1-(α^2)])))) )/(2 (gamma2^4) (Sqrt[1-(α^2)]) (((1+(Sqrt[1-(α^2)])))^3) (3-2 (α^2)+3 (Sqrt[1-(α^2)])));
gamma18=  32(gamma4^2)  ((gamma6^2) (α^2) (3 (1+(Sqrt[1-(α^2)]))-(α^2) (3+2 (Sqrt[1-(α^2)])))+4 (gamma3^2) (12 (1+(Sqrt[1-(α^2)]))+(α^4) (7+2 (Sqrt[1-(α^2)]))-(α^2) (19+13 (Sqrt[1-(α^2)]))))  /(64  (gamma2^5) (Sqrt[1-(α^2)]) (((1+(Sqrt[1-(α^2)])))^3) (3-2 (α^2)+3 (Sqrt[1-(α^2)])));

Print["\n\n--------------------------------------------\nFINAL SUMMARY OF GAMMA VALUES: "];
Print["gamma0 = ",gamma0," = ",InputForm[gamma0/.α->alpha//N]];
Print["gamma1 = ",gamma1," = ",InputForm[gamma1/.α->alpha//N]];
Print["gamma2 = ",gamma2," = ",InputForm[gamma2/.α->alpha//N]];
Print["gamma3 = ",gamma3," = ",InputForm[gamma3/.α->alpha//N]];
Print["gamma4 = ",gamma4," = ",InputForm[gamma4/.α->alpha//N]];
Print["gamma5 = ",gamma5," = ",InputForm[gamma5/.α->alpha//N]];
Print["gamma6 = ",gamma6," = ",InputForm[gamma6/.α->alpha//N]];
Print["gamma7 = ",gamma7," = ",InputForm[gamma7/.α->alpha//N]];
Print["gamma8 = ",gamma8," = ",InputForm[gamma8/.α->alpha//N]];
Print["gamma9 = ",gamma9," = ",InputForm[gamma9/.α->alpha//N]];
Print["gamma10 = ",gamma10," = ",InputForm[gamma10/.α->alpha//N]];
Print["gamma11 = ",gamma11," = ",InputForm[gamma11/.α->alpha//N]];
Print["gamma12 = ",gamma12," = ",InputForm[gamma12/.α->alpha//N]];
Print["gamma13 = ",gamma13," = ",InputForm[gamma13/.α->alpha//N]];
Print["gamma14 = ",gamma14," = ",InputForm[gamma14/.α->alpha//N]];
Print["gamma15 = ",gamma15," = ",InputForm[gamma15/.α->alpha//N]];
Print["gamma16 = ",gamma16," = ",InputForm[gamma16/.α->alpha//N]];
Print["gamma17 = ",gamma17," = ",InputForm[gamma17/.α->alpha//N]];
Print["gamma18 = ",gamma18," = ",InputForm[gamma18/.α->alpha//N]];
Print["--------------------------------------------\n"];
gamma0val = gamma0;
gamma1val = gamma1;
gamma2val = gamma2;
gamma3val = gamma3;
gamma4val = gamma4;
gamma5val = gamma5;
gamma6val = gamma6;
gamma7val = gamma7;
gamma8val = gamma8;
gamma9val = gamma9;
gamma10val = gamma10;
gamma11val = gamma11;
gamma12val = gamma12;
gamma13val = gamma13;
gamma14val = gamma14;
gamma15val = gamma15;
gamma16val = gamma16;
gamma17val = gamma17;
gamma18val = gamma18;
Clear[gamma0,gamma1,gamma2,gamma3,gamma4,gamma5,gamma6,gamma7,gamma8,gamma9,gamma10,gamma11,gamma12,gamma13,gamma14,gamma15,gamma16,gamma17,gamma18];

ElectronRho2S12[r_]:=e  (gamma4^2)/(32Pi a0^3)Exp[-  r gamma2/a0 ](  r gamma2/a0)^(2(-1+Sqrt[1-α^2])) ((2- r gamma3/a0)^2+(α(4-r gamma6/a0)/(2(1+Sqrt[1-α^2])))^2) ;
ElectronRho20 = e  (gamma4^2)/(32Pi a0^3) (2^2+(α 4/(2(1+Sqrt[1-α^2])))^2)  ;
Rho2S12[r_]:=e (μ^3) (gamma4^2)/(32Pi a0^3)Exp[- μ r gamma2/a0 ]( μ r gamma2/a0)^(2(-1+Sqrt[1-α^2])) ((2-μ r gamma3/a0)^2+(α(4-μ r gamma6/a0)/(2(1+Sqrt[1-α^2])))^2) ;
Rho00 = e (μ^3)/(Pi a0^3)2/(Gamma[1+2Sqrt[1-α^2]]) ;
Rho20 = e  (μ^3)(gamma4^2)/(32Pi a0^3) (2^2+(α 4/(2(1+Sqrt[1-α^2])))^2);
f2S12[r_]:= 1/(2 (Sqrt[2])a0^(3/2))(2- r gamma3/a0)Exp[- r gamma2/(2 a0) ](((((r gamma2)/a0)))^(-1+ (Sqrt[1-(α^2)])))gamma4;
g2S12[r_]:= -α/(2(1+Sqrt[1-α^2]))1/(2 (Sqrt[2])a0^(3/2))(4-r gamma6/a0)Exp[- r gamma2/(2 a0) ](((((r gamma2)/a0)))^(-1+ (Sqrt[1-(α^2)])))gamma4;

V2S12raw[r_]:= V0[r](1+(-((gamma1 (gamma4^2))/2)+(((gamma4^2) r μ)/(4 a0 gamma0)))Gamma[1+2 (Sqrt[1-(α^2)]),((gamma2 r μ)/a0)]+(1/2 gamma4^2 gamma11+-1/6  r μ/a0 gamma4^2gamma13)Gamma[2+2 (Sqrt[1-(α^2)]),((gamma2 r μ)/a0)] +(-1/8 gamma4^2 gamma12+1/32  r μ/a0 gamma4^2gamma14)Gamma[3+2 (Sqrt[1-(α^2)]),((gamma2 r μ)/a0)]+
(E^(-((gamma2 r μ)/a0)))(((((gamma2 r μ)/a0)))^(1+2 (Sqrt[1-(α^2)])))( -(1/4)  gamma16+(1/6)  gamma17 (((gamma2 r μ)/a0))-(1/32) gamma18  (((((gamma2 r μ)/a0)))^2))  );
V2S12[r_]:=V2S12raw[r]/.gamma18->gamma18val/.gamma17->gamma17val/.gamma16->gamma16val/.gamma11->gamma11val/.gamma12->gamma12val/.gamma13->gamma13val/.gamma14->gamma14val/.gamma0->gamma0val/.gamma1->gamma1val/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha/.a0->a0val/.μ->μval;

V2S12rawScaled[r_, s2S12_]:= V0[r](1+(-((gamma1 (gamma4^2))/2)+(((gamma4^2) r s2S12 μ)/(4 a0 gamma0)))Gamma[1+2 (Sqrt[1-(α^2)]),((gamma2 r s2S12 μ)/a0)]+(1/2 gamma4^2 gamma11+-1/6  r s2S12 μ/a0 gamma4^2gamma13)Gamma[2+2 (Sqrt[1-(α^2)]),((gamma2 r s2S12 μ)/a0)] +(-1/8 gamma4^2 gamma12+1/32  r s2S12 μ/a0 gamma4^2gamma14)Gamma[3+2 (Sqrt[1-(α^2)]),((gamma2 r s2S12 μ)/a0)]+
(E^(-((gamma2 r s2S12 μ)/a0)))(((((gamma2 r s2S12 μ)/a0)))^(1+2 (Sqrt[1-(α^2)])))( -(1/4)  gamma16+(1/6)  gamma17 (((gamma2 r s2S12 μ)/a0))-(1/32) gamma18  (((((gamma2 r s2S12 μ)/a0)))^2))  );
V2S12Scaled[r_, s2S12_]:=V2S12rawScaled[r, s2S12]/.gamma18->gamma18val/.gamma17->gamma17val/.gamma16->gamma16val/.gamma11->gamma11val/.gamma12->gamma12val/.gamma13->gamma13val/.gamma14->gamma14val/.gamma0->gamma0val/.gamma1->gamma1val/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha/.a0->a0val/.μ->μval;


(* Polynomial Fit by fitting error function *)
Rdp[r_] := Module[{rFactor, rR,b0,b1,b2,b3, b4,b5,b6, b7,b8,b9,val}, 
rFactor = Sqrt[3 /μ] ;   (*  roundedness of top, 0.04042 was found empirically. *)
rR = rFactor a0;  (* determined by examining schrodinger error near r=0 *)
b0 = -0.00069;  (* -0.00073692 *)
b1 = 1;
b2 = -1;
b3 = 0;
b4 =900; (* 900 *)
b5 =-27000; (*  *)
b6 =270000; (* -1800000 *)
b7 =70000; (* -800000 *)
b8 = 0; (* -500000 *)
b9 = -165000000; (* -500000 *)
val = R00(b0+b1(r/(a0))+b2(r/(rR))^2+b3(r/(rR))^3+b4(r/(rR))^4+b5(r/(rR))^5+b6(r/(rR))^6+b7(r/(rR))^7+b8(r/(rR))^8+b9(r/(rR))^9);
val
];
R1p[r_] := R0[r] + Rdp[r]; 

(* Single-term Exponential Fit *)
Clear[NULL, a0d, a0dval, RDSE, a0dDefault];
RdSEparameters := Module[{a0dDefault, rFDefault},
a0dDefault = -0.000817244;
rFDefault = -a0dDefault a0/rc;                     (* constraint to ensure slope at origin of new solution is 0 *)
{a0dDefault, rFDefault}
];
RdSE[r_] := Module[{a0dDefault, val},
(* a0dDefault = -0.000817244; *)                             (* adjustable parameter default value *)
a0dDefault = RdSEparameters[[1]];                              (* adjustable parameter default value *)
val = RdSEparam[r, a0dDefault]; 
val
];  
RdSEparam[r_, a0d_] := Module[{Rd0, rF, val}, 
Rd0 = a0d R00; 
rF = -Rd0 a0/R00;                                                  (* constraint to ensure slope at origin of new solution is 0 *)
val = Rd0  Exp[-r/(rF)] ;                                   (* function definition *)
val
];
R1SEparam[r_, a0d_] := R0[r] + RdSEparam[r, a0d]; 
R1SE[r_] := R0[r] + RdSE[r];

(* Double-term Exponential Fit *)
RdDEparameters := Module[{a1dDefault, a0dDefault, rF1dDefault,rF0dDefault},
(* a1dDefault = -0.0008812747920000101;                                 
a0dDefault = 0.00022233;
rF1dDefault = 0.9914600220000117; *)
a1dDefault = -0.00074691270;                                 
a0dDefault = 0.00008080252;
rF1dDefault = 1.0719063692; 
rF0dDefault =  -a0dDefault a0 rF1dDefault rc/ (  rF1dDefault rc + a1dDefault a0 )/rc;    (* constraint to ensure slope at origin of new solution is 0 *)
{a1dDefault, a0dDefault, rF1dDefault,rF0dDefault}
];
RdDE[r_] := Module[{a1dDefault, a0dDefault, rF1dDefault,  val},
a1dDefault = RdDEparameters[[1]];                                 
a0dDefault = RdDEparameters[[2]];
rF1dDefault = RdDEparameters[[3]];                (* leads to rF0Default of 0.645840593 *)                                 
val = RdDEparam[r, a1dDefault, a0dDefault, rF1dDefault ];
val
];

RdDEparam[r_, a1d_, a0d_, rF1d_] := Module[{rF0, rF1, Rd0,Rd1, val}, 
Rd1 = a1d R00; 
Rd0 = a0d  R00;
rF1 = rF1d rc;
rF0 = -a0d a0 rF1 / ( rF1 + a1d a0 );        (* constraint to ensure slope at origin of new solution is 0 *)
val = Rd0 Exp[-r*(1/(rF0))] +  Rd1 Exp[-r*(1/rF1)];  (* function definition *)
val
];
R1DEparam[r_, a1d_, a0d_, rF1d_] := R0[r] + RdDEparam[r, a1d, a0d, rF1d]; 
R1DE[r_] := R0[r] + RdDE[r]; 
rF0constrained[a1d_, a0d_, rF1d_] := Module[{rF0, rF1, Rd0,Rd1}, 
Rd1 = a1d R00; 
Rd0 = a0d R00;
rF1 = rF1d rc;
rF0 = -Rd0 a0 rF1 / ( R00 rF1 + Rd1 a0 ) / rc;        (* constraint to ensure slope at origin of new solution is 0 *)
rF0 
];

(* Triple-term Exponential Fit *)
RdTEparameters := Module[{a1dDefault, a0dDefault, rF1dDefault,rF0dDefault,rF2dDefault, a2dDefault},
a1dDefault = 0.0000837488;                                 
a0dDefault = -1.04201513192*10^(-8);
rF1dDefault = 0.5359400594;
rF0dDefault = 0.643721609;
rF2dDefault = 1.07003381;  (* leads to a2dDefault of -0.000749950 *)  
a2dDefault = -rF2dDefault rc (1/a0 + a0dDefault /(rF0dDefault rc ) + a1dDefault/(rF1dDefault rc )  );  (* constraint to ensure slope at origin of new solution is 0 *)
{a1dDefault, a0dDefault, rF1dDefault,rF0dDefault,rF2dDefault, a2dDefault}
];
RdTE[r_] := Module[{a1dDefault, a0dDefault, rF1dDefault, rF0dDefault, rF2dDefault,val},
a1dDefault = RdTEparameters[[1]];                                 
a0dDefault = RdTEparameters[[2]];
rF1dDefault = RdTEparameters[[3]];
rF0dDefault = RdTEparameters[[4]];
rF2dDefault = RdTEparameters[[5]];  (* leads to a2dDefault of -0.000749950 *)  
val = RdTEparam[r, a1dDefault, a0dDefault, rF1dDefault, rF0dDefault, rF2dDefault];
val
];

RdTEparam[r_, a1d_, a0d_,rF1d_, rF0d_, rF2d_] := Module[{rF0, rF1, rF2, Rd0,Rd1, Rd2, val}, 
Rd1 = a1d R00; 
Rd0 = a0d R00;
rF2 = rF2d rc;
rF1 = rF1d rc;
rF0 = rF0d rc;                            
Rd2 = -rF2 (R00/a0 + Rd0/rF0 + Rd1/rF1  );  (* constraint to ensure slope at origin of new solution is 0 *)
(* Print["Rd2 / R00 = ",Rd2/R00]; *)
val = Rd0 Exp[-r*(1/(rF0))] +  Rd1 Exp[-r*(1/rF1)] +  Rd2 Exp[-r*(1/rF2)];  (* function definition *)
val
];
R1TEparam[r_, a1d_, a0d_,rF1d_, rF0d_, rF2d_] := R0[r] + RdTEparam[r, a1d, a0d,rF1d, rF0d, rF2d]; 
R1TE[r_] := R0[r] + RdTE[r]; 

(* Stretched Hypergeometric *)
R1SH[r_] := Module[{cU, cF, Edval, f,val}, 
cU = 1.0000020049432417 R00;
cF = 0.6041079765502242*10^(-6) R00;
Edval =-1.18497* 10^(-6) (Subscript[E, 0]);
f = 0.666881 rc Exp[ -0.85 r/rc -0.11(r/rc)^2];
val = Simplify[Exp[-r/a0]Exp[ (1/a0-Sqrt[1/a0^2 -2 m Edval/hbar^2])(r+f)](cF  Hypergeometric1F1[1-(1/(a0 (Sqrt[(1/(a0^2))-((2 Edval m)/(hbar^2))]))),2,2 (Sqrt[(1/(a0^2))-((2 Edval m)/(hbar^2))]) (r+f)]+cU HypergeometricU[1-(1/(a0 (Sqrt[(1/(a0^2))-((2 Edval m)/(hbar^2))]))),2,2 (Sqrt[(1/(a0^2))-((2 Edval m)/(hbar^2))]) (r+f)])];
val
];

RdSH[r_] := -R0[r] + R1SH[r];
R1SHgen[r_, f_[r_],cU_,cF_,Ed_] := Module[{ val}, 
val = Simplify[Exp[-r/a0]Exp[ (1/a0-Sqrt[1/a0^2 -2 m Ed/hbar^2])(r+f[r])](cF  Hypergeometric1F1[1-(1/(a0 (Sqrt[(1/(a0^2))-((2 Ed m)/(hbar^2))]))),2,2 (Sqrt[(1/(a0^2))-((2 Ed m)/(hbar^2))]) (r+f[r])]+cU HypergeometricU[1-(1/(a0 (Sqrt[(1/(a0^2))-((2 Ed m)/(hbar^2))]))),2,2 (Sqrt[(1/(a0^2))-((2 Ed m)/(hbar^2))]) (r+f[r])])];
val
];

PrintReport := Module[{nearZero},
nearZero = .1*10^(-19);
Print["SINGLE EXPONENTIAL:   \t\t\tDOUBLE EXPONENTIAL\t\t\t\tTRIPLE EXPONENTIAL"];
Print["-------------------------------------------------------------------------------------------"];
Print["Rd0 = ",RdSEparameters[[1]]," R00","\t\t\t",      "Rd1 = ",RdDEparameters[[1]]," R00","\t\t\t",           "Rd2 = ",RdTEparameters[[6]]," R00"];
Print["rF0 = ",RdSEparameters[[2]]," rc  ","\t\t\t\t","rF1 = ",RdDEparameters[[3]]," rc","\t\t\t","      rF2 = ",RdTEparameters[[5]]," rc"];
Print["                      ","\t\t\t",                                  "Rd0 = ",RdDEparameters[[2]]," R00","  \t\t\t",      "Rd0 = ",RdTEparameters[[2]]," R00"];
Print["                      ","\t\t\t",                                  "rF0 = ",RdDEparameters[[4]]," rc","\t\t\t",  "     rF0 = ",RdTEparameters[[4]]," rc"];
Print["                      ","\t\t\t","                      ","\t\t\t",                                                                        "Rd1 = ",RdTEparameters[[1]]," R00"];
Print["                      ","\t\t\t","                      ","\t\t\t",                                                                        "rF1 = ",RdTEparameters[[3]]," rc"];
Print["-------------------------------------------------------------------------------------------"];
Print[                             "SE0 = ",SchrodingerError[R1SE[r],(Subscript[E, 0]),V1[r]]/.r->nearZero, 
"                  SE0 = ",SchrodingerError[R1DE[r],(Subscript[E, 0]),V1[r]]/.r->nearZero,
"                  SE0 = ",SchrodingerError[R1TE[r],(Subscript[E, 0]),V1[r]]/.r->nearZero];
Print[                              "SE0 = ",SE0[R1SE[r],0], 
"                  SE0 = ",SE0[R1DE[r],0],
"                  SE0 = ",SE0[R1TE[r],0]];
Print[                          "SE1 = ",D[SchrodingerError[R1SE[r],(Subscript[E, 0]),V1[r]],r]/.r->nearZero,
 "                SE1 = ",D[SchrodingerError[R1DE[r],(Subscript[E, 0]),V1[r]],r]/.r->nearZero,
"                SE1 = ",D[SchrodingerError[R1TE[r],(Subscript[E, 0]),V1[r]],r]/.r->nearZero];
Print[                         "SE1 = ",SE1[R1SE[r],0],
 "                SE1 = ",SE1[R1DE[r],0],
"                SE1 = ",SE1[R1TE[r],0]];
Print[                        "SE2 = ",D[SchrodingerError[R1SE[r],(Subscript[E, 0]),V1[r]],{r,2}]/.r->nearZero,
 "               SE2 = ",D[SchrodingerError[R1DE[r],(Subscript[E, 0]),V1[r]],{r,2}]/.r->nearZero,
"               SE2 = ",D[SchrodingerError[R1TE[r],(Subscript[E, 0]),V1[r]],{r,2}]/.r->nearZero];
Print[                          "SE2 = ",SE2[R1SE[r],0],
 "               SE2 = ",SE2[R1DE[r],0],
"               SE2 = ",SE2[R1TE[r],0]];
0
];
Printfg[matrix_] := Module[{newmatrix,width, height},
height = Length[matrix];
width = Length[matrix[[1]]];
newmatrix = Table[0,{i,1,height},{j,1,width}];
Do[
newmatrix[[i,j]] = If[j<=width-2,matrix[[i,j]],If[ ToString[matrix[[i,j]]]=="1" ,"  1  ",If[ ToString[matrix[[i,j]]]=="0" ,"  0  ","{ "<>ToString[Length[matrix[[i,j]]]]<>" }"] ]   ];
,{j,1,width},{i,1,height}];
Print[MatrixForm[newmatrix]]
];
PrintfgLastOne[matrix_] := Module[{newmatrix,width, height},
height = Length[matrix];
width = Length[matrix[[1]]];
newmatrix = Table[0,{i,1,height},{j,1,width}];
Do[
newmatrix[[i,j]] = If[j<=width-1,matrix[[i,j]],If[ ToString[matrix[[i,j]]]=="1" ,"  1  ",If[ ToString[matrix[[i,j]]]=="0" ,"  0  ","{ "<>ToString[Length[matrix[[i,j]]]]<>" }"] ]   ];
,{j,1,width},{i,1,height}];
Print[MatrixForm[newmatrix]]
];
NormalizeRowByElement[matrix_,row_,column_] :=Module[{newmatrix,keyelement,width},
newmatrix = matrix;
width = Length[matrix[[1]]];
keyelement = matrix[[row,column]];
(* Print["keyelement = ",keyelement]; *)
If[ToString[keyelement]≠ "0",
Do[
newmatrix[[row,j]] = Expand[Simplify[matrix[[row,j]]/keyelement] ];
,{j,1,width}],
Print["Warning: attempt to Normalize by a zero-valued element - Nothing done.\n"];
];
newmatrix (* return value *)
];
EliminateElementFromRow[matrix_,row_,column_,victimrow_] :=Module[{newmatrix,keyelement,width,victimelement},
newmatrix = matrix;
width = Length[matrix[[1]]];
keyelement = matrix[[row,column]];
victimelement = matrix[[victimrow,column]];
(* Print["keyelement = ",keyelement]; *)
If[ToString[keyelement]≠ "0" && ToString[victimelement]≠ "0",
Do[
(* newmatrix[[row,j]] = Expand[Simplify[matrix[[row,j]]/keyelement] ]; *) (* normalize source row *)
newmatrix[[victimrow,j]] = Expand[Simplify[matrix[[victimrow,j]]-matrix[[row,j]]victimelement/keyelement] ];  (* modify victim row *)
,{j,1,width}],
Print["Warning: attempt to Eliminate by a zero-valued element - Nothing done.\n"];
];
newmatrix (* return value *)
];
EliminateElementFromAllRows[matrix_,row_,column_] :=Module[{newmatrix,keyelement,width,height,victimelement},
newmatrix = matrix;
height = Length[matrix];
width = Length[matrix[[1]]];
keyelement = matrix[[row,column]];
(* Print["keyelement = ",keyelement]; *)
If[ToString[keyelement]≠ "0",
Do[
(* newmatrix[[row,j]] = Expand[Simplify[matrix[[row,j]]/keyelement] ]; *) (* normalize source row *)
If[i≠row,
victimelement = matrix[[i,column]];
If[ToString[victimelement]≠ "0",
Do[
newmatrix[[i,j]] = Expand[Simplify[matrix[[i,j]]-matrix[[row,j]]victimelement/keyelement] ];  (* modify victim row *)
,{j,1,width}];
]
]
,{i,1,height}],
Print["Warning: attempt to Eliminate by a zero-valued element - Nothing done.\n"];
];
newmatrix (* return value *)
];

(* 2-term exponential fit *)
RdHyperPlusExp[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval},
cU = 1.00000261;
b1 = 1.6/rc;
a2 = 0.00005 R00;
b2 = 2.9/rc;
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 Exp[-b2 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0];
returnval
];
R1HyperPlusExp[r_] :=R0[r] + RdHyperPlusExp[r] ;
RdHyperPlusExpPure1[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval},
cU = 1.00000261;
b1 = 2/rc;
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) );
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0];
returnval
];
R1HyperPlusExpPure1[r_] :=R0[r] + RdHyperPlusExpPure1[r] ;
RdHyperPlusExpPure2[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval,a11},
cU = 1.00000261;
b1 = 2/rc;
a11 = .00027;
a2 = 0.0000 R00; 
b2 = 4/rc;
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 Exp[-b2 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0];
returnval
];
R1HyperPlusExpPure2[r_] :=R0[r] + RdHyperPlusExpPure2[r] ;

(* 5-term exponential fit *)
cUval = 1.00000321;  (* 1.00000261 *)
Edval =-1.18497* 10^(-6) (Subscript[E, 0]);
RdHyper[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval},
cU = cUval;
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ;
returnval
];
RdHyperPlusExpPure1[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval},
cU = cUval;
b1 = 2/rc;
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) );
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0];
returnval
];
RdHyperPlusExpPure1a[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval,a11},
cU = cUval;
b1 = 2/rc;
a11 = 0.0002685;  (* .00027 *)  
(* -.0000016Exp[-3.7r/rc] *)
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) );
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1Hyper[r_] :=R0[r] + RdHyper[r] ;
R1HyperPlusExpPure1[r_] :=R0[r] + RdHyperPlusExpPure1[r] ;
R1HyperPlusExpPure1a[r_] :=R0[r] + RdHyperPlusExpPure1a[r] ;

RdHyperPlusExpPure2[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,returnval,a11},
cU = cUval;
b1 = 2/rc;
a11 = 0.0002685;  (* .00027 *)
(* -.0000016Exp[-3.7r/rc] *)
a2 = -.0000004 R00;   (* -.0000018 R00 *) 
b2 = 4.0/rc;                   (* 3.0/rc *)
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 Exp[-b2 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1HyperPlusExpPure2[r_] :=R0[r] + RdHyperPlusExpPure2[r] ;
RdHyperPlusExpPure3[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,a3,b3,returnval,a11},
cU = cUval;
b1 = 2/rc;
a11 = 0.0002685;  (* .00027 *)
(* -.0000016Exp[-3.7r/rc] *)
a2 = -.0000004 R00;   (* -.0000018 R00 *)
b2 = 4.0/rc;                   (* 3.0/rc *)
a3 = -.00000025 R00;   (* -.0000018 R00 *)  
b3 =6.0/rc;                   (* 3.0/rc *)
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 Exp[-b2 r]+a3 Exp[-b3 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1HyperPlusExpPure3[r_] :=R0[r] + RdHyperPlusExpPure3[r] ;
RdHyperPlusExpPure4[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,a3,b3,a4,b4,returnval,a11},
cU = cUval;
b1 = 2/rc;
a11 = 0.0002685;  (* .00027 *)
(* -.0000016Exp[-3.7r/rc] *)
a2 = -.0000004 R00;   (* -.0000018 R00 *)
b2 = 4.0/rc;                   (* 3.0/rc *)
a3 = -.00000025 R00;   (* -.0000018 R00 *)  
b3 =6.0/rc;                   (* 3.0/rc *)
a4 = -.00000010 R00;   (* -.0000018 R00 *)  (********************** EDIT *********************)
b4 =12.0/rc;                   (* 3.0/rc *)
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 Exp[-b2 r]+a3 Exp[-b3 r]+a4 Exp[-b4 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1HyperPlusExpPure4[r_] :=R0[r] + RdHyperPlusExpPure4[r] ;
RdHyperPlusExpPure5[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,a3,b3,a4,b4,a5,b5,r0,returnval,a11},
cU = cUval;
b1 = 2/rc;
a11 = 0.0002685;  (* .00027 *)
(* -.0000016Exp[-3.7r/rc] *)
a2 = -.0000004 R00;   (* -.0000018 R00 *)
b2 = 4.0/rc;                   (* 3.0/rc *)
a3 = -.00000025 R00;   (* -.0000018 R00 *)  
b3 =6.0/rc;                   (* 3.0/rc *)
a4 = -.00000010 R00;   (* -.0000018 R00 *)  
b4 =12.0/rc;                   (* 3.0/rc *)
a5 = -.000000015 R00;   (* -.0000018 R00 *)  (* ********************* EDIT ******************** *)
b5 =30.0/rc;                   (* 3.0/rc *)
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 Exp[-b2 r]+a3 Exp[-b3 r]+a4 Exp[-b4 r]+a5 Exp[-b5 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1HyperPlusExpPure5[r_] :=R0[r] + RdHyperPlusExpPure5[r] ;
R1PolyFit[r_] :=R00 (.999182995 - .0001814 (r/rc)^2+ .000035(r/rc)^4);
R1Composite[r_] :=Module[{crossfactor},
crossfactor = 6;
Crossfade[crossfactor r/rc]R1PolyFit[r] + (1-Crossfade[crossfactor r/rc])R1HyperPlusExpPure5[r]
];
RdComposite[r_] := R1Composite[r]-R0[r];

RdInversePlusExpPure5[r_] := Module[{cU,Edval,f,a0hat,b1,a2,b2,a3,b3,a4,b4,a5,b5,r0,returnval,a11},
cU = cUval;
b1 = 2/rc;
a11 = 0.0002685;  (* .00027 *)
(* -.0000016Exp[-3.7r/rc] *)
a2 = -.0000004 R00;   (* -.0000018 R00 *)
b2 = 4.0/rc;                   (* 3.0/rc *)
a3 = -.00000025 R00;   (* -.0000018 R00 *)  
b3 =6.0/rc;                   (* 3.0/rc *)
a4 = -.00000010 R00;   (* -.0000018 R00 *)  
b4 =12.0/rc;                   (* 3.0/rc *)
a5 = -.000000015 R00;   (* -.0000018 R00 *)  (* ********************* EDIT ******************** *)
b5 =30.0/rc;                   (* 3.0/rc *)
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- (1-rc^2/(a0hat r)) ) +a2 Exp[-b2 r]+a3 Exp[-b3 r]+a4 Exp[-b4 r]+a5 Exp[-b5 r]);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r](1-rc^2/(a0hat r)) + f  Exp[-r/a0hat];
returnval
];
R1InversePlusExpPure5[r_] :=R0[r] + RdInversePlusExpPure5[r] ;
R1CompositeInverse[r_] :=Module[{crossfactor},
crossfactor = 6;
Crossfade[crossfactor r/rc]R1PolyFit[r] + (1-Crossfade[crossfactor r/rc])R1InversePlusExpPure5[r]
];
RdCompositeInverse[r_] := R1CompositeInverse[r]-R0[r];

R1Analytic[r_, numterms_] := Module[{Edval,c0, c1, c2, c , a0hat, returnval,fudge},
fudge = 30;
Edval = -(8μ+4)/(2μ^3+9μ^2+7μ)(Subscript[E, 0]);
c0 = ((2μ^3+9μ^2+9μ+3)/(2μ^3+9μ^2+7μ)) ; 
c1 = (2μ+3)/(2μ+2)c0;
c2 = -fudge(2μ+1)/(4(3μ+1)(2μ^2+9μ+7))*c0 ;
c = Table[ 0 ,{n,1,numterms}];
Do[
c[[n]] = If[n==1,c1,  
                 If[n==2,c2, 
                    c[[n-1]](n+1)/(2n) ]];
,{n,1,numterms}];
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
returnval =  R00  Exp[(- 1/a0hat)r](c0 HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] (1-  Exp[-2r/rc]) + Sum[ c[[n]]Exp[-2 n r/rc] ,{n,1,numterms}]);
returnval
];
RdAnalytic[r_, numterms_] :=-R0[r] + R1Analytic[r, numterms] ;

(* zeroth-order approximation *)
HypergeometricUApprox[r_, ε_] :=  (1+ε/2(a0/(2 r)-Log[2 r/a0]));  
ExpApprox[r_, ε_] :=  Exp[(- (1+ε/2)/a0)r];  

(* first-order approximation *)
(* HypergeometricUApprox[r_, ε_] :=  (1+ε/2(a0/(2 r)-Log[2 r/a0])+ε^2((-1/2 + EulerGamma/4-EulerGamma^2/8-Pi^2/16)+a0/(8 r)(-1+EulerGamma)+r/(8 a0)(5-2EulerGamma) +(1/4)Log[2 r/a0](1-EulerGamma - r/a0)));   
ExpApprox[r_, ε_] :=  Exp[(- (1+ε/2-(ε^2)/8)/a0)r];  *)

(* Full Accuracy *)
(* HypergeometricUApprox[r_, ε_] :=  HypergeometricU[1-1/Sqrt[1+ε],2,2 r/a0 Sqrt[1+ε]];  
ExpApprox[r_, ε_] :=  Exp[(- Sqrt[1+ε]/a0)r];  *)



R1Approx0[r_, ε_ ,c0_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε]  );
returnval
];
RdApprox0[r_, ε_ ,c0_] :=-R0[r] + R1Approx0[r, ε ,c0] ;
R1Approx1[r_, ε_ ,c0_, μ_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε] (1-  Exp[-2μ r/a0]) +  Exp[-2 μ r/a0] );
returnval
];
RdApprox1[r_, ε_ ,c0_,μ_] :=-R0[r] + R1Approx1[r, ε ,c0,μ] ;
R1Approx1a[r_, ε_ ,c0_, c1_, μ_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε] (1-  Exp[-2μ r/a0]) + c1 Exp[-2 μ r/a0] );
returnval
];
RdApprox1a[r_, ε_ ,c0_, c1_,μ_] :=-R0[r] + R1Approx1a[r, ε ,c0, c1,μ] ;
R1Approx2[r_, ε_ ,c0_, c1_, c2_,μ_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε] (1-  Exp[-2μ r/a0]) + c1 Exp[-2 μ r/a0] + c2 Exp[-4 μ r/a0]);
returnval
];
RdApprox2[r_, ε_ ,c0_, c1_, c2_,μ_] :=-R0[r] + R1Approx2[r, ε ,c0, c1, c2,μ] ;
R1Approx3[r_, ε_ ,c0_, c1_, c2_,c3_,μ_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε] (1-  Exp[-2μ r/a0]) + c1 Exp[-2 μ r/a0] + c2 Exp[-4 μ r/a0]+ c3 Exp[-6 μ r/a0]);
returnval
];
RdApprox3[r_, ε_ ,c0_, c1_, c2_,c3_,μ_] :=-R0[r] + R1Approx3[r, ε ,c0, c1, c2,c3,μ] ;
R1Approx4[r_, ε_ ,c0_, c1_, c2_,c3_,c4_,μ_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε] (1-  Exp[-2μ r/a0]) + c1 Exp[-2 μ r/a0] + c2 Exp[-4 μ r/a0]+ c3 Exp[-6 μ r/a0]+ c4 Exp[-8 μ r/a0]);
returnval
];
RdApprox4[r_, ε_ ,c0_, c1_, c2_,c3_,c4_,μ_] :=-R0[r] + R1Approx4[r, ε ,c0, c1, c2,c3,c4,μ] ;
R1Approx5[r_, ε_ ,c0_, c1_, c2_,c3_,c4_,c5_,μ_] := Module[{returnval},
returnval =  R00  ExpApprox[r, ε](c0 HypergeometricUApprox[r,ε] (1-  Exp[-2μ r/a0]) + c1 Exp[-2 μ r/a0] + c2 Exp[-4 μ r/a0]+ c3 Exp[-6 μ r/a0]+ c4 Exp[-8 μ r/a0]+ c5 Exp[-10 μ r/a0]);
returnval
];
RdApprox5[r_, ε_ ,c0_, c1_, c2_,c3_,c4_,c5_,μ_] :=-R0[r] + R1Approx5[r, ε ,c0, c1, c2,c3,c4,c5,μ] ;

U1approx[r_, a0_, ε_] := 1+ε/2( a0/(2 r)  - Log[2r/a0] );
R1Approximation01[r_] :=  Module[{CD,exponentialDepth,polyLogDepth,c0val,solution},
exponentialDepth =2;
polyLogDepth = 1;
CD =           { {{c10,d10},{c11,d11}},
                    {{c20,d20},{c21,d21}}       };
c0val = 1.00000323 ;
solution = {ε->((4+8 μ)/(3+μ-5 (μ^2)-2 (μ^3))),c10->((c0 (3+2 μ))/(2 (1+μ))),d10->((c0 (1+2 μ) (3+2 μ))/((1+μ) (-3-μ+5 (μ^2)+2 (μ^3)))),c11->0,d11->((c0 (((1+2 μ))^2))/(μ (((1+μ))^2) (-3-μ+5 (μ^2)+2 (μ^3)))),c20->(c0/(8+24 μ+16 (μ^2))),d20->(c0/(4 (1+μ) (-3-μ+5 (μ^2)+2 (μ^3)))),c21->((c0 (-5-10 μ+32 (μ^2)+66 (μ^3)+28 (μ^4)))/(16 μ (1+μ) (((1+2 μ))^2) (-3-μ+5 (μ^2)+2 (μ^3)))),d21->((c0 (2+8 μ+7 (μ^2)))/(4 μ (((1+μ))^2) (1+2 μ) (-3-μ+5 (μ^2)+2 (μ^3))))};
R00 Exp[-1/a0 (1+ε/2)r](c0 U1approx[r, a0, ε](1-Exp[-2 μ r/a0])+ Sum[Exp[-2 n μ r/a0](a0/r)^k(CD[[n,k+1,1]]+CD[[n,k+1,2]]Log[2r/a0]),{n,1,exponentialDepth},{k,0,polyLogDepth}])/.solution/.μ->μval/.c0->c0val/.R00->R00val/.a0->a0val
];
R1Approximation02[r_] :=  Module[{CD,exponentialDepth,polyLogDepth,c0val,solution},
exponentialDepth =2;
polyLogDepth = 1;
CD =           { {{c10,d10},{c11,d11}},
                    {{c20,d20},{c21,d21}}       };
c0val = 1.00000323 ;
solution = {ε->((4+8 μ)/(3+μ-5 (μ^2)-2 (μ^3))),c10->((c0 (3+2 μ))/(2 (1+μ))),d10->((c0 (1+2 μ) (3+2 μ))/((1+μ) (-3-μ+5 (μ^2)+2 (μ^3)))),c11->0,d11->((c0 (((1+2 μ))^2))/(μ (((1+μ))^2) (-3-μ+5 (μ^2)+2 (μ^3)))),c20->(c0/(8+24 μ+16 (μ^2))),d20->(c0/(4 (1+μ) (-3-μ+5 (μ^2)+2 (μ^3)))),c21->((c0 (-5-10 μ+32 (μ^2)+66 (μ^3)+28 (μ^4)))/(16 μ (1+μ) (((1+2 μ))^2) (-3-μ+5 (μ^2)+2 (μ^3)))),d21->((c0 (2+8 μ+7 (μ^2)))/(4 μ (((1+μ))^2) (1+2 μ) (-3-μ+5 (μ^2)+2 (μ^3))))};
(R00 Exp[-1/a0 (1+ε/2)r](c0 U1approx[r, a0, ε](1-Exp[-2 μ r/a0])+ Sum[Exp[-2 n μ r/a0](a0/r)^k(CD[[n,k+1,1]]+CD[[n,k+1,2]]Log[2r/a0]),{n,1,exponentialDepth},{k,0,polyLogDepth}]) -R00* ((-.000000135(-.00015a0/r+20+Log[2 r/a0]))Exp[-4 μ r/a0])    )/.solution/.μ->μval/.c0->c0val/.R00->R00val/.a0->a0val
];
R1Approximation03[r_] :=  Module[{CD,exponentialDepth,polyLogDepth,c0val,solution},
exponentialDepth =2;
polyLogDepth = 1;
CD =           { {{c10,d10},{c11,d11}},
                    {{c20,d20},{c21,d21}}       };
c0val = 1.00000323 ;
solution = {ε->((4+8 μ)/(3+μ-5 (μ^2)-2 (μ^3))),c10->((c0 (3+2 μ))/(2 (1+μ))),d10->((c0 (1+2 μ) (3+2 μ))/((1+μ) (-3-μ+5 (μ^2)+2 (μ^3)))),c11->0,d11->((c0 (((1+2 μ))^2))/(μ (((1+μ))^2) (-3-μ+5 (μ^2)+2 (μ^3)))),c20->(c0/(8+24 μ+16 (μ^2))),d20->(c0/(4 (1+μ) (-3-μ+5 (μ^2)+2 (μ^3)))),c21->((c0 (-5-10 μ+32 (μ^2)+66 (μ^3)+28 (μ^4)))/(16 μ (1+μ) (((1+2 μ))^2) (-3-μ+5 (μ^2)+2 (μ^3)))),d21->((c0 (2+8 μ+7 (μ^2)))/(4 μ (((1+μ))^2) (1+2 μ) (-3-μ+5 (μ^2)+2 (μ^3))))};
(R00 Exp[-1/a0 (1+ε/2)r](c0 U1approx[r, a0, ε](1-Exp[-2 μ r/a0])+ Sum[Exp[-2 n μ r/a0](a0/r)^k(CD[[n,k+1,1]]+CD[[n,k+1,2]]Log[2r/a0]),{n,1,exponentialDepth},{k,0,polyLogDepth}]) -R00* ((-.000000135(-.00015a0/r+20+Log[2 r/a0]))Exp[-4 μ r/a0]) - R00*((.0000000000102(a0/r)Exp[-60 μ r/a0]))    )/.solution/.μ->μval/.c0->c0val/.R00->R00val/.a0->a0val
];

RdHyperPlusPoly5[r_] := Module[{cU,Edval,f,a0hat,b1,a2,a3,a4,a5,returnval,a11},
cU = 1.000002767;
b1 = 2/rc;
a11 = 0.0002700;  
a2 =    .00000000052 R00; (* .00000000134 R00; *)   
a3 = -.000000000000244 R00;  
a4 =  -.00000000000000000420 R00; 
a5 =  -.00000000000000000000000000000000000000000025 R00; 
Edval = -.00000118497(Subscript[E, 0]);
a0hat = 1/Sqrt[1/a0^2-2 m Ed/hbar^2]/.Ed->Edval;
f = (cU R00 Exp[-b1 r](1+a11- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +a2 (1-Exp[-b1 r])*(a0/r)+a3 ((1-Exp[-b1 r])*(a0/r))^2+a4 ((1-Exp[-b1 r])*(a0/r))^3+a5 ((1-Exp[-b1 r])*(a0/r))^10);
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1HyperPlusPoly5[r_] :=R0[r] + RdHyperPlusPoly5[r] ;
R1PolyFit3[r_] :=R00 (.999183005 - .00018134 (r/rc)^2+ .00000010(r/rc)^3  + .0000352(r/rc)^4 - .0000205(r/rc)^5+ .00000501(r/rc)^6);
R1Composite3[r_] :=Module[{crossfactor},
crossfactor = 1.7;
Crossfade[crossfactor r/rc]R1PolyFit3[r] + (1-Crossfade[crossfactor r/rc])R1HyperPlusPoly5[r]
];
RdComposite3[r_] := R1Composite3[r]-R0[r];

RdHyperPlusPoly6[r_] := Module[{cU,Edval,f,a0hat,b1,a01,a02,a03,a04,a05,a06,a07,a08,a09,a10,a11,a12,a13,a14,a15,
b06,b07,b08,b09,b10,b11,b12,b13,b14,b15,returnval},
cU = 1.000002767;
b1 = 2/rc;
a01 = 0.0002700;  
a02 =    .00000000052 R00; (* .00000000134 R00; *)   
a03 = -.000000000000244 R00;  
a04 =  -.00000000000000000420 R00; 
a05 =  -2.0`*^-27; 

(* a06 =  -1.039`*^-43; 
a07 =    3.117`*^-54; 
a08 =   60`*^-72; *)

a06 =40`*^-43; 
a07 = 2.5`*^-53; 
a08 =  0`*^-72; 
a09 =  0.0`*^-89; (* *)
a10 =  0.00`*^-106;   
a11 = 0.01`*^-141; 
a12 =  -0.00`*^-197; 

b06 = 0.01;
b07 = -.0000000005;
b08 = .0000000000002;
b09 = .00000000000000004;
b10 = -.0000000000000000000000000000000000000000000000000001;
b11 = -2`*^-120;  (* *)
(* b06 = 2;
b07 = -.00000020;
b08 = .0000000000002;
b09 = .00000000000000005;
b10 = .0000000000000000095;
b11 = 1.4`*^-28;
b12 = 3.0`*^-43;
b13 = .01`*^-79; *)

Edval = -.00000118497(Subscript[E, 0]);  (* previous best *)
a0hat = 1/Sqrt[1/a0^2-2 m Edval/hbar^2];
f = (cU R00 Exp[-b1 r](1+a01- HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] ) +
a02 (1-Exp[-b1 r])*(a0/r)+
a03 ((1-Exp[-b1 r])*(a0/r))^2+
a04 ((1-Exp[-b1 r])*(a0/r))^3+
a05 ((1-Exp[-b1 r])*(a0/r))^10 + 
a06 ((1-Exp[-b1 r])*(a0/r))^14 + 
a07 ((1-Exp[-b1 r])*(a0/r))^17 + 
a08 ((1-Exp[-b1 r])*(a0/r))^22  +
a09 ((1-Exp[-b1 r])*(a0/r))^27  +
a10 ((1-Exp[-b1 r])*(a0/r))^32  +
a11 ((1-Exp[-b1 r])*(a0/r))^42 +   
a12 ((1-Exp[-b1 r])*(a0/r))^58    +

b06 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^2+
b07 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^4 +
b08 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^5 +
b09 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^6 +
b10 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^16 +
b11 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^36 
(* + 
b06 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^2 +
b07 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^4 +
b08 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^5 +
b09 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^6 +
b10 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^7  +
b11 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^10 +
b12 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^14 +
b13 Exp[-b1 r]Log[2 r/a0](1-Exp[-b1 r])((1-Exp[-b1 r])(a0/r))^25 *)
  );
returnval = -R00  Exp[-r/a0] +cU R00  Exp[(- 1/a0hat)r]HypergeometricU[1-a0hat/a0,2,2 r/a0hat  ] + f  Exp[-r/a0hat];
returnval
];
R1HyperPlusPoly6[r_] :=R0[r] + RdHyperPlusPoly6[r] ;
R1PolyFit4[r_] :=R00 (.999183008 - .00018134 (r/rc)^2+ -.00000002(r/rc)^3  + .0000358(r/rc)^4 - .00002202(r/rc)^5+ .00000648(r/rc)^6- .0000000256(r/rc)^7- .000000026(r/rc)^9);
R1Composite4[r_] :=Module[{crossfactor},
crossfactor = 2.0;
Crossfade[crossfactor r/rc]R1PolyFit4[r] + (1-Crossfade[crossfactor r/rc])R1HyperPlusPoly6[r]
];
RdComposite4[r_] := R1Composite4[r]-R0[r];

R1Approximation05[r_] :=  Module[{CD,exponentialDepth,polyLogDepth,c0val,solution,logTame},
exponentialDepth =1;
polyLogDepth = 2;
logTame = 2;
CD =           { {{c10,d10},{c11,d11},{c12,d12}} };
c0val = 0.999998861888186 ;
solution = {ε->((6+20 μ+34 (μ^2)+32 (μ^3))/(2+9 μ+18 (μ^2)-11 (μ^3)-39 (μ^4)-8 (μ^5))),c10->((c0 (3+2 μ))/(2 (1+μ))),d10->((c0 (5+4 μ) (3+10 μ+17 (μ^2)+16 (μ^3)))/(2 (1+μ) (-2-9 μ-18 (μ^2)+11 (μ^3)+39 (μ^4)+8 (μ^5)))),c11->((c0 (11+33 μ+28 (μ^2)+25 (μ^3)+65 (μ^4)+58 (μ^5)))/(4 μ (((1+μ))^2) (-2-9 μ-18 (μ^2)+11 (μ^3)+39 (μ^4)+8 (μ^5)))),d11->(((c0+2 c0 μ) (3+10 μ+17 (μ^2)+16 (μ^3)))/(2 μ (((1+μ))^2) (-2-9 μ-18 (μ^2)+11 (μ^3)+39 (μ^4)+8 (μ^5)))),c12->((c0 (-5+μ+32 (μ^2)+4 (μ^3)-78 (μ^4)-64 (μ^5)))/(8 (μ^2) (((1+μ))^2) (-2-9 μ-18 (μ^2)+11 (μ^3)+39 (μ^4)+8 (μ^5)))),d12->-(((c0+2 c0 μ) (3+10 μ+17 (μ^2)+16 (μ^3)))/(4 (μ^2) (((1+μ))^3) (-2-9 μ-18 (μ^2)+11 (μ^3)+39 (μ^4)+8 (μ^5))))};
( R00 Exp[-1/a0 (1+ε/2)r](c0 (1(1-Exp[-2 μ r/a0])+ε/2( (1-Exp[-2 μ r/a0])a0/(2 r)  - (1-Exp[-2 μ r/a0])^logTame Log[2r/a0] ))+ Sum[ Exp[-2 n μ r/a0] ((1-Exp[-(2) μ r/a0])(a0/r))^k(CD[[n,k+1,1]]+CD[[n,k+1,2]]Log[2r/a0](1-Exp[-(2) μ r/a0])^logTame),{n,1,exponentialDepth},{k,0,polyLogDepth}])  )/.solution/.c0->c0val/.μ->μval/.R00->R00val/.a0->a0val 


];
RdApproximation05[r_] := R1Approximation05[r]-R0[r];

(* set up R1S numerical solution *)
f1[r_]:= (E^((-(Sqrt[1+εval])) r/a0))  HypergeometricU[1-(1/( (Sqrt[1+εval]))),2,2(Sqrt[1+εval]) r/a0];
Off[InterpolatingFunction::dmval];
Off[NIntegrate::ncvb];
εval= -1.1843071020237506`*^-6;                    (* -.00000100000;  *)
rmax = 2000a0val / 1836;
rmin = rmax/1000000000;

relativeError = Infinity;
relativeErrorThreshold = 10^(-6);

RdZero = -0.0008211580472791136` * R00;  (* -0.0004 R00; *)
RdPrimeZero = R00/a0;
normTolerance = 1*10^-7;
normError = Infinity;
Clear[Rd];
Rdsoln = NDSolve[{Rd''[r]+ Rd'[r]( 2/r)+ Rd[r](-(1+εval)/a0^2+2/(a0 r) (1-Exp[-2 r/rc](1+r/rc)) )+R00 Exp[-r/a0](-(εval)/a0^2 -2/(a0 r) Exp[-2 r/rc](1+r/rc) )==0,Rd[rmin]==RdZero,Rd'[rmin]==RdPrimeZero},Rd,{r,rmin,rmax}];
R1Sd[r_] := Evaluate[Rd[r]/.Rdsoln][[1]];
R1S[r_] := R1Sd[r]+R0[r]; 

(* choose two points from numerical solution *)
r1 = 200rc;
r2 = 600 rc; 
R1Sdnumr1 = R1Sd[r1];
R1Sdnumr2 = R1Sd[r2];

(* determine cU to match numerical solution at the first point *)
f1r1 = f1[r1];
f1r2 = f1[r2];
cUval =  (R1Sdnumr1+R00 Exp[-r1/a0])/f1r1;  (* 1.000002114970299 R00 *)
error = (cUval f1r2-R00 Exp[-r2/a0]-R1Sdnumr2)/R00;
relativeError = (1-R1Sdnumr2/(cUval f1r2-R00 Exp[-r2/a0]));
relativeErrorString = If[Abs[relativeError]<relativeErrorThreshold,"PASS","FAIL"];

RdHyper[r_] :=cUval f1[r]- R00 Exp[-r/a0];
R1Hyper[r_] := R0[r] + RdHyper[r]; 

normIntegral =NIntegrate[r^2 *(R1S[r])^2,{r,rmin,r1}]+NIntegrate[r^2 *(R1Hyper[r])^2,{r,r1,Infinity}];
normError = normIntegral-1;
normTestString = If[Abs[normError]<normTolerance,"PASS","FAIL"];

Print["   iteration2 = ",iteration2," εval = ",εval,"  RdZero/R00 = ",RdZero/R00,"  normIntegral = ",normIntegral,"  normError = ",normError,"   ",normTestString];

Print["iteration = ",iteration," εval = ",εval," cU/R00  = ",cUval/R00,"  error = ",error," = ",relativeError*100,"%  ",relativeErrorString];

peakval = (R1S[rmin]/(R00))^2;
Print["peakval = ",peakval];

R1Snum[r_] := R1S[r];
R1Sdnum[r_] := R1Snum[r]-R0[r];
R1SnumParameters = {ε->εval, cU->cUval};
ε1Sval=εval;

(* set up R2S numerical solution - tight version for initialization cell *)
Off[InterpolatingFunction::dmval];
Off[NIntegrate::ncvb];
a0=a0val;
rc=rcval;
f1[r_]:= (E^((-(Sqrt[1+εval])) r/(2a0)))  HypergeometricU[1-(2/( (Sqrt[1+εval]))),2,(Sqrt[1+εval]) r/a0];
(* εval = -7.383661893915934`*^-7; *)  (* old value, came from buggy formulation *)
εval =-8.254138708069398*^-6;    (* new value, from fixed formulation *)
rmax = 2a0val (1-.000000001);
rmin = 2a0val (1-.000000001)/10000000000000;

iteration = 1;
maxIterations = 8;
resultRecord = Table[{0,Infinity},{n,1,2}];
relativeError = Infinity;
relativeErrorThreshold = 10^(-6);
lastεval = εval;
While [(Abs[relativeError]≥relativeErrorThreshold) && (iteration≤maxIterations),


RdZero = -0.006612591164204538*R20; (* -0.0008 R20*2; *)
RdPrimeZero = 2R20/a0val;
normTolerance = 1*10^-7;
iteration2 = 1;
maxIterations2 = 8;
resultRecord2 = Table[{0,Infinity},{n,1,2}];
normError = Infinity;
lastRdZero = RdZero;

While [(Abs[normError]≥normTolerance) && (iteration2≤maxIterations2),
Clear[R2d];
(* old method, with bug *)
(* R2dsoln = NDSolve[{Rd''[r]+ Rd'[r]( 2/r)+ Rd[r](-(1+εval)/(4a0^2)+2/(a0 r) (1-Exp[- r/rc](1+(3/4)r/rc+(1/4)(r/rc)^2+(1/8)(r/rc)^3)) )+R20 (2-r/a0)Exp[-r/(2a0)](-(εval)/(4a0^2) -2/(a0 r) Exp[- r/rc]Exp[- r/rc](1+(3/4)r/rc+(1/4)(r/rc)^2+(1/8)(r/rc)^3) )==0,Rd[rmin]==RdZero,Rd'[rmin]==RdPrimeZero},Rd,{r,rmin,rmax}]; *)
(* new method, bug fixed *)
R2dsoln = NDSolve[{R2d''[r]+ R2d'[r]( 2/r)+ R2d[r](-(1+εval)/(4a0^2)+2/(a0 r) (1-Exp[- r/rc](1+(3/4)r/rc+(1/4)(r/rc)^2+(1/8)(r/rc)^3)) )+R20 (2-r/a0)Exp[-r/(2a0)](-(εval)/(4a0^2) -2/(a0 r) Exp[- r/rc](1+(3/4)r/rc+(1/4)(r/rc)^2+(1/8)(r/rc)^3) )==0,R2d[rmin]==RdZero,R2d'[rmin]==RdPrimeZero},R2d,{r,rmin,rmax}];
R2Sd[r_] := Evaluate[R2d[r]/.R2dsoln][[1]];
R2S[r_] := R2Sd[r]+R2[r];

(* choose two points from numerical solution *)
r1 = 200rc;
r2 = 1600 rc; 
R2Sdnumr1 = R2Sd[r1];
R2Sdnumr2 = R2Sd[r2];

(* determine cU to match numerical solution at the first point *)
f1r1 = f1[r1];
f1r2 = f1[r2];

cUval =  (R2Sdnumr1+R20 (2-r1/a0)Exp[-r1/(2a0)])/f1r1;  (* 1.000002114970299 R00 *)
error = (cUval f1r2-R20 (2-r2/a0)Exp[-r2/(2a0)]-R2Sdnumr2)/R20;
relativeError = (1-R2Sdnumr2/(cUval f1r2-R20 (2-r2/a0)Exp[-r2/(2a0)]));
relativeErrorString = If[Abs[relativeError]<relativeErrorThreshold,"PASS","FAIL"];

RdHyper[r_] :=cUval f1[r]- R20 (2-r/a0)Exp[-r/(2a0)];
R2Hyper[r_] := R2[r] + RdHyper[r];


normIntegral =NIntegrate[r^2 *(R2S[rmin])^2,{r,0,rmin}]+
NIntegrate[r^2 *(R2S[r])^2,{r,rmin,r1}]+
NIntegrate[r^2 *(R2Hyper[r])^2,{r,r1,2 a0 - rmin}]+
NIntegrate[r^2 *(R2Hyper[r])^2,{r,2 a0 - rmin,2 a0 + rmin}]+
NIntegrate[r^2 *(R2Hyper[r])^2,{r,2 a0 + rmin,Infinity}]; 
normError = normIntegral-1;
normTestString = If[Abs[normError]<normTolerance,"PASS","FAIL"];

Print["   iteration2 = ",iteration2," εval = ",εval,"  RdZero/R20 = ",RdZero/R20,"  normIntegral = ",normIntegral,"  normError = ",normError,"   ",normTestString];

lastRdZero = RdZero;
If[iteration2==1,
         resultRecord2[[1]]={RdZero,normError};
         RdZero = RdZero*1.01;
         , 
                 (* find slot with worst error *)
                  badSlot = If[Abs[resultRecord2[[1,2]]]>Abs[resultRecord2[[2,2]]],1,2];
                  (* overwrite it *)
                   resultRecord2[[badSlot]]={RdZero,normError};
                  (* use existing content to determine next energy value *)
                          
             RdZero = resultRecord2[[1,1]] - (resultRecord2[[2,1]]-resultRecord2[[1,1]] )*(resultRecord2[[1,2]])/(resultRecord2[[2,2]]-resultRecord2[[1,2]]);
         ];

iteration2++;

];
RdZero = lastRdZero;
Print["iteration = ",iteration," εval = ",εval," point1  = ",(R2Sdnumr1)/R20," point2 = ",(R2Sdnumr2)/R20," fit = ",(cUval f1r2-R20 (2-r2/a0)Exp[-r2/(2a0)])/R20," cU/R20  = ",cUval/R20,"  error = ",error," = ",relativeError*100,"%  ",relativeErrorString];

lastεval = εval;
If[iteration==1,
         resultRecord[[1]]={εval,relativeError};
         εval = εval*1.01;
         , 
                 (* find slot with worst error *)
                  badSlot = If[Abs[resultRecord[[1,2]]]>Abs[resultRecord[[2,2]]],1,2];
                  (* overwrite it *)
                   resultRecord[[badSlot]]={εval,relativeError};
                  (* use existing content to determine next energy value *)
                    εval = resultRecord[[1,1]] - (resultRecord[[2,1]]-resultRecord[[1,1]] )*(resultRecord[[1,2]])/(resultRecord[[2,2]]-resultRecord[[1,2]]);
         ];
(* Print["resultRecord = ",resultRecord]; *)

iteration++;
];
εval = lastεval;
peakval = (R2S[rmin]/(2 R20))^2;
Print["peakval = ",InputForm[peakval]];

R2Snum[r_] := R2S[r];
R2Sdnum[r_] := R2Snum[r]-R2[r];
R2SnumParameters = {ε->εval, cU->cUval};
ε2Sval=εval;

(* set up R1S1/2m numerical solution - tight version for initialization cell *)
Compute1S12Error[gfRatioFactorZero_, gfRatioFactorRmax_, εval_] := Module[{TotalError,debugLevel},
If[NumberQ[εval],
debugLevel = 2;
Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha/(1+Sqrt[1-alpha^2]));
workingPrecisionForNDSolve = 24;  
rmaxForPlot = 7a0val ;
rmaxForNorm = 28.798a0val ;  (* not used, rmaxInward is used instead *)
rmin = a0val/100000000000;

A[r_]:= V1S12[r]/V0[r];
f1S12mEqn = f1S12m'[r]-((1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])g1S12m[r];
g1S12mEqn = g1S12m'[r]+2/r g1S12m[r]+((-1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])f1S12m[r];

rmid1 = 11 rcval;
rmid2 = 40rcval;
f1S12mZero =  1.000R00/.a0->a0val;  
g1S12mZero = f1S12mZero*gfRatioStandard*gfRatioFactorZero;  
fgmsolnOutward=NDSolve[{(f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f1S12m[rmin]==f1S12mZero,g1S12m[rmin]==g1S12mZero},{f1S12m[r],g1S12m[r]},{r,0,Infinity},WorkingPrecision->workingPrecisionForNDSolve];

rmaxInward = 30a0val;
f1S12mrmax =  0.0000000000000936R00/.a0->a0val;  
g1S12mrmax = f1S12mrmax*gfRatioStandard*gfRatioFactorRmax;  
fgmsolnInward=NDSolve[{(f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f1S12m[rmaxInward]==f1S12mrmax,g1S12m[rmaxInward]==g1S12mrmax},{f1S12m[r],g1S12m[r]},{r,0,Infinity},WorkingPrecision->workingPrecisionForNDSolve];

(* impose continuity at midpoint *)
f1S12mOutwardMidpoint = (f1S12m[r]/.fgmsolnOutward[[1]]/.r->rmid1)/R00val;
f1S12mInwardMidpoint = (f1S12m[r]/.fgmsolnInward[[1]]/.r->rmid1)/R00val;
InwardScaleFactor = f1S12mOutwardMidpoint/f1S12mInwardMidpoint;

normIntegralOutward =NIntegrate[r^2 *((f1S12m[r]/.fgmsolnOutward[[1]])^2+(g1S12m[r]/.fgmsolnOutward[[1]])^2),{r,rmin,rmid1}];

normIntegralInward =NIntegrate[r^2 *((InwardScaleFactor f1S12m[r]/.fgmsolnInward[[1]])^2+(InwardScaleFactor g1S12m[r]/.fgmsolnInward[[1]])^2),{r,rmid1,rmaxInward}];
normIntegralTotal = normIntegralOutward+normIntegralInward;
scaleFactorTotal = Sqrt[1/normIntegralTotal];

       ElectronRho1S12fgmsolnOutward[r_]:= ((scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val)^2+( scaleFactorTotal g1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val )^2);
ElectronRho1S12fgmsolnInward[r_]:= ((scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val)^2+( scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val )^2);
fOutwardDifference = (scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val)-(f1S12[r]/R00/.a0->a0val/.α->alpha);
fInwardDifference = (scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val)-(f1S12[r]/R00/.a0->a0val/.α->alpha);
gOutwardDifference = (scaleFactorTotal g1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val)-(g1S12[r]/R00/.a0->a0val/.α->alpha);
gInwardDifference = (scaleFactorTotal InwardScaleFactor  g1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val)-(g1S12[r]/R00/.a0->a0val/.α->alpha);
ElectronRho1S12fgmOutwardDifference = (ElectronRho1S12fgmsolnOutward[r])-(ElectronRho1S12[r] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval);
ElectronRho1S12fgmInwardDifference = (ElectronRho1S12fgmsolnInward[r])-(ElectronRho1S12[r] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval);

fOutwardRmid2 = fOutwardDifference/.r->rmid2;
fInwardRmid2 = fInwardDifference/.r->rmid2;
gOutwardRmid1 = gOutwardDifference/.r->rmid1;
gInwardRmid1 = gInwardDifference/.r->rmid1;
gOutwardRmid2 = gOutwardDifference/.r->rmid2;
gInwardRmid2 = gInwardDifference/.r->rmid2;
(*
ErrorTerm1 = 1-fInwardRmid2/fOutwardRmid2;
ErrorTerm2 = 1-gInwardRmid1/gOutwardRmid1;
ErrorTerm3 = 1-gInwardRmid2/gOutwardRmid2;
*)
(* simpler error metric *)
ErrorTerm1 = fOutwardRmid2-fInwardRmid2;
ErrorTerm2 = gOutwardRmid1-gInwardRmid1;
ErrorTerm3 = gOutwardRmid2-gInwardRmid2;

(* primary output value *)
TotalError = ErrorTerm1^2+ErrorTerm2^2+ErrorTerm3^2;

If[debugLevel==1,
Print["εval = ",εval];
Print["f1S12mOutwardMidpoint = ",f1S12mOutwardMidpoint];
Print["f1S12mInwardMidpoint = ",f1S12mInwardMidpoint];
Print["InwardScaleFactor = ",InwardScaleFactor];
Print["normIntegralOutward = ",normIntegralOutward];
Print["normIntegralInward = ",normIntegralInward];
Print["normIntegralTotal = ",normIntegralTotal];
Print["scaleFactorTotal = ",scaleFactorTotal];

Print["fOutwardRmid2 = ",fOutwardRmid2];
         Print["fInwardRmid2 = ",fInwardRmid2];
         Print["gOutwardRmid1 = ",gOutwardRmid1];
         Print["gInwardRmid1 = ",gInwardRmid1];
Print["gOutwardRmid2 = ",gOutwardRmid2];
         Print["gInwardRmid2 = ",gInwardRmid2];

         Print["ErrorTerm1 = ",ErrorTerm1];
         Print["ErrorTerm2 = ",ErrorTerm2];
         Print["ErrorTerm3 = ",ErrorTerm3];
         Print["TotalError = ",TotalError];
];
If[debugLevel==2,
Print["εval = ",InputForm[εval],"       TotalError = ",TotalError];
];
(* return value *)
TotalError
,
Print["First Localization Pass for Compute1S12Error"]; 
Hold[Compute1S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ]
]
];

ε1S12val=-1.1847160839418804*^-6;
Compute1S12Error[0, 1, ε1S12val];
f1S12num[r_] := scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val;
g1S12num[r_] := scaleFactorTotal g1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val;
ElectronRho1S12num[r_]:=((scaleFactorTotal f1S12m[r]/.fgmsolnOutward[[1]]/.a0->a0val)^2+( scaleFactorTotal g1S12m[r]/.fgmsolnOutward[[1]]/.a0->a0val )^2); ;
(* f1S12num[r]
g1S12num[r]
ElectronRho1S12num[r] *)

(* Define Compute2S12Error[] function *)
Compute2S12Error[gfRatioFactorZero_, gfRatioFactorRmax_, εval_] := Module[{TotalError,debugLevel},
If[NumberQ[εval],
debugLevel = 2;
If[debugLevel==1,Print["Beginning Compute2S12Error[].   εval = ",εval]];
Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha/(1+Sqrt[1-alpha^2]));
workingPrecisionForNDSolve = 24;  
rmaxForPlot = 7a0val ;
rmin = a0val/100000000000;

A[r_]:= V2S12[r]/V0[r];
f2S12mEqn = f2S12m'[r]-((1+gamma1+ε(-1+gamma1))/(α a0)+α/r A[r])g2S12m[r];
g2S12mEqn = g2S12m'[r]+2/r g2S12m[r]+((-1+gamma1+ε(-1+gamma1))/(α a0)+α/r A[r])f2S12m[r];

rmid1 = 11 rcval;
rmid2 = 40rcval;
f2S12mZero =  1.000R20val;  
g2S12mZero = gfRatioFactorZero f2S12mZero*gfRatioStandard;  

If[debugLevel==1,Print["Beginning NDSolve Outward.  "]];
fg2S12msolnOutward=NDSolve[{(f2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f2S12m[rmin]==f2S12mZero,g2S12m[rmin]==g2S12mZero},{f2S12m[r],g2S12m[r]},{r,0,Infinity},WorkingPrecision->workingPrecisionForNDSolve];

rmaxInward = 30a0val;
f2S12mrmax =  f2S12[rmaxInward]/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha; (* 0.0000000000000936R20/.a0->a0val *);  
g2S12mrmax = gfRatioFactorRmax g2S12[rmaxInward]/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha;  

If[debugLevel==1,Print["Beginning NDSolve Inward.  "]];
fg2S12msolnInward=NDSolve[{(f2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f2S12m[rmaxInward]==f2S12mrmax,g2S12m[rmaxInward]==g2S12mrmax},{f2S12m[r],g2S12m[r]},{r,0,Infinity},WorkingPrecision->workingPrecisionForNDSolve];

(* impose continuity at midpoint *)
f2S12mOutwardMidpoint = (f2S12m[r]/.fg2S12msolnOutward[[1]]/.r->rmid1)/R20val/2;
f2S12mInwardMidpoint = (f2S12m[r]/.fg2S12msolnInward[[1]]/.r->rmid1)/R20val/2;
Inward2S12ScaleFactor = f2S12mOutwardMidpoint/f2S12mInwardMidpoint;

If[debugLevel==1,Print["Beginning NIntegrate Outward.  "]];
normIntegral2S12Outward =NIntegrate[r^2 *((f2S12m[r]/.fg2S12msolnOutward[[1]])^2+(g2S12m[r]/.fg2S12msolnOutward[[1]])^2),{r,rmin,rmid1}];

If[debugLevel==1,Print["Beginning NIntegrate Inward.  "]];
normIntegral2S12Inward =NIntegrate[r^2 *((Inward2S12ScaleFactor f2S12m[r]/.fg2S12msolnInward[[1]])^2+(Inward2S12ScaleFactor g2S12m[r]/.fg2S12msolnInward[[1]])^2),{r,rmid1,rmaxInward}];
normIntegral2S12Total = normIntegral2S12Outward+normIntegral2S12Inward;
scaleFactor2S12Total = Sqrt[1/normIntegral2S12Total];

       ElectronRho2S12fgmsolnOutward[r_]:= ((scaleFactor2S12Total f2S12m[r]/R20/2/.fg2S12msolnOutward[[1]]/.a0->a0val)^2+( scaleFactor2S12Total g2S12m[r]/R20/2/.fg2S12msolnOutward[[1]]/.a0->a0val )^2);
ElectronRho2S12fgmsolnInward[r_]:= ((scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val)^2+( scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val )^2);
f2S12OutwardDifference = (scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val)-(f2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
f2S12InwardDifference = (scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val)-(f2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
g2S12OutwardDifference = (scaleFactor2S12Total g2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val)-(g2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
g2S12InwardDifference = (scaleFactor2S12Total Inward2S12ScaleFactor  g2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val)-(g2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
ElectronRho2S12fgmOutwardDifference = (ElectronRho2S12fgmsolnOutward[r])-(ElectronRho2S12[r] / ElectronRho20 /. α->alpha/.a0->a0val/.μ->μval);
ElectronRho2S12fgmInwardDifference = (ElectronRho2S12fgmsolnInward[r])-(ElectronRho2S12[r] / ElectronRho20 /. α->alpha/.a0->a0val/.μ->μval);

f2S12OutwardRmid2 = f2S12OutwardDifference/.r->rmid2;
f2S12InwardRmid2 = f2S12InwardDifference/.r->rmid2;
g2S12OutwardRmid1 = g2S12OutwardDifference/.r->rmid1;
g2S12InwardRmid1 = g2S12InwardDifference/.r->rmid1;
g2S12OutwardRmid2 = g2S12OutwardDifference/.r->rmid2;
g2S12InwardRmid2 = g2S12InwardDifference/.r->rmid2;
(*
ErrorTerm1 = 1-fInwardRmid2/fOutwardRmid2;
ErrorTerm2 = 1-gInwardRmid1/gOutwardRmid1;
ErrorTerm3 = 1-gInwardRmid2/gOutwardRmid2;
*)
ErrorTerm1 = f2S12OutwardRmid2-f2S12InwardRmid2;
ErrorTerm2 = g2S12OutwardRmid1-g2S12InwardRmid1;
ErrorTerm3 = g2S12OutwardRmid2-g2S12InwardRmid2;

(* primary output value *)
TotalError = ErrorTerm1^2+ErrorTerm2^2+ErrorTerm3^2;

If[debugLevel==1,
Print["εval = ",εval];
Print["f2S12mOutwardMidpoint = ",f2S12mOutwardMidpoint];
Print["f2S12mInwardMidpoint = ",f2S12mInwardMidpoint];
Print["InwardScaleFactor = ",Inward2S12ScaleFactor];
Print["normIntegralOutward = ",normIntegral2S12Outward];
Print["normIntegralInward = ",normIntegral2S12Inward];
Print["normIntegralTotal = ",normIntegral2S12Total];
Print["scaleFactorTotal = ",scaleFactor2S12Total];

Print["fOutwardRmid2 = ",f2S12OutwardRmid2];
         Print["fInwardRmid2 = ",f2S12InwardRmid2];
         Print["gOutwardRmid1 = ",g2S12OutwardRmid1];
         Print["gInwardRmid1 = ",g2S12InwardRmid1];
Print["gOutwardRmid2 = ",g2S12OutwardRmid2];
         Print["gInwardRmid2 = ",g2S12InwardRmid2];

         Print["ErrorTerm1 = ",ErrorTerm1];
         Print["ErrorTerm2 = ",ErrorTerm2];
         Print["ErrorTerm3 = ",ErrorTerm3];
         Print["TotalError = ",TotalError];
];
If[debugLevel==2,
Print["εval = ",InputForm[εval],"       TotalError = ",TotalError];
];
(* return value *)
TotalError
,
Print["First Localization Pass for Compute2S12Error"]; 
Hold[Compute2S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ]
]
];
ε2S12val=-8.256788658754109*^-6;
Compute2S12Error[0, 1, ε2S12val];
f2S12num[r_] := scaleFactor2S12Total f2S12m[r]/R00/.fg2S12msolnOutward[[1]]/.a0->a0val;
g2S12num[r_] := scaleFactor2S12Total g2S12m[r]/R00/.fg2S12msolnOutward[[1]]/.a0->a0val;
ElectronRho2S12num[r_]:=((scaleFactor2S12Total f2S12m[r]/.fg2S12msolnOutward[[1]]/.a0->a0val)^2+( scaleFactor2S12Total g2S12m[r]/.fg2S12msolnOutward[[1]]/.a0->a0val )^2); ;
(* f1S12num[r]
g1S12num[r]
ElectronRho1S12num[r] *)

(* Lamb Shift Results *)

(* n=1 case (2014-08-03 best analytic approximation) *)
R00 = R0[r]/.r->0;
N10 = N1[r]/.r->0;
V0norm = -LHopital[V1[r],r,1];
Edval = (((6+20 μ+34 (μ^2)+32 (μ^3))/(2+9 μ+18 (μ^2)-11 (μ^3)-39 (μ^4)-8 (μ^5))))(Subscript[E, 0])/.μ->μval;

plotrange0 = .5a0val;
plotrange = 6a0val / 1836;
plotrangeRound = 6a0val / 1836;
plotrangeMedium = 6 a0val;
plotmin = 0.9932;
plotmax = 1.0002;

(* Electron-scale plot, Nucleus-scale, and Rounded-top plots *)
plot1 = Plot[{ (R0[Abs[r]])^2 / R00^2 ,             (N1[Abs[r]])^2 / N10^2  ,           V0[Abs[r]]/V0norm  ,           V1[Abs[r]]/V0norm,  (R1Approximation05[Abs[r]])^2 / R00^2},
             {r,-plotrange0,plotrange0},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green],Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ (R0[Abs[r]])^2 / R00^2 ,             (N1[Abs[r]])^2 / N10^2  ,           V0[Abs[r]]/V0norm  ,           V1[Abs[r]]/V0norm ,  (R1Approximation05[Abs[r]])^2 / R00^2},
             {r,-plotrange,plotrange},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green], Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = Plot[{ (R0[Abs[r]])^2 / R00^2,         (R1Approximation05[Abs[r]])^2 / R00^2   },
             {r,-plotrangeRound,plotrangeRound},
             PlotStyle->{Red, Darker[Red]},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsRow[{plot1,plot2,plot3}]]

(* Rd, SchrodingerError, and SchrodingerError^2 plots *)
plot1 = Plot[{ (RdApproximation05[r])/R00},
             {r,0,plotrangeRound},
             PlotStyle->{Darker[Red]},
             PlotRange->{-.0011,.0002},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ SchrodingerError[R1Approximation05[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]                     
                      },
             {r2,-plotrangeRound,plotrangeRound},
             PlotStyle->{Darker[Red]},
             PlotRange->{-4,4},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = Plot[{    RdApproximation05[r]/R00 },
             {r,0,plotrangeMedium},
             PlotStyle->{Darker[Red]},Filling->Axis,
             PlotRange->{-0.000001,0.0000003}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsRow[{plot1,plot2,plot3}]]

(* Rd, SchrodingerError, and SchrodingerError^2 plots *)
(*
plot1 = Plot[{ (RdComposite[r])/R00,(RdComposite4[r])/R00},
             {r,0,plotrangeRound},
             PlotStyle->{Purple,Darker[Red]},
             PlotRange->{-.0011,.0002},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ SchrodingerError[R1Composite[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]   ,
                       SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]                     
                      },
             {r2,-plotrangeRound,plotrangeRound},
             PlotStyle->{Purple,Darker[Red]},
             PlotRange->{-.15,.15},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = LogPlot[{ SchrodingerError[R1Composite[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]   ,
                             -SchrodingerError[R1Composite[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2],  
                       SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]  ,
                             -SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]                       
                      },
             {r2,-plotrangeRound,plotrangeRound},
             PlotStyle->{Purple,{Purple,Dashing[{Small,Tiny}]},Darker[Red],{Darker[Red],Dashing[{Small,Tiny}]}},
             PlotRange->{.00001,.1},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8,PlotPoints->1000];
Show[GraphicsRow[{plot1,plot2,plot3}]]
*)

(* n=1 case (best numerical method), plot with best previous analytic *)
(* establish plot ranges *)
plotrangeLong = 30 a0val;
plotrangeMedium = 6 a0val;
plotrangeRound = rmax;
plotrangeRound2 =  12a0val / 1836;
plotrangeRound2a =  6a0val / 1836;

(* plot everything *)
plotmin = -5;
plotmax =5;

plot5 = Plot[R1Sdnum[r]/R00,{r,rmin,plotrangeRound2a},Frame->True,PlotStyle->Blue,PlotRange->{-.0011,.0002},AspectRatio->0.8];
plot6d = Plot[R1Sdnum[r]/R00,{r,rmin,rmax},Frame->True,PlotStyle->Blue,PlotRange->{-.0011,.0002}];

plotmin = 0.9932;
plotmax = 1.0002;
plot7 = Plot[{ (R0[Abs[r2]])^2 / R00^2},
             {r2,-plotrangeRound2a,plotrangeRound2a},
             PlotStyle->{Red},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot8 = Plot[(R1Snum[r]/R00)^2,{r,rmin,plotrangeRound2a},PlotRange->{plotmin,plotmax},Frame->True,AspectRatio->0.8];
plot9 = Plot[(R1Snum[-r]/R00)^2,{r,-plotrangeRound2a,-rmin},PlotRange->{plotmin,plotmax},Frame->True,AspectRatio->0.8];
plot7a = Plot[{ (R0[Abs[r2]])^2 / R00^2,         (R1Approximation05[Abs[r2]])^2 / R00^2  },
             {r2,-plotrangeRound2a,plotrangeRound2a},
             PlotStyle->{Red,Darker[Green]},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsGrid[{{Show[plot5],Show[plot7,plot8,plot9],Show[plot7a,plot8,plot9]},{Show[plot7a,plot8,plot9,PlotRange->{{-plotrangeRound6*4,plotrangeRound6*4},{0.99814,0.99840}}]}}]]

(* n=1 case (previous best manual method) *)
R00 = R0[r]/.r->0;
N10 = N1[r]/.r->0;
V0norm = -LHopital[V1[r],r,1];
Edval = -.00000118497(Subscript[E, 0]);

plotrange0 = .5a0val;
plotrange = 6a0val / 1836;
plotrangeRound = 6a0val / 1836;
plotrangeMedium = 6 a0val;
plotmin = 0.9932;
plotmax = 1.0002;

(* Electron-scale plot, Nucleus-scale, and Rounded-top plots *)
plot1 = Plot[{ (R0[Abs[r]])^2 / R00^2 ,             (N1[Abs[r]])^2 / N10^2  ,           V0[Abs[r]]/V0norm  ,           V1[Abs[r]]/V0norm,  (R1Composite4[Abs[r]])^2 / R00^2},
             {r,-plotrange0,plotrange0},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green],Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ (R0[Abs[r]])^2 / R00^2 ,             (N1[Abs[r]])^2 / N10^2  ,           V0[Abs[r]]/V0norm  ,           V1[Abs[r]]/V0norm ,  (R1Composite4[Abs[r]])^2 / R00^2},
             {r,-plotrange,plotrange},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green], Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = Plot[{ (R0[Abs[r]])^2 / R00^2,         (R1Composite4[Abs[r]])^2 / R00^2   },
             {r,-plotrangeRound,plotrangeRound},
             PlotStyle->{Red, Darker[Red]},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsRow[{plot1,plot2,plot3}]]

(* Rd, SchrodingerError, and SchrodingerError^2 plots *)
plot1 = Plot[{ (RdComposite4[r])/R00},
             {r,0,plotrangeRound},
             PlotStyle->{Darker[Red]},
             PlotRange->{-.0011,.0002},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]                     
                      },
             {r2,-plotrangeRound,plotrangeRound},
             PlotStyle->{Darker[Red]},
             PlotRange->{-4,4},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = Plot[{    RdComposite4[r]/R00 },
             {r,0,plotrangeMedium},
             PlotStyle->{Darker[Red]},Filling->Axis,
             PlotRange->{-0.00001,0.00001}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsRow[{plot1,plot2,plot3}]]

(* Rd, SchrodingerError, and SchrodingerError^2 plots *)
plot1 = Plot[{ (RdComposite[r])/R00,(RdComposite4[r])/R00},
             {r,0,plotrangeRound},
             PlotStyle->{Purple,Darker[Red]},
             PlotRange->{-.0011,.0002},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ SchrodingerError[R1Composite[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]   ,
                       SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]                     
                      },
             {r2,-plotrangeRound,plotrangeRound},
             PlotStyle->{Purple,Darker[Red]},
             PlotRange->{-.15,.15},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = LogPlot[{ SchrodingerError[R1Composite[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]   ,
                             -SchrodingerError[R1Composite[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2],  
                       SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]  ,
                             -SchrodingerError[R1Composite4[r],(Subscript[E, 0])+Edval,V1[r]]  /.r->Abs[r2]                       
                      },
             {r2,-plotrangeRound,plotrangeRound},
             PlotStyle->{Purple,{Purple,Dashing[{Small,Tiny}]},Darker[Red],{Darker[Red],Dashing[{Small,Tiny}]}},
             PlotRange->{.00001,.1},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8,PlotPoints->1000];
Show[GraphicsRow[{plot1,plot2,plot3}]]

(* n=2 case *)
R20 = R2[r]/.r->0;
N20 = N2[r]/.r->0;
V2norm = -LHopital[V2[r],r,1];


plotrange0 = .5a0val;
plotrange = 6a0val / 1836;
plotrangeRound = 6a0val / 1836;
plotrangeMedium = 6 a0val;
plotmin = 0.9932;
plotmax = 1.0002;

(* Electron-scale plot, Nucleus-scale, and Rounded-top plots *)
plot1 = Plot[{ (R2[Abs[r]])^2 / R20^2 ,             (N2[Abs[r]])^2 / N20^2  ,      V0[Abs[r]]/V2norm ,      V2[Abs[r]]/V2norm  },
             {r,-20plotrange0,20plotrange0},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green],Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ (R2[Abs[r]])^2 / R20^2 ,             (N2[Abs[r]])^2 / N20^2  ,         V0[Abs[r]]/V2norm ,  V2[Abs[r]]/V2norm  },
             {r,-3plotrange,3plotrange},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green], Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot3 = Plot[{ (R2[Abs[r]])^2 / R20^2  },
             {r,-plotrangeRound,plotrangeRound},
             PlotStyle->{Red},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsRow[{plot1,plot2,plot3}]]


(* Electron-scale plot, Nucleus-scale, and Rounded-top plots *)
plot1 = Plot[{ (R0[Abs[r]])^2 / R00^2 ,             (N1[Abs[r]])^2 / N10^2  ,           V0[Abs[r]]/V0norm  ,           V1[Abs[r]]/V0norm ,V2[Abs[r]]/V0norm , V2P0[Abs[r]]/V0norm ,V2P90[Abs[r]]/V0norm , (R1Composite4[Abs[r]])^2 / R00^2},
             {r,-3plotrange,3plotrange},
             PlotStyle->{Red,Blue,{Green, Dashing[{Small,Small}]},Darker[Green],Darker[Darker[Green]],Darker[Darker[Darker[Green]]],Darker[Darker[Darker[Green]]], Darker[Red]},
             PlotRange->{-1.05,1.05},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{ V0[Abs[r]]/V0norm  ,V2[Abs[r]]/V0norm  },
             {r,-5plotrange,5plotrange},
             PlotStyle->{{Green, Dashing[{Small,Small}]},Darker[Green],Darker[Darker[Darker[Green]]]},
             PlotRange->{-0.3,0},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8,PlotPoints->1000];
plot3 = Plot[{ V0[Abs[r]]/V0norm  ,V2P0[Abs[r]]/V0norm , V2P90[Abs[r]]/V0norm },
             {r,-5plotrange,5plotrange},
             PlotStyle->{{Green, Dashing[{Small,Small}]},Darker[Green],Darker[Darker[Darker[Green]]]},
             PlotRange->{-0.3,0},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8,PlotPoints->1000];
Show[GraphicsRow[{plot1,plot2,plot3}]]

(* Summary plots for 1S and 2S *)

(* Lamb Shift Optimizations *)

(* Numerical Solution for Dirac 2S1/2, Gaussian distribution - figures used in Paper *)

(* First, verify that we can numerically duplicate the well-known analytic result for the unmodified Dirac 2S1/2 state. *)
(* The numerical integration method only gets the normalization right with a particular value of rmax. *)
(* It seems surprising that it should be sensitive to this value of rmax. *)

(* first, plot the previous unmodified relativistic analytic result for 2S1/2, and the previous non-relativistic modified result for reference *)
plotrangeRound2 = 16a0val / 1836;
plot4 = Plot[{ ElectronRho2S12[Abs[r]] / ElectronRho20 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma6->gamma6val/. α->alpha/.a0->a0val/.μ->μval},
             {r,-plotrangeRound2,plotrangeRound2},
             PlotStyle->{Red (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{0.982,1.0014},PlotPoints->10000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];
plot4a = Plot[{ ElectronRho2S12[Abs[r]] / ElectronRho20 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma6->gamma6val/. α->alpha/.a0->a0val/.μ->μval},
             {r,-8 a0val,8a0val},
             PlotStyle->{Red (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{-0.13,1.01},PlotPoints->1000,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot4d = Plot[(R2Snum[r]/R20/2)^2/.a0->a0val,{r,rmin,plotrangeRound2},PlotStyle->{Gray,Dashing[{Tiny,Tiny}]},PlotRange->{0.982,1.0014},Frame->True,AspectRatio->0.8];
plot4e = Plot[(R2Snum[-r]/R20/2)^2/.a0->a0val,{r,-plotrangeRound2,-rmin},PlotStyle->{Gray,Dashing[{Tiny,Tiny}]},PlotRange->{0.982,1.0014},Frame->True,AspectRatio->0.8];
plot4f = Plot[{ (R2[Abs[r]] / R20/2)^2 /.a0->a0val},
             {r,-plotrangeRound2,plotrangeRound2},
             PlotStyle->{Red, Dashing[{Tiny,Tiny}]},
             PlotRange->{0.982,1.0014},PlotPoints->10000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];
Show[GraphicsRow[{Show[plot4,plot4d,plot4e,plot4f],plot4a}]]

Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha (4)/(2(1+Sqrt[1-alpha^2])(2)));
workingPrecisionForNDSolve = 24;  
rmaxForPlot = 7a0val ;
rmaxForNorm = 26.7a0val ;  (* surprisingly sensitive value to give agreement on the charge normalization *)
rmin = a0val/100000000000;

A[r_]:= 1; 
f2S12mEqn = f2S12m'[r]-((1+gamma1+ε(-1+gamma1))/(α a0)+α/r A[r])g2S12m[r];
g2S12mEqn = g2S12m'[r]+2/r g2S12m[r]+((-1+gamma1+ε(-1+gamma1))/(α a0)+α/r A[r])f2S12m[r];
f2S12mZero =  1.00000R20/.a0->a0val;   (* 1.00065 *)
g2S12mZero = f2S12mZero*gfRatioStandard;  
εval = -.00000000000;  

fgmsoln=NDSolve[{(f2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f2S12m[rmin]==f2S12mZero,g2S12m[rmin]==g2S12mZero},{f2S12m[r],g2S12m[r]},{r,0,Infinity},WorkingPrecision->workingPrecisionForNDSolve];
normIntegral =NIntegrate[r^2 *((f2S12m[r]/.fgmsoln[[1]])^2+(g2S12m[r]/.fgmsoln[[1]])^2),{r,rmin,rmaxForNorm}];
scaleFactor = Sqrt[1/normIntegral];
Print["rmaxForNorm = ",InputForm[rmaxForNorm/a0val]," a0     normIntegral = ",InputForm[normIntegral],"    scaleFactor = ",InputForm[scaleFactor]];
Print["Original Dirac Solution"];
plot1 =Plot[{ f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,
scaleFactor f2S12m[r]/R20/2/.fgmsoln[[1]]/.a0->a0val, 
- scaleFactor g2S12m[r]/R20/2/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsoln[[1]]/.a0->a0val },
{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->All,PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,
scaleFactor  f2S12m[r]/R20/2/.fgmsoln[[1]]/.a0->a0val,
 -scaleFactor g2S12m[r]/R20/2/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsoln[[1]] /.a0->a0val},
{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,
scaleFactor  f2S12m[r]/R20/2/.fgmsoln[[1]]/.a0->a0val, 
-scaleFactor g2S12m[r]/R20/2/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsoln[[1]] /.a0->a0val},
{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
ElectronRho2S12fgmsoln[r_]:= ((scaleFactor f2S12m[r]/R20/2/.fgmsoln[[1]]/.a0->a0val)^2+(scaleFactor  g2S12m[r]/R20/2/.fgmsoln[[1]]/.a0->a0val )^2);
(* scaleHack = (ElectronRho1S12fgmsoln[r]/.r->plotrangeRound)/( ElectronRho1S12[plotrangeRound] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval ); *)
plot4a =Plot[{ElectronRho2S12fgmsoln[r]/.r->Abs[r2]},
{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsoln[r]/.r->Abs[r2]},
{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

(* Define Compute2S12Error[] function *)
Compute2S12Error[gfRatioFactorZero_, gfRatioFactorRmax_, εval_] := Module[{TotalError,debugLevel},
If[NumberQ[εval],
debugLevel = 2;
If[debugLevel==1,Print["Beginning Compute2S12Error[].   εval = ",εval]];
Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha/(1+Sqrt[1-alpha^2]));
workingPrecisionForNDSolve = 24;  
rmaxForPlot = 7a0val ;
rmaxForNorm = 28.798a0val ;  (* not used, rmaxInward is used instead *)
rmin = a0val/100000000000;

rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
A[r_]:= V1S12[r]/V0[r];                           (* for Exponential distribution *)
A[r_]:= (Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;   (* for Gaussian distribution *)

f2S12mEqn = f2S12m'[r]-((1+gamma1+ε(-1+gamma1))/(α a0)+α/r A[r])g2S12m[r];
g2S12mEqn = g2S12m'[r]+2/r g2S12m[r]+((-1+gamma1+ε(-1+gamma1))/(α a0)+α/r A[r])f2S12m[r];

rmid1 = 11 rcval;
rmid2 = 40rcval;
f2S12mZero =  1.000R20val;  
g2S12mZero = gfRatioFactorZero f2S12mZero*gfRatioStandard;  

If[debugLevel==1,Print["Beginning NDSolve Outward.  "]];
fg2S12msolnOutward=NDSolve[{(f2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f2S12m[rmin]==f2S12mZero,g2S12m[rmin]==g2S12mZero},{f2S12m[r],g2S12m[r]},{r,rmin,rmaxForNorm},WorkingPrecision->workingPrecisionForNDSolve];

rmaxInward = 30a0val;
f2S12mrmax =  f2S12[rmaxInward]/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha; (* 0.0000000000000936R20/.a0->a0val *);  
g2S12mrmax = gfRatioFactorRmax g2S12[rmaxInward]/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha;  

If[debugLevel==1,Print["Beginning NDSolve Inward.  "]];
fg2S12msolnInward=NDSolve[{(f2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g2S12mEqn/. gamma1->gamma1val/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f2S12m[rmaxInward]==f2S12mrmax,g2S12m[rmaxInward]==g2S12mrmax},{f2S12m[r],g2S12m[r]},{r,rmin,rmaxInward},WorkingPrecision->workingPrecisionForNDSolve];

(* impose continuity at midpoint *)
f2S12mOutwardMidpoint = (f2S12m[r]/.fg2S12msolnOutward[[1]]/.r->rmid1)/R20val/2;
f2S12mInwardMidpoint = (f2S12m[r]/.fg2S12msolnInward[[1]]/.r->rmid1)/R20val/2;
Inward2S12ScaleFactor = f2S12mOutwardMidpoint/f2S12mInwardMidpoint;

If[debugLevel==1,Print["Beginning NIntegrate Outward.  "]];
normIntegral2S12Outward =NIntegrate[r^2 *((f2S12m[r]/.fg2S12msolnOutward[[1]])^2+(g2S12m[r]/.fg2S12msolnOutward[[1]])^2),{r,rmin,rmid1}];

If[debugLevel==1,Print["Beginning NIntegrate Inward.  "]];
normIntegral2S12Inward =NIntegrate[r^2 *((Inward2S12ScaleFactor f2S12m[r]/.fg2S12msolnInward[[1]])^2+(Inward2S12ScaleFactor g2S12m[r]/.fg2S12msolnInward[[1]])^2),{r,rmid1,rmaxInward}];
normIntegral2S12Total = normIntegral2S12Outward+normIntegral2S12Inward;
scaleFactor2S12Total = Sqrt[1/normIntegral2S12Total];

       ElectronRho2S12fgmsolnOutward[r_]:= ((scaleFactor2S12Total f2S12m[r]/R20/2/.fg2S12msolnOutward[[1]]/.a0->a0val)^2+( scaleFactor2S12Total g2S12m[r]/R20/2/.fg2S12msolnOutward[[1]]/.a0->a0val )^2);
ElectronRho2S12fgmsolnInward[r_]:= ((scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val)^2+( scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val )^2);
f2S12OutwardDifference = (scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val)-(f2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
f2S12InwardDifference = (scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val)-(f2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
g2S12OutwardDifference = (scaleFactor2S12Total g2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val)-(g2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
g2S12InwardDifference = (scaleFactor2S12Total Inward2S12ScaleFactor  g2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val)-(g2S12[r]/R20/2 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha);
ElectronRho2S12fgmOutwardDifference = (ElectronRho2S12fgmsolnOutward[r])-(ElectronRho2S12[r] / ElectronRho20 /. α->alpha/.a0->a0val/.μ->μval);
ElectronRho2S12fgmInwardDifference = (ElectronRho2S12fgmsolnInward[r])-(ElectronRho2S12[r] / ElectronRho20 /. α->alpha/.a0->a0val/.μ->μval);

f2S12OutwardRmid2 = f2S12OutwardDifference/.r->rmid2;
f2S12InwardRmid2 = f2S12InwardDifference/.r->rmid2;
g2S12OutwardRmid1 = g2S12OutwardDifference/.r->rmid1;
g2S12InwardRmid1 = g2S12InwardDifference/.r->rmid1;
g2S12OutwardRmid2 = g2S12OutwardDifference/.r->rmid2;
g2S12InwardRmid2 = g2S12InwardDifference/.r->rmid2;
(*
ErrorTerm1 = 1-fInwardRmid2/fOutwardRmid2;
ErrorTerm2 = 1-gInwardRmid1/gOutwardRmid1;
ErrorTerm3 = 1-gInwardRmid2/gOutwardRmid2;
*)
ErrorTerm1 = f2S12OutwardRmid2-f2S12InwardRmid2;
ErrorTerm2 = g2S12OutwardRmid1-g2S12InwardRmid1;
ErrorTerm3 = g2S12OutwardRmid2-g2S12InwardRmid2;

(* primary output value *)
TotalError = ErrorTerm1^2+ErrorTerm2^2+ErrorTerm3^2;

If[debugLevel==1,
Print["εval = ",εval];
Print["f2S12mOutwardMidpoint = ",f2S12mOutwardMidpoint];
Print["f2S12mInwardMidpoint = ",f2S12mInwardMidpoint];
Print["InwardScaleFactor = ",Inward2S12ScaleFactor];
Print["normIntegralOutward = ",normIntegral2S12Outward];
Print["normIntegralInward = ",normIntegral2S12Inward];
Print["normIntegralTotal = ",normIntegral2S12Total];
Print["scaleFactorTotal = ",scaleFactor2S12Total];

Print["fOutwardRmid2 = ",f2S12OutwardRmid2];
         Print["fInwardRmid2 = ",f2S12InwardRmid2];
         Print["gOutwardRmid1 = ",g2S12OutwardRmid1];
         Print["gInwardRmid1 = ",g2S12InwardRmid1];
Print["gOutwardRmid2 = ",g2S12OutwardRmid2];
         Print["gInwardRmid2 = ",g2S12InwardRmid2];

         Print["ErrorTerm1 = ",ErrorTerm1];
         Print["ErrorTerm2 = ",ErrorTerm2];
         Print["ErrorTerm3 = ",ErrorTerm3];
         Print["TotalError = ",TotalError];
];
If[debugLevel==2,
Print["εval = ",InputForm[εval],"       TotalError = ",TotalError];
];
(* return value *)
TotalError
,
Print["First Localization Pass for Compute2S12Error"]; 
Hold[Compute2S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ]
]
];

Clear[εval];
εvalInit=ε2S12val;
Compute2S12Error[0, 1, εvalInit]

(* Plot results *)
Print["Modified Dirac Solution, Outward Integration"];
plot1 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val, -scaleFactor2S12Total g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnOutward[[1]] /.a0->a0val},{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->{-.2,1.1},PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val, -scaleFactor2S12Total g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnOutward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val, -scaleFactor2S12Total g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnOutward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b,plot4d,plot4e]}]]

Print["Modified Dirac Solution, Inward Integration"];
plot1 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val, -scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnInward[[1]] /.a0->a0val},{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->{-.2,1.1},PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val, -scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnInward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val, -scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnInward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho2S12fgmsolnInward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnInward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b,plot4e]}]]

Print["f differences to original                          g differences to original"];
plot5 =Plot[{f2S12OutwardDifference, f2S12InwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.0008,0.0001},PlotStyle->{Blue,Darker[Green]}];
plot5b =Plot[{f2S12OutwardDifference, f2S12InwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0008,0.0001},PlotStyle->{Blue,Darker[Green]}];
plot20e = ListPlot[{{rmid1,f2S12OutwardDifference/.r->rmid1},{rmid2,f2S12OutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ee = ListPlot[{{rmid1,f2S12InwardDifference/.r->rmid1},{rmid2,f2S12InwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
plot6 =Plot[{g2S12OutwardDifference, g2S12InwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.00014,0.0005},PlotStyle->{Blue,Darker[Green]}];
plot6b =Plot[{g2S12OutwardDifference, g2S12InwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0001,0.0005},PlotStyle->{Blue,Darker[Green]}];
plot20f = ListPlot[{{rmid1,g2S12OutwardDifference/.r->rmid1},{rmid2,g2S12OutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ff = ListPlot[{{rmid1,g2S12InwardDifference/.r->rmid1},{rmid2,g2S12InwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
Show[GraphicsRow[{Show[plot5,plot20e,plot20ee],Show[plot6,plot20f,plot20ff],Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff]}]]

plot7 =Plot[{ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha, ElectronRho2S12fgmInwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha},{r,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.008,0.001},PlotStyle->{Blue,Darker[Green]}];
plot20d = ListPlot[{{rmid1,ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha/.r->rmid1},{rmid2,ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot8 =Plot[{ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha, ElectronRho2S12fgmInwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha},{r,rmin,0.4a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0016,0.0002},PlotStyle->{Blue,Darker[Green]}];
plot9 =Plot[{ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha, ElectronRho2S12fgmInwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha},{r,rmin,700*plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.0015,0.0002},PlotStyle->{Blue,Darker[Green]}];
Show[GraphicsRow[{plot7,Show[plot8,plot20d],Show[plot9,plot20d] }]]

Show[GraphicsRow[{Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff],Show[plot9,plot20d]}]]
plot4a =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot7,Show[plot4,plot4a,plot4b,plot4d,plot4e], }]]

Clear[εval];
εvalInit=-1.0*10^-6;
findMinimumResult = FindMinimum[Compute2S12Error[0, 1, εval],{εval,εvalInit},Method->"PrincipalAxis"];   (* Big Optimization Loop *)

TotalErrorValue = findMinimumResult[[1]];
ε2S12=εval/.findMinimumResult[[2,1]];
Print["findMinimumResult = ",findMinimumResult];
Print["TotalErrorValue = ",TotalErrorValue];
Print["ε2S12 = ",InputForm[ε2S12]];

(* Compute 1S1/2 Error, update all state variables *)
gfRatioFactorZero = 0;
gfRatioFactorRmax = 1;
εval = ε2S12;
TotalError=Compute2S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ;  (* update all state variables with final returned value *)
Print["gfRatioFactorZero  = ",gfRatioFactorZero  ,      "    gfRatioFactorRmax  = ",gfRatioFactorRmax ,   "    εval  = ",εval,"    TotalError  = ",TotalError ];      
Print[ ];

(* Compute 1S1/2 Error, update all state variables *)
gfRatioFactorZero = 0;
gfRatioFactorRmax = 1;
ε2S12num = -1.271301520600962*^-6;
TotalError=Compute2S12Error[gfRatioFactorZero, gfRatioFactorRmax, ε2S12num] ;  (* update all state variables with final returned value *)
Print["gfRatioFactorZero  = ",gfRatioFactorZero  ,      "    gfRatioFactorRmax  = ",gfRatioFactorRmax ,   "    εval  = ",εval,"    TotalError  = ",TotalError ];      
Print[ ];

(* Plot results *)
Print["Modified Dirac Solution, Outward Integration"];
plot1 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val, -scaleFactor2S12Total g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnOutward[[1]] /.a0->a0val},{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->{-.2,1.1},PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val, -scaleFactor2S12Total g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnOutward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total f2S12m[r]/R20/2 /.fg2S12msolnOutward[[1]]/.a0->a0val, -scaleFactor2S12Total g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnOutward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

Print["Modified Dirac Solution, Inward Integration"];
plot1 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val, -scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnInward[[1]] /.a0->a0val},{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->{-.2,1.1},PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val, -scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnInward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,scaleFactor2S12Total Inward2S12ScaleFactor f2S12m[r]/R20/2 /.fg2S12msolnInward[[1]]/.a0->a0val, -scaleFactor2S12Total Inward2S12ScaleFactor g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fg2S12msolnInward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho2S12fgmsolnInward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnInward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

Print["f differences to original                          g differences to original"];
plot5 =Plot[{f2S12OutwardDifference, f2S12InwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.0008,0.0001},PlotStyle->{Blue,Darker[Green]}];
plot5b =Plot[{f2S12OutwardDifference, f2S12InwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0008,0.0001},PlotStyle->{Blue,Darker[Green]}];
plot20e = ListPlot[{{rmid1,f2S12OutwardDifference/.r->rmid1},{rmid2,f2S12OutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ee = ListPlot[{{rmid1,f2S12InwardDifference/.r->rmid1},{rmid2,f2S12InwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
plot6 =Plot[{g2S12OutwardDifference, g2S12InwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.00014,0.0005},PlotStyle->{Blue,Darker[Green]}];
plot6b =Plot[{g2S12OutwardDifference, g2S12InwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0001,0.0005},PlotStyle->{Blue,Darker[Green]}];
plot20f = ListPlot[{{rmid1,g2S12OutwardDifference/.r->rmid1},{rmid2,g2S12OutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ff = ListPlot[{{rmid1,g2S12InwardDifference/.r->rmid1},{rmid2,g2S12InwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
Show[GraphicsRow[{Show[plot5,plot20e,plot20ee],Show[plot6,plot20f,plot20ff],Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff]}]]

plot7 =Plot[{ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha, ElectronRho2S12fgmInwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha},{r,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.008,0.001},PlotStyle->{Blue,Darker[Green]}];
plot20d = ListPlot[{{rmid1,ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha/.r->rmid1},{rmid2,ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot8 =Plot[{ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha, ElectronRho2S12fgmInwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha},{r,rmin,0.4a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0016,0.0002},PlotStyle->{Blue,Darker[Green]}];
plot9 =Plot[{ElectronRho2S12fgmOutwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha, ElectronRho2S12fgmInwardDifference/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.α->alpha},{r,rmin,700*plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.0015,0.0002},PlotStyle->{Blue,Darker[Green]}];
Show[GraphicsRow[{plot7,Show[plot8,plot20d],Show[plot9,plot20d] }]]

Show[GraphicsRow[{Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff],Show[plot9,plot20d]}]]
plot4a =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot7,Show[plot4,plot4a,plot4b], }]]

ElectronRho2S12fgmsolnOutwardFOnly[r_]:= ((scaleFactorTotal f2S12m[r]/R20/2/.fgmsolnOutward[[1]]/.a0->a0val)^2);
Print["Modified Dirac Solution, Outward Integration"];
plot1 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,
-g2S12[r]/R20/2/(alpha/(1+Sqrt[1-alpha^2]))/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha,scaleFactorTotal f2S12m[r]/R20/2 /.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]] /.a0->a0val},{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->{-.2,1.1},PlotStyle->{Red,{Red,Dashing[{Tiny,Tiny}]},Blue,Purple}];
plot2 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,-g2S12[r]/R20/2/(alpha/(1+Sqrt[1-alpha^2]))/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha,scaleFactorTotal f2S12m[r]/R20/2 /.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,{Red,Dashing[{Tiny,Tiny}]},Blue,Purple}];
plot3 =Plot[{f2S12[r]/R20/2/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.a0->a0val/.α->alpha,-g2S12[r]/R20/2/(alpha/(1+Sqrt[1-alpha^2]))/.gamma2->gamma2val/.gamma3->gamma3val/.gamma4->gamma4val/.gamma6->gamma6val/.a0->a0val/.α->alpha,scaleFactorTotal f2S12m[r]/R20/2 /.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g2S12m[r]/R20/2 /(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,{Red,Dashing[{Tiny,Tiny}]},Blue,Purple}];
plot4a =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2],ElectronRho2S12fgmsolnOutwardFOnly[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2],ElectronRho2S12fgmsolnOutwardFOnly[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b,plot4d,plot4e]}]]

plotrangeRound2 = 16a0val / 1836;
plot4 = Plot[{ ElectronRho2S12[Abs[r]] / ElectronRho20 /.gamma2->gamma2val/.gamma3->gamma3val/.gamma6->gamma6val/. α->alpha/.a0->a0val/.μ->μval},
             {r,-plotrangeRound2,plotrangeRound2},
             PlotStyle->{Red (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{0.982,1.0014},PlotPoints->10000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];
plot4d = Plot[(R2Snum[r]/R20/2)^2/.a0->a0val,{r,rmin,plotrangeRound2},PlotStyle->{Gray,Dashing[{Tiny,Tiny}]},PlotRange->{0.982,1.0014},Frame->True,AspectRatio->0.8];
plot4e = Plot[(R2Snum[-r]/R20/2)^2/.a0->a0val,{r,-plotrangeRound2,-rmin},PlotStyle->{Gray,Dashing[{Tiny,Tiny}]},PlotRange->{0.982,1.0014},Frame->True,AspectRatio->0.8];
plot4f = Plot[{ (R2[Abs[r]] / R20/2)^2 /.a0->a0val},
             {r,-plotrangeRound2,plotrangeRound2},
             PlotStyle->{Magenta (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{0.982,1.0014},PlotPoints->10000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];

plot4a =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot4b =Plot[{ElectronRho2S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];

plot5 = Plot[{ ElectronRho1S12[Abs[r]] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval},
             {r,-plotrangeRound2,plotrangeRound2},
             PlotStyle->{Red (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{0.982,1.0014},PlotPoints->10000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];
plot5d = Plot[(R1Snum[r]/R00)^2/.a0->a0val,{r,100rmin,plotrangeRound2},PlotStyle->{Gray,Dashing[{Tiny,Tiny}]},PlotRange->{0.982,1.0014},Frame->True,AspectRatio->0.8];
plot5e = Plot[(R1Snum[-r]/R00)^2/.a0->a0val,{r,-plotrangeRound2,-100rmin},PlotStyle->{Gray,Dashing[{Tiny,Tiny}]},PlotRange->{0.982,1.0014},Frame->True,AspectRatio->0.8];
plot5f = Plot[{ (R0[Abs[r]] / R00)^2 /.a0->a0val},
             {r,-plotrangeRound2,plotrangeRound2},
             PlotStyle->{Magenta (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{0.982,1.0014},PlotPoints->10000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];
plot5a =Plot[{ElectronRho1S12num[r]*e/(4 Pi)/ ElectronRho00/. α->alpha/.r->Abs[r2]},{r2,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
plot5b =Plot[{ElectronRho1S12num[r]*e/(4 Pi)/ ElectronRho00/. α->alpha/.r->Abs[r2]},{r2,-plotrangeRound2,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound2,plotrangeRound2},{0.982,1.0014}}];
Show[GraphicsRow[{Show[plot5,plot5a,plot5b,plot5f,PlotLabel->"1S1/2 Charge Densities"], Show[plot4,plot4a,plot4b,plot4f,PlotLabel->"2S1/2 Charge Densities" ]}]]

(* Numerical Solution for Dirac 1S1/2 Gaussian distribution - figures used in Paper  *)

(* First, verify that we can numerically duplicate the well-known analytic result for the unmodified Dirac 1S1/2 state. *)
(* The numerical integration method only gets the normalization right with a particular value of rmax. *)
(* It seems surprising that it should be sensitive to this value of rmax. *)
plotrangeRound = 6a0val / 1836;
plot4 = Plot[{ ElectronRho1S12[Abs[r]] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval(* , ElectronRho1S12NoSingularity[Abs[r]] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval *)(*,         (R1Approximation05[Abs[r]])^2 / R00^2  *) },
             {r,-plotrangeRound,plotrangeRound},
             PlotStyle->{Red (* ,{Red, Dashing[{Tiny,Tiny}]}*) (*, Darker[Red]*)},
             PlotRange->{0.9932,1.001},PlotPoints->100000,Frame->True,Axes->False,AxesOrigin->{0,0},AspectRatio->0.8];

Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha/(1+Sqrt[1-alpha^2]));
workingPrecisionForNDSolve = 32;  
rmaxForPlot = 7a0val ;
rmaxForNorm = 26.7a0val ;  (* surprisingly sensitive value to give agreement on the charge normalization *)
rmin = a0val/100000000000;

A[r_]:= 1; 
f1S12mEqn = f1S12m'[r]-((1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])g1S12m[r];
g1S12mEqn = g1S12m'[r]+2/r g1S12m[r]+((-1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])f1S12m[r];
f1S12mZero =  1.00000R00/.a0->a0val;   (* 1.00065 *)
g1S12mZero = f1S12mZero*gfRatioStandard;  
εval = -.00000000000;  

fgmsoln=NDSolve[{(f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f1S12m[rmin]==f1S12mZero,g1S12m[rmin]==g1S12mZero},{f1S12m[r],g1S12m[r]},{r,0,Infinity},WorkingPrecision->workingPrecisionForNDSolve];
normIntegral =NIntegrate[r^2 *((f1S12m[r]/.fgmsoln[[1]])^2+(g1S12m[r]/.fgmsoln[[1]])^2),{r,rmin,rmaxForNorm}];
scaleFactor = Sqrt[1/normIntegral];
Print["rmaxForNorm = ",InputForm[rmaxForNorm/a0val]," a0     normIntegral = ",InputForm[normIntegral],"    scaleFactor = ",InputForm[scaleFactor]];

Print["Original Dirac Solution"];
plot1 =Plot[{ f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactor f1S12m[r]/R00/.fgmsoln[[1]]/.a0->a0val, - scaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsoln[[1]]/.a0->a0val },{r,rmin,rmaxForPlot},Frame->True,AspectRatio->0.8,PlotRange->All,PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactor  f1S12m[r]/R00/.fgmsoln[[1]]/.a0->a0val, -scaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsoln[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactor  f1S12m[r]/R00/.fgmsoln[[1]]/.a0->a0val, -scaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsoln[[1]] /.a0->a0val},{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
ElectronRho1S12fgmsoln[r_]:= ((scaleFactor f1S12m[r]/R00/.fgmsoln[[1]]/.a0->a0val)^2+(scaleFactor  g1S12m[r]/R00/.fgmsoln[[1]]/.a0->a0val )^2);
(* scaleHack = (ElectronRho1S12fgmsoln[r]/.r->plotrangeRound)/( ElectronRho1S12[plotrangeRound] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval ); *)
plot4a =Plot[{ElectronRho1S12fgmsoln[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsoln[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
A1[r_]:= (Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;
A2[r_]:= V1S12[r]/V0[r];
A3[r_]:= V1S12[.5r]/V0[.5r];
A4[r_]:= (A3[r]+A1[r])/2;

rZval
A1[r]
A2[r]/.a0->a0val/.α->alpha/. μ-> μval
Plot[{A1[r],A2[r]/.a0->a0val/.α->alpha/. μ-> μval,A3[r]/.a0->a0val/.α->alpha/. μ-> μval,A4[r]/.a0->a0val/.α->alpha/. μ-> μval},{r,0,2 10 ^-13},PlotRange->{0,1},AspectRatio->0.8,Frame->True]

(* Define Compute1S12Error[] function *)
Compute1S12Error[gfRatioFactorZero_, gfRatioFactorRmax_, εval_] := Module[{TotalError,debugLevel},
If[NumberQ[εval],
debugLevel = 2;
Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha/(1+Sqrt[1-alpha^2]));
workingPrecisionForNDSolve = 24;  
rmaxForPlot = 7a0val ;
rmaxForNorm = 28.798a0val ;  (* not used, rmaxInward is used instead *)
rmin = a0val/100000000000;

rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
A[r_]:= V1S12[r]/V0[r];                           (* for Exponential distribution *)
A[r_]:= (Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;   (* for Gaussian distribution *)

f1S12mEqn = f1S12m'[r]-((1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])g1S12m[r];
g1S12mEqn = g1S12m'[r]+2/r g1S12m[r]+((-1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])f1S12m[r];

rmid1 = 11 rcval;
rmid2 = 40rcval;
f1S12mZero =  1.000R00/.a0->a0val;  
g1S12mZero = f1S12mZero*gfRatioStandard*gfRatioFactorZero;  
(*
Print["about to do Outward NDSolve..."];
Print["f1S12mEqn = ", (f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)];
Print["g1S12mEqn = ",(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)];
*)
fgmsolnOutward=NDSolve[{(f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f1S12m[rmin]==f1S12mZero,g1S12m[rmin]==g1S12mZero},{f1S12m[r],g1S12m[r]},{r,rmin,rmaxForNorm},WorkingPrecision->workingPrecisionForNDSolve];

rmaxInward = 30a0val;
f1S12mrmax =  0.0000000000000936R00/.a0->a0val;  
g1S12mrmax = f1S12mrmax*gfRatioStandard*gfRatioFactorRmax;  
(* Print["about to do Inward NDSolve..."]; *)
fgmsolnInward=NDSolve[{(f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f1S12m[rmaxInward]==f1S12mrmax,g1S12m[rmaxInward]==g1S12mrmax},{f1S12m[r],g1S12m[r]},{r,rmin,rmaxInward},WorkingPrecision->workingPrecisionForNDSolve];

(* impose continuity at midpoint *)
f1S12mOutwardMidpoint = (f1S12m[r]/.fgmsolnOutward[[1]]/.r->rmid1)/R00val;
f1S12mInwardMidpoint = (f1S12m[r]/.fgmsolnInward[[1]]/.r->rmid1)/R00val;
InwardScaleFactor = f1S12mOutwardMidpoint/f1S12mInwardMidpoint;

(* Print["about to do Outward NIntegrate..."]; *)
normIntegralOutward =NIntegrate[r^2 *((f1S12m[r]/.fgmsolnOutward[[1]])^2+(g1S12m[r]/.fgmsolnOutward[[1]])^2),{r,rmin,rmid1}];

(* Print["about to do Inward NIntegrate..."]; *)
normIntegralInward =NIntegrate[r^2 *((InwardScaleFactor f1S12m[r]/.fgmsolnInward[[1]])^2+(InwardScaleFactor g1S12m[r]/.fgmsolnInward[[1]])^2),{r,rmid1,rmaxInward}];
normIntegralTotal = normIntegralOutward+normIntegralInward;
scaleFactorTotal = Sqrt[1/normIntegralTotal];

       ElectronRho1S12fgmsolnOutward[r_]:= ((scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val)^2+( scaleFactorTotal g1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val )^2);
ElectronRho1S12fgmsolnInward[r_]:= ((scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val)^2+( scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val )^2);
fOutwardDifference = (scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val)-(f1S12[r]/R00/.a0->a0val/.α->alpha);
fInwardDifference = (scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val)-(f1S12[r]/R00/.a0->a0val/.α->alpha);
gOutwardDifference = (scaleFactorTotal g1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val)-(g1S12[r]/R00/.a0->a0val/.α->alpha);
gInwardDifference = (scaleFactorTotal InwardScaleFactor  g1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val)-(g1S12[r]/R00/.a0->a0val/.α->alpha);
ElectronRho1S12fgmOutwardDifference = (ElectronRho1S12fgmsolnOutward[r])-(ElectronRho1S12[r] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval);
ElectronRho1S12fgmInwardDifference = (ElectronRho1S12fgmsolnInward[r])-(ElectronRho1S12[r] / ElectronRho00 /. α->alpha/.a0->a0val/.μ->μval);

fOutwardRmid2 = fOutwardDifference/.r->rmid2;
fInwardRmid2 = fInwardDifference/.r->rmid2;
gOutwardRmid1 = gOutwardDifference/.r->rmid1;
gInwardRmid1 = gInwardDifference/.r->rmid1;
gOutwardRmid2 = gOutwardDifference/.r->rmid2;
gInwardRmid2 = gInwardDifference/.r->rmid2;
(*
ErrorTerm1 = 1-fInwardRmid2/fOutwardRmid2;
ErrorTerm2 = 1-gInwardRmid1/gOutwardRmid1;
ErrorTerm3 = 1-gInwardRmid2/gOutwardRmid2;
*)
(* simpler error metric *)
ErrorTerm1 = fOutwardRmid2-fInwardRmid2;
ErrorTerm2 = gOutwardRmid1-gInwardRmid1;
ErrorTerm3 = gOutwardRmid2-gInwardRmid2;

(* primary output value *)
TotalError = ErrorTerm1^2+ErrorTerm2^2+ErrorTerm3^2;

If[debugLevel==1,
Print["εval = ",εval];
Print["f1S12mOutwardMidpoint = ",f1S12mOutwardMidpoint];
Print["f1S12mInwardMidpoint = ",f1S12mInwardMidpoint];
Print["InwardScaleFactor = ",InwardScaleFactor];
Print["normIntegralOutward = ",normIntegralOutward];
Print["normIntegralInward = ",normIntegralInward];
Print["normIntegralTotal = ",normIntegralTotal];
Print["scaleFactorTotal = ",scaleFactorTotal];

Print["fOutwardRmid2 = ",fOutwardRmid2];
         Print["fInwardRmid2 = ",fInwardRmid2];
         Print["gOutwardRmid1 = ",gOutwardRmid1];
         Print["gInwardRmid1 = ",gInwardRmid1];
Print["gOutwardRmid2 = ",gOutwardRmid2];
         Print["gInwardRmid2 = ",gInwardRmid2];

         Print["ErrorTerm1 = ",ErrorTerm1];
         Print["ErrorTerm2 = ",ErrorTerm2];
         Print["ErrorTerm3 = ",ErrorTerm3];
         Print["TotalError = ",TotalError];
];
If[debugLevel==2,
Print["εval = ",InputForm[εval],"       TotalError = ",TotalError];
];
(* return value *)
TotalError
,
Print["First Localization Pass for Compute1S12Error"]; 
Hold[Compute1S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ]
]
];

(* just do a single iteration, Gaussian case *)
Clear[εval];
gfRatioFactorZero = 0;  (* 0 for Exponential, not sure yet what to use for Gaussian *)
gfRatioFactorRmax = 1;
εvalInit=-1.1*10^-6;
Compute1S12Error[gfRatioFactorZero, gfRatioFactorRmax, εvalInit];

(* Just testing first iteration *)
gfRatioFactorZero = 0;  (* 0 for Exponential, not sure yet what to use for Gaussian *)
gfRatioFactorRmax = 1;
εvalInit=-1.1*10^-6;
εval=εvalInit;
Clear[a0,hbar,c, mr,μ];
Off[NDSolve::mxst];
Off[NDSolve::precw];
gfRatioStandard=(-alpha/(1+Sqrt[1-alpha^2]));
workingPrecisionForNDSolve = 24;  
rmaxForPlot = 7a0val ;
rmaxForNorm = 28.798a0val ;  (* not used, rmaxInward is used instead *)
rmin = a0val/100000000000;

rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
A[r_]:= V1S12[r]/V0[r];                           (* for Exponential distribution *)
A[r_]:= V1S12[.5r]/V0[.5r];                           (* modified Exponential distribution *)
A[r_] := A4[r];
A[r_]:= (Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;   (* for Gaussian distribution *)


f1S12mEqn = f1S12m'[r]-((1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])g1S12m[r];
g1S12mEqn = g1S12m'[r]+2/r g1S12m[r]+((-1+Sqrt[1-α^2]+ε(-1+Sqrt[1-α^2]))/(α a0)+α/r A[r])f1S12m[r];

rmid1 = 11 rcval;
rmid2 = 40rcval;
f1S12mZero =  1.000R00/.a0->a0val;   (* suitable for Exponential case *)
g1S12mZero = f1S12mZero*gfRatioStandard*gfRatioFactorZero;  
Print["about to do Outward NDSolve..."];
Print["f1S12mEqn = ", (f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)];
Print["g1S12mEqn = ",(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)];

fgmsolnOutward=NDSolve[{(f1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,(g1S12mEqn/.ε->εval/.a0->a0val/.α->alpha/. μ-> μval)==0,f1S12m[rmin]==f1S12mZero,g1S12m[rmin]==g1S12mZero},{f1S12m[r],g1S12m[r]},{r,0,rmaxForNorm},Method->"Shooting",WorkingPrecision->workingPrecisionForNDSolve (*,StepMonitor:>Print["Step to r = ",r] *)];
Print["done Outward NDSolve."];

Clear[εval];
gfRatioFactorZero = 0;  (* 0 for Exponential, not sure yet what to use for Gaussian *)
gfRatioFactorRmax = 1;
εvalInit=-1.1*10^-6;
findMinimumResult = FindMinimum[Compute1S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval],{εval,εvalInit},Method->"PrincipalAxis"];   (* Big Optimization Loop *)

TotalErrorValue = findMinimumResult[[1]];
ε1S12=εval/.findMinimumResult[[2,1]];
Print["findMinimumResult = ",findMinimumResult];
Print["TotalErrorValue = ",TotalErrorValue];
Print["ε1S12 = ",InputForm[ε1S12]];

(* Compute 1S1/2 Error, update all state variables *)

εval = ε1S12;
TotalError=Compute1S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ;  (* update all state variables with final returned value *)
Print["gfRatioFactorZero  = ",gfRatioFactorZero  ,      "    gfRatioFactorRmax  = ",gfRatioFactorRmax ,   "    εval  = ",εval,"    TotalError  = ",TotalError ];      
Print[ ];      

(* Plot results *)
Print["Modified Dirac Solution, Outward Integration"];
plot1 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]] /.a0->a0val},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->All,PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

Print["Modified Dirac Solution, Inward Integration"];
plot1 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val, -scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnInward[[1]] /.a0->a0val},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-.1,1.1},PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val, -scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnInward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val, -scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnInward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho1S12fgmsolnInward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsolnInward[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

Print["f differences to original                          g differences to original"];
plot5 =Plot[{fOutwardDifference, fInwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.00006,0.000007},PlotStyle->{Blue,Darker[Green]}];
plot5b =Plot[{fOutwardDifference, fInwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.00006,0.000007},PlotStyle->{Blue,Darker[Green]}];
plot20e = ListPlot[{{rmid1,fOutwardDifference/.r->rmid1},{rmid2,fOutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ee = ListPlot[{{rmid1,fInwardDifference/.r->rmid1},{rmid2,fInwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
plot6 =Plot[{gOutwardDifference, gInwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.0000014,0.00004},PlotStyle->{Blue,Darker[Green]}];
plot6b =Plot[{gOutwardDifference, gInwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.00001,0.00004},PlotStyle->{Blue,Darker[Green]}];
plot20f = ListPlot[{{rmid1,gOutwardDifference/.r->rmid1},{rmid2,gOutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ff = ListPlot[{{rmid1,gInwardDifference/.r->rmid1},{rmid2,gInwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
Show[GraphicsRow[{Show[plot5,plot20e,plot20ee],Show[plot6,plot20f,plot20ff],Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff]}]]

plot7 =Plot[{ElectronRho1S12fgmOutwardDifference, ElectronRho1S12fgmInwardDifference},{r,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.0020,0.00003},PlotStyle->{Blue,Darker[Green]}];
plot20d = ListPlot[{{rmid1,ElectronRho1S12fgmOutwardDifference/.r->rmid1},{rmid2,ElectronRho1S12fgmOutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot8 =Plot[{ElectronRho1S12fgmOutwardDifference, ElectronRho1S12fgmInwardDifference},{r,rmin,0.4a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0002,0.00008},PlotStyle->{Blue,Darker[Green]}];
plot9 =Plot[{ElectronRho1S12fgmOutwardDifference, ElectronRho1S12fgmInwardDifference},{r,rmin,700*plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.0002,0.00008},PlotStyle->{Blue,Darker[Green]}];
Show[GraphicsRow[{plot7,Show[plot8,plot20d],Show[plot9,plot20d] }]]

Show[GraphicsRow[{Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff],Show[plot9,plot20d]}]]
plot4a =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot7,Show[plot4,plot4a,plot4b], }]]

(* Compute 1S1/2 Error, update all state variables *)

Clear[εval];
gfRatioFactorZero = 0;  (* 0 for Exponential, not sure yet what to use for Gaussian *)
gfRatioFactorRmax = 1;
εval = -2.5424935493344967*^-6;  (* this was the best, but not the last value *)
TotalError=Compute1S12Error[gfRatioFactorZero, gfRatioFactorRmax, εval] ;  (* update all state variables with final returned value *)
Print["gfRatioFactorZero  = ",gfRatioFactorZero  ,      "    gfRatioFactorRmax  = ",gfRatioFactorRmax ,   "    εval  = ",εval,"    TotalError  = ",TotalError ];      
Print[ ];

(* Plot results *)
Print["Modified Dirac Solution, Outward Integration"];
plot1 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]] /.a0->a0val},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->All,PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal f1S12m[r]/R00/.fgmsolnOutward[[1]]/.a0->a0val, -scaleFactorTotal g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnOutward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

Print["Modified Dirac Solution, Inward Integration"];
plot1 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val, -scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnInward[[1]] /.a0->a0val},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-.1,1.1},PlotStyle->{Red,Blue,Purple}];
plot2 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val, -scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnInward[[1]] /.a0->a0val},{r,rmin,100 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.95,1.002},PlotStyle->{Red,Blue,Purple}];
plot3 =Plot[{f1S12[r]/R00/.a0->a0val/.α->alpha,scaleFactorTotal InwardScaleFactor f1S12m[r]/R00/.fgmsolnInward[[1]]/.a0->a0val, -scaleFactorTotal InwardScaleFactor g1S12m[r]/R00/(alpha/(1+Sqrt[1-alpha^2]))/.fgmsolnInward[[1]]/.a0->a0val },{r,rmin,10 rcval},Frame->True,AspectRatio->0.8,PlotRange->{0.995,1.0015},PlotStyle->{Red,Blue,Purple}];
plot4a =Plot[{ElectronRho1S12fgmsolnInward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsolnInward[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot1,plot2,plot3,Show[plot4,plot4a,plot4b]}]]

Print["f differences to original                          g differences to original"];
plot5 =Plot[{fOutwardDifference, fInwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.00014,0.000007},PlotStyle->{Blue,Darker[Green]}];
plot5b =Plot[{fOutwardDifference, fInwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.00014,0.000007},PlotStyle->{Blue,Darker[Green]}];
plot20e = ListPlot[{{rmid1,fOutwardDifference/.r->rmid1},{rmid2,fOutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ee = ListPlot[{{rmid1,fInwardDifference/.r->rmid1},{rmid2,fInwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
plot6 =Plot[{gOutwardDifference, gInwardDifference},{r,rmin,rmax},Frame->True,AspectRatio->0.8,PlotRange->{-0.0000014,0.00008},PlotStyle->{Blue,Darker[Green]}];
plot6b =Plot[{gOutwardDifference, gInwardDifference},{r,rmin,0.1a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.00001,0.00008},PlotStyle->{Blue,Darker[Green]}];
plot20f = ListPlot[{{rmid1,gOutwardDifference/.r->rmid1},{rmid2,gOutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot20ff = ListPlot[{{rmid1,gInwardDifference/.r->rmid1},{rmid2,gInwardDifference/.r->rmid2}},Joined->False,PlotStyle->{Darker[Green],PointSize[.013]}];
Show[GraphicsRow[{Show[plot5,plot20e,plot20ee],Show[plot6,plot20f,plot20ff],Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff]}]]

plot7 =Plot[{ElectronRho1S12fgmOutwardDifference, ElectronRho1S12fgmInwardDifference},{r,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.0030,0.00003},PlotStyle->{Blue,Darker[Green]}];
plot20d = ListPlot[{{rmid1,ElectronRho1S12fgmOutwardDifference/.r->rmid1},{rmid2,ElectronRho1S12fgmOutwardDifference/.r->rmid2}},Joined->False,PlotStyle->PointSize[.02]];
plot8 =Plot[{ElectronRho1S12fgmOutwardDifference, ElectronRho1S12fgmInwardDifference},{r,rmin,0.4a0val},Frame->True,AspectRatio->0.8,PlotRange->{-0.0002,0.00008},PlotStyle->{Blue,Darker[Green]}];
plot9 =Plot[{ElectronRho1S12fgmOutwardDifference, ElectronRho1S12fgmInwardDifference},{r,rmin,700*plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{-0.0002,0.00008},PlotStyle->{Blue,Darker[Green]}];
Show[GraphicsRow[{plot7,Show[plot8,plot20d],Show[plot9,plot20d] }]]

Show[GraphicsRow[{Show[plot5b,plot20e,plot20ee],Show[plot6b,plot20f,plot20ff],Show[plot9,plot20d]}]]
plot4a =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,rmin,plotrangeRound},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
plot4b =Plot[{ElectronRho1S12fgmsolnOutward[r]/.r->Abs[r2]},{r2,-plotrangeRound,-rmin},Frame->True,AspectRatio->0.8,PlotRange->{{-plotrangeRound,plotrangeRound},{0.9932,1.001}}];
Show[GraphicsRow[{plot7,Show[plot4,plot4a,plot4b], }]]

(* comparison of 2S12 and 1S12 *)

(* Daywitt's factor of 1/4.5   -- really, 4.50524 *)

Off[Solve::ifun];
daywittRatio = Solve[Exp[x] == x Exp[3],x];
Print["daywittRatio(1) = ",x/.daywittRatio[[1,1]]," = ",x/.daywittRatio[[1,1]]//N];
Print["daywittRatio(2) = ",x/.daywittRatio[[2,1]]," = ",x/.daywittRatio[[2,1]]//N];
Print["(1/(daywittRatio (2)))= ",(1/(x/.daywittRatio[[2,1]]))//N,"   -- quite close to my empirically determined 0.21885 adjustment factor"];
Print["\!\(\*FractionBox[\(1\), \(\*SqrtBox[\(2\)]\\ π\)]\) = ",(1/((Sqrt[2]) π))//N,"            -- Daywitt's factor is closer than my guess!"];
Print["(1/0.21885) = ",(1/0.21885)];

(* summary plot of modified potentials for different charge distributions - Exponential - Gaussian - Imaginary Ring *)

VCompositeZitterExponential[r_]:= -((Z α c hbar)/(  r))(1-Exp[-((2r)/(  rZ))](1+(r/(  rZ))))/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.21885 ;
VCompositeZitterGaussian[r_]:= -((Z α c hbar)/(  r))Erf[ (r/( (Sqrt[2]) rZ))]/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.21885 ;
VCompositeZitterRing[r_]:= -((Z α c hbar)/(  Max[r,rZ]))/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.38126 ;
VCompositeZitterImaginaryRing[r_]:= -((Z α c hbar)/(  (Sqrt[(r^2)+(rZ^2)])))/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.08236385533099996 ;
ReducedComptonWavelength=(hbarval/(mval cval ));
VminForPlot = -1.5 10^-14;
plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitterExponential[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
VCompositeZitterGaussian[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
(* VCompositeZitterRing[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr], *)
VCompositeZitterImaginaryRing[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]
},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{VminForPlot,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue,Purple,(* Red,*)Black},ImageSize->408];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ReducedComptonWavelength/2,VminForPlot} , {ReducedComptonWavelength/2,0} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ReducedComptonWavelength/2,VminForPlot} , {-ReducedComptonWavelength/2,0} }]}} ];
Show[plot1b,line1,line2]

VCompositeZitterExponential[r_]:= -((Z α c hbar)/(  r))(1-Exp[-((2r)/(  rZ))](1+(r/(  rZ))))/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.21885 ;
VCompositeZitterGaussian[r_]:= -((Z α c hbar)/(  r))Erf[ (r/( (Sqrt[2]) rZ))]/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.21885 ;
VCompositeZitterRing[r_]:= -((Z α c hbar)/(  Max[r,rZ]))/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.38126 ;
VCompositeZitterImaginaryRing[r_]:= -((Z α c hbar)/(  (Sqrt[(r^2)+(rZ^2)])))/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.08236385533099996 ;
ReducedComptonWavelength=(hbarval/(mval cval ));
VminForPlot = -1.5 10^-14;
plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitterExponential[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
VCompositeZitterGaussian[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
VCompositeZitterRing[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
VCompositeZitterImaginaryRing[r]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]
},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{VminForPlot,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue,Purple, Red,Black},ImageSize->408];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ReducedComptonWavelength/2,VminForPlot} , {ReducedComptonWavelength/2,0} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ReducedComptonWavelength/2,VminForPlot} , {-ReducedComptonWavelength/2,0} }]}} ];
Show[plot1b,line1,line2]

Graphics[{Arrowheads[0.025],Arrow[{{j + .2*i,EnergyEVArray[[j]]},{j + .2*i,EnergyEVArray[[i+1]]}}]}]

rhoZitterExponential[r_]:= (e/(  π (rZ^3)))Exp[-((2r)/(  rZ))]/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.21885 ;
rhoZitterGaussian[r_]:= (e/(  2(Sqrt[2]) (π^(3/2))(rZ^3)))Exp[-((r^2)/(  2(rZ^2)))]/.Z->1/.rZ->(hbarval/(2 mval cval ))*0.21885 ;

ReducedComptonWavelength=(hbarval/(mval cval ));
VmaxForPlot = 1.05;
ArrowHeight = .6;
plot1c = Plot[{
rhoZitterExponential[r]/rhoZitterExponential[0]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
rhoZitterGaussian[r]/rhoZitterExponential[0]/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr],
},{rr,-.006 a0val,.006 a0val},Frame->True,Axes->False,AspectRatio->0.8,PlotPoints->1000,PlotRange->All,PlotStyle->{Blue,Purple},ImageSize->408];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ReducedComptonWavelength/2,VmaxForPlot} , {ReducedComptonWavelength/2,0} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ReducedComptonWavelength/2,VmaxForPlot} , {-ReducedComptonWavelength/2,0} }]}} ];
line3 = Graphics[{{Red,{Arrowheads[Medium],Arrow[{{ReducedComptonWavelength/2*0.38126,0} , {ReducedComptonWavelength/2*0.38126,ArrowHeight} }]}}} ];
line4 = Graphics[{{Red,{Arrowheads[Medium],Arrow[{{-ReducedComptonWavelength/2*0.38126,0} , {-ReducedComptonWavelength/2*0.38126,ArrowHeight} }]}}} ];
line5 = Graphics[{{Black,{Arrowheads[Medium],Arrow[{{ReducedComptonWavelength/2*0.082364,0} , {ReducedComptonWavelength/2*0.082364,ArrowHeight} }]}}} ];
line6 = Graphics[{{Black,{Arrowheads[Medium],Arrow[{{-ReducedComptonWavelength/2*0.082364,0} , {-ReducedComptonWavelength/2*0.082364,ArrowHeight} }]}}} ];
line7 = Graphics[{{Darker[Green],{Arrowheads[Medium],Arrow[{{0,0} , {0,ArrowHeight} }]}}} ];
Show[plot1c,line1,line2,line3,line4,line5,line6,line7]

Show[Graphics[{Red,{Arrowheads[Large],Arrow[{{0,0},{1,100000000000000000000}}]}}],Frame->True]

(* 1S, 2S Zitterbewegung Imaginary Ring of Charge  *)

(* Imaginary Ring of Charge *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z/.Z->1;
rZScale = 0.08236385533099996`;  (* scale factor needed to match experiment  *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Schrodinger, Hestenes, and Barut and Bracken *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];

VCompositeZitter[r_]:= -((Z α c hbar)/(  (Sqrt[(r^2)+(rZ^2)])))/.Z->1;
Vmod1[r_]:= Z α c hbar(-(1/(Sqrt[(r^2)+(rZ^2)]))+(1/r))/.Z->1;
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2)/.Z->1;
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
LambShift2STargetHz= 1.045032731917778*10^9;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ ]];
μr1Sval = μrval(Sqrt[((Log[(2/(α^2))]-lnk0[2,0])/(Log[(2/(α^2))]-lnk0[1,0]))])/.α->alpha;
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
Print["μr1Sval = ",μr1Sval,"     (scaled μr value for 1S state, accounts for lnk0 adjustment)"];
Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μr1Sval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz (scaled)    target is ",GroundStateShiftHz/10^9," GHz"];
(* can't seem to do 2S shift in closed form *)
(*
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShift2STargetHz/10^9," GHz"]; 
*)

plot1b = Plot[{V0[Abs[rr]]/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitter[r]/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]
(*,
VTruncatedCoulomb[r]/VCompositeZitterAtOrigin/.rT->rTval/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr] *)
},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-2 10^-14,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue,Purple},ImageSize->408];
plot1a = Plot[{ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
plot1c = Plot[{1.36(r/rZ)^2ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ComptonWavelength/2,0} , {ComptonWavelength/2,1} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ComptonWavelength/2,0} , {-ComptonWavelength/2,1} }]}} ];
(* Grid[{{Show[plot1a,line1,line2]},{Show[plot1c,line1,line2]},{plot1b}}] *)
Show[plot1b]

(* Gaussian 2S Numerical Solution (Schrodinger)  *)

(* set up R2S numerical solution *)
a0=a0val;
Off[InterpolatingFunction::dmval];
Off[NIntegrate::ncvb];
f1[r_]:= (E^((-(Sqrt[1+εval])) r/(2a0)))  HypergeometricU[1-(2/( (Sqrt[1+εval]))),2,(Sqrt[1+εval]) r/a0];
εval = -.000001;   
rmax = 2a0val (1-.000000001);
rmin = rmax/10000000000000;
RdZero = -0.0008 R20*2;
RdPrimeZero = 2R20/a0val;

iteration = 1;
maxIterations = 20;
resultRecord = Table[{0,Infinity},{n,1,2}];
relativeError = Infinity;
relativeErrorThreshold = 10^(-9);
lastεval = εval;

rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];

While [(Abs[relativeError]≥relativeErrorThreshold) && (iteration≤maxIterations),


normTolerance = 1*10^-9;
iteration2 = 1;
maxIterations2 = 8;
resultRecord2 = Table[{0,Infinity},{n,1,2}];
normError = Infinity;
lastRdZero = RdZero;

While [(Abs[normError]≥normTolerance) && (iteration2≤maxIterations2),
Clear[Rd];

(*
V=2/(a0 r);
dV = -V Exp[-2 r/rc](1+r/rc);  (* usual exponential correction *)
dV = -V(1-Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;  (* new Gaussian correction *)
Rdsoln = NDSolve[{Rd''[r]+ Rd'[r]( 2/r)+ Rd[r](-(1+εval)/a0^2+V + dV          )+R00 Exp[-r/a0](-(εval)/a0^2 + dV )==0,Rd[rmin]==RdZero,Rd'[rmin]==RdPrimeZero},Rd,{r,rmin,rmax}];
*)
V=2/(a0 r);
(* dV = -V Exp[- r/rc](1+(3/4)r/rc+(1/4)(r/rc)^2+(1/8)(r/rc)^3); *) (* usual exponential correction *)
dV = -V(1-Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;  (* new Gaussian correction *)
Rdsoln = NDSolve[{Rd''[r]+ Rd'[r]( 2/r)+ Rd[r](-(1+εval)/(4a0^2)+V +dV  )+R20 (2-r/a0)Exp[-r/(2a0)](-(εval)/(4a0^2) +dV )==0,Rd[rmin]==RdZero,Rd'[rmin]==RdPrimeZero},Rd,{r,rmin,rmax}];
R2Sd[r_] := Evaluate[Rd[r]/.Rdsoln][[1]];
R2S[r_] := R2Sd[r]+R2[r];

(* choose two points from numerical solution *)
r1 = 200rc;
r2 = 1600 rc; 
R2Sdnumr1 = R2Sd[r1];
R2Sdnumr2 = R2Sd[r2];

(* determine cU to match numerical solution at the first point *)
f1r1 = f1[r1];
f1r2 = f1[r2];

cU =  (R2Sdnumr1+R20 (2-r1/a0)Exp[-r1/(2a0)])/f1r1;  (* 1.000002114970299 R00 *)
error = (cU f1r2-R20 (2-r2/a0)Exp[-r2/(2a0)]-R2Sdnumr2)/R20;
relativeError = (1-R2Sdnumr2/(cU f1r2-R20 (2-r2/a0)Exp[-r2/(2a0)]));
relativeErrorString = If[Abs[relativeError]<relativeErrorThreshold,"PASS","FAIL"];

RdHyper[r_] :=cU f1[r]- R20 (2-r/a0)Exp[-r/(2a0)];
R2Hyper[r_] := R2[r] + RdHyper[r];


normIntegral =NIntegrate[r^2 *(R2S[rmin])^2,{r,0,rmin}]+
NIntegrate[r^2 *(R2S[r])^2,{r,rmin,r1}]+
NIntegrate[r^2 *(R2Hyper[r])^2,{r,r1,2 a0 - rmin}]+
NIntegrate[r^2 *(R2Hyper[r])^2,{r,2 a0 - rmin,2 a0 + rmin}]+
NIntegrate[r^2 *(R2Hyper[r])^2,{r,2 a0 + rmin,Infinity}]; 
normError = normIntegral-1;
normTestString = If[Abs[normError]<normTolerance,"PASS","FAIL"];

Print["   iteration2 = ",iteration2," εval = ",InputForm[εval],"  RdZero/R20 = ",InputForm[RdZero/R20],"  normIntegral = ",normIntegral,"  normError = ",normError,"   ",normTestString];

lastRdZero = RdZero;
If[iteration2==1,
         resultRecord2[[1]]={RdZero,normError};
         RdZero = RdZero*1.01;
         , 
                 (* find slot with worst error *)
                  badSlot = If[Abs[resultRecord2[[1,2]]]>Abs[resultRecord2[[2,2]]],1,2];
                  (* overwrite it *)
                   resultRecord2[[badSlot]]={RdZero,normError};
                  (* use existing content to determine next energy value *)
                          
             RdZero = resultRecord2[[1,1]] - (resultRecord2[[2,1]]-resultRecord2[[1,1]] )*(resultRecord2[[1,2]])/(resultRecord2[[2,2]]-resultRecord2[[1,2]]);
         ];

iteration2++;

];
RdZero = lastRdZero;
Print["iteration = ",iteration," εval = ",InputForm[εval]," point1  = ",(R2Sdnumr1)/R20," point2 = ",(R2Sdnumr2)/R20," fit = ",(cU f1r2-R20 (2-r2/a0)Exp[-r2/(2a0)])/R20," cU/R20  = ",cU/R20,"  error = ",error," = ",relativeError*100,"%  ",relativeErrorString];

lastεval = εval;
If[iteration==1,
         resultRecord[[1]]={εval,relativeError};
         εval = εval*1.01;
         , 
                 (* find slot with worst error *)
                  badSlot = If[Abs[resultRecord[[1,2]]]>Abs[resultRecord[[2,2]]],1,2];
                  (* overwrite it *)
                   resultRecord[[badSlot]]={εval,relativeError};
                  (* use existing content to determine next energy value *)
                    εval = resultRecord[[1,1]] - (resultRecord[[2,1]]-resultRecord[[1,1]] )*(resultRecord[[1,2]])/(resultRecord[[2,2]]-resultRecord[[1,2]]);
         ];
(* Print["resultRecord = ",resultRecord]; *)

iteration++;
];
εval = lastεval;
peakval = (R2S[rmin]/(2 R20))^2;
Print["peakval = ",peakval];

(* establish plot ranges *)
plotrangeLong = 30 a0;
plotrangeMedium = 24 a0;
plotrangeRound = rmax;
plotrangeRound2 =  16a0 / 1836;
plotrangeRound2a =  18a0 / 1836;

(* plot everything *)
InitialLine[r_] := RdZero + RdPrimeZero r;
plot20d = ListPlot[{{r1,R2Sd[r1] /R20/2},{r2,R2Sd[r2]/R20/2}},Joined->False,PlotStyle->PointSize[.02]];
plot22 = Plot[{RdHyper[r]/R20/2,InitialLine[r]/R20/2},{r,rmin,plotrangeRound2a},Frame->True,AspectRatio->0.8,PlotStyle->{Darker[Green],{Purple,Dashing[{Small,Tiny}]}},PlotRange->{-.0014,.0002}];
plotmin = -5;
plotmax =5;
plot2 = Plot[{    RdHyper[r]/R20/2 },
             {r,rmin,plotrangeRound},
             PlotStyle->{Darker[Green]},
             PlotRange->{-.0011,.0002}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2d = Plot[{    RdHyper[r]/R20/2 },
             {r,rmin,plotrangeMedium},
             PlotStyle->{Darker[Green]},
             PlotRange->{-0.00006,0.00001}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2e = Plot[{    RdHyper[r]/R20 /2},
             {r,rmin,plotrangeMedium},
             PlotStyle->{Darker[Green]},Filling->Axis,
             PlotRange->{-0.00006,0.00001}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];

plot5 = Plot[R2Sd[r]/R20/2,{r,rmin,plotrangeRound2a/2.5},Frame->True,PlotStyle->Blue,PlotRange->{-.0014,.0002},AspectRatio->0.8];
plot6d = Plot[R2Sd[r]/R20/2,{r,rmin,rmax},Frame->True,PlotStyle->Blue,PlotRange->{-.0011,.0002}];

plotrangeRound2a =  6a0 / 1836;
plotmin = 0.9932;
plotmax = 1.0002;
plot7 = Plot[{ (R2[Abs[r2]])^2 / R20^2/4,   (R2Hyper[r])^2 / R20^2/4/.r->Abs[r2]},
             {r2,-plotrangeRound2a,plotrangeRound2a},
             PlotStyle->{Red, Darker[Green]},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot8 = Plot[(R2S[r]/R20)^2/4,{r,rmin,plotrangeRound2a},PlotRange->{plotmin,plotmax},Frame->True,AspectRatio->0.8];
plot9 = Plot[(R2S[-r]/R20)^2/4,{r,-plotrangeRound2a,-rmin},PlotRange->{plotmin,plotmax},Frame->True,AspectRatio->0.8];



Show[GraphicsGrid[{{Show[plot2,plot6d,plot20d],Show[plot2d,plot6d,plot20d,PlotRange->{-0.00001,0.000002},PlotLabel->StringJoin["εval = ",ToString[(εval),InputForm]]],Show[plot2e,plot6d,plot20d,PlotRange->{-0.000001,0.0000012}]},{Show[plot5,plot22],Show[plot7,plot8,plot9]}}]]

(* Gaussian 1S Numerical Solution (Schrodinger)  *)

(* set up numerical solution *)
(* note:  the inner loop adjusts RdZero until charge is normalized, then outer loop adjusts ε until continuity is achieved   *)
Off[InterpolatingFunction::dmval];
Off[NIntegrate::ncvb];
f1[r_]:= (E^((-(Sqrt[1+εval])) r/a0))  HypergeometricU[1-(1/( (Sqrt[1+εval]))),2,2(Sqrt[1+εval]) r/a0];
εval = -.00000100000;                    (* -.00000100000;  *)  (* -1.1843071020237506`*^-6 *)
rmax = 2000a0 / 1836;
rmin = rmax/1000000000;
RdZero = -0.0004 R00;  (* -0.0004 R00; *)  (* -0.0008211580472791136` * R00; *)
RdPrimeZero = R00/a0;

iteration = 1;
maxIterations = 20;                                                     (* 8 *)
resultRecord = Table[{0,Infinity},{n,1,2}];
relativeError = Infinity;
relativeErrorThreshold = 10^(-9);
lastεval = εval;

rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];


While [(Abs[relativeError]≥relativeErrorThreshold) && (iteration≤maxIterations),

normTolerance = 1*10^-9;
iteration2 = 1;
maxIterations2 = 8;                                               (* 8 *)
resultRecord2 = Table[{0,Infinity},{n,1,2}];
normError = Infinity;
lastRdZero = RdZero;

While [(Abs[normError]≥normTolerance) && (iteration2≤maxIterations2),
Clear[Rd];

V=2/(a0 r);
dV = -V Exp[-2 r/rc](1+r/rc);  (* usual exponential correction *)
dV = -V(1-Erf[(r/((Sqrt[2]) rZ))])/.rZ->rZval;  (* new Gaussian correction *)

Rdsoln = NDSolve[{Rd''[r]+ Rd'[r]( 2/r)+ Rd[r](-(1+εval)/a0^2+V + dV          )+R00 Exp[-r/a0](-(εval)/a0^2 + dV )==0,Rd[rmin]==RdZero,Rd'[rmin]==RdPrimeZero},Rd,{r,rmin,rmax}];
R1Sd[r_] := Evaluate[Rd[r]/.Rdsoln][[1]];
R1S[r_] := R1Sd[r]+R0[r];

(* choose two points from numerical solution *)
r1 = 200rc;
r2 = 600 rc; 
R1Sdnumr1 = R1Sd[r1];
R1Sdnumr2 = R1Sd[r2];

(* determine cU to match numerical solution at the first point *)
f1r1 = f1[r1];
f1r2 = f1[r2];
cU =  (R1Sdnumr1+R00 Exp[-r1/a0])/f1r1;  (* 1.000002114970299 R00 *)
error = (cU f1r2-R00 Exp[-r2/a0]-R1Sdnumr2)/R00;
relativeError = (1-R1Sdnumr2/(cU f1r2-R00 Exp[-r2/a0]));
relativeErrorString = If[Abs[relativeError]<relativeErrorThreshold,"PASS","FAIL"];

RdHyper[r_] :=cU f1[r]- R00 Exp[-r/a0];
R1Hyper[r_] := R0[r] + RdHyper[r];

normIntegral =NIntegrate[r^2 *(R1S[r])^2,{r,rmin,r1}]+NIntegrate[r^2 *(R1Hyper[r])^2,{r,r1,Infinity}];
normError = normIntegral-1;
normTestString = If[Abs[normError]<normTolerance,"PASS","FAIL"];

Print["   iteration2 = ",iteration2," εval = ",InputForm[εval],"  RdZero/R00 = ",InputForm[RdZero/R00],"  normIntegral = ",normIntegral,"  normError = ",normError,"   ",normTestString];

lastRdZero = RdZero;
If[iteration2==1,
         resultRecord2[[1]]={RdZero,normError};
         RdZero = RdZero*1.0001;
         , 
                 (* find slot with worst error *)
                  badSlot = If[Abs[resultRecord2[[1,2]]]>Abs[resultRecord2[[2,2]]],1,2];
                  (* overwrite it *)
                   resultRecord2[[badSlot]]={RdZero,normError};
                  (* use existing content to determine next energy value *)
                          
             RdZero = resultRecord2[[1,1]] - (resultRecord2[[2,1]]-resultRecord2[[1,1]] )*(resultRecord2[[1,2]])/(resultRecord2[[2,2]]-resultRecord2[[1,2]]);
         ];

iteration2++;

];
RdZero = lastRdZero;
Print["iteration = ",iteration," εval = ",InputForm[εval]," cU/R00  = ",InputForm[cU/R00],"  error = ",error," = ",relativeError*100,"%  ",relativeErrorString];

lastεval = εval;
If[iteration==1,
         resultRecord[[1]]={εval,relativeError};
         εval = εval*1.01;
         , 
                 (* find slot with worst error *)
                  badSlot = If[Abs[resultRecord[[1,2]]]>Abs[resultRecord[[2,2]]],1,2];
                  (* overwrite it *)
                   resultRecord[[badSlot]]={εval,relativeError};
                  (* use existing content to determine next energy value *)
                    εval = resultRecord[[1,1]] - (resultRecord[[2,1]]-resultRecord[[1,1]] )*(resultRecord[[1,2]])/(resultRecord[[2,2]]-resultRecord[[1,2]]);
         ];
(* Print["resultRecord = ",resultRecord]; *)

iteration++;
];
εval = lastεval;
peakval = (R1S[rmin]/(R00))^2;
Print["peakval = ",peakval];

(* establish plot ranges *)
plotrangeLong = 30 a0;
plotrangeMedium = 6 a0;
plotrangeRound = rmax;
plotrangeRound2 =  12a0 / 1836;
plotrangeRound2a =  6a0 / 1836;

(* plot everything *)
InitialLine[r_] := RdZero + RdPrimeZero r;
plot20d = ListPlot[{{r1,R1Sd[r1] /R00},{r2,R1Sd[r2]/R00}},Joined->False,PlotStyle->PointSize[.02]];
plot22 = Plot[{RdHyper[r]/R00,InitialLine[r]/R00},{r,rmin,plotrangeRound2},Frame->True,AspectRatio->0.8,PlotStyle->{Darker[Green],{Purple,Dashing[{Small,Tiny}]}},PlotRange->{-.0014,.0002}];
plotmin = -5;
plotmax =5;
plot1 = Plot[{(SchrodingerError[R1Hyper[r],(Subscript[E, 0])(1+εval),V1[r]]/.r->Abs[r2] ),
                      (SchrodingerError[ R1S[r],(Subscript[E, 0])(1+εval),V1[r]]/.r->Abs[r2] )},
            {r2,- plotrange, plotrange},PlotRange->{plotmin,plotmax},
            PlotStyle->{Darker[Green],Blue},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2 = Plot[{    RdHyper[r]/R00 },
             {r,rmin,plotrangeRound},
             PlotStyle->{Darker[Green]},
             PlotRange->{-.0011,.0002}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2d = Plot[{    RdHyper[r]/R00 },
             {r,rmin,plotrangeMedium},
             PlotStyle->{Darker[Green]},
             PlotRange->{-0.00001,0.00001}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot2e = Plot[{    RdHyper[r]/R00 },
             {r,rmin,plotrangeMedium},
             PlotStyle->{Darker[Green]},Filling->Axis,
             PlotRange->{-0.00001,0.00001}  ,Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];

plot6 = Plot[H1S[r]/R00,{r,rmin,rmax},Frame->True,PlotStyle->Blue,PlotRange->{-.0011,.0002}];
plot5 = Plot[R1Sd[r]/R00,{r,rmin,plotrangeRound2a},Frame->True,PlotStyle->Blue,PlotRange->{-.0014,.0002},AspectRatio->0.8];
plot6d = Plot[R1Sd[r]/R00,{r,rmin,rmax},Frame->True,PlotStyle->Blue,PlotRange->{-.0011,.0002}];

plotmin = 0.9932;
plotmax = 1.0002;
plot7 = Plot[{ (R0[Abs[r2]])^2 / R00^2,   (R1Hyper[r])^2 / R00^2/.r->Abs[r2]},
             {r2,-plotrangeRound2a,plotrangeRound2a},
             PlotStyle->{Red, Darker[Green]},
             PlotRange->{plotmin,plotmax},Frame->True,Axes->True,AxesOrigin->{0,0},AspectRatio->0.8];
plot8 = Plot[(R1S[r]/R00)^2,{r,rmin,plotrangeRound2a},PlotRange->{plotmin,plotmax},Frame->True,AspectRatio->0.8];
plot9 = Plot[(R1S[-r]/R00)^2,{r,-plotrangeRound2a,-rmin},PlotRange->{plotmin,plotmax},Frame->True,AspectRatio->0.8];
Show[GraphicsGrid[{{Show[plot2,plot6d,plot20d],Show[plot2d,plot6d,plot20d,PlotRange->{-0.000005,0.000001},PlotLabel->StringJoin["εval = ",ToString[(εval),InputForm]]],Show[plot2e,plot6d,plot20d,PlotRange->{-5*10^-7,2.3*10^-7}]},
{Show[plot5,plot22],Show[plot7,plot8,plot9](* ,plot1*)}}]]

(* Erf vs. Tanh *)

Plot[{Tanh[x],Erf[x*.875]},{x,-5,5},Frame->True,AspectRatio->0.8]

(* interpreting Dirac Solution *)

r = (Sqrt[1-2 rB Cos[θ] +(rB^2) ]);
Plot[{r/.rB->alpha/4,1-rB Cos[θ]/.rB->alpha/4},{θ,0,π},Frame->True,AspectRatio->0.8]

(* 1S, 2S Zitterbewegung state - Gaussian Distribution with radius = λe/2*0.218849 - scaling fits distribution inside cube of Compton wavelength,
   looks like Feynman's F(s^2) function           *)

(* "Gaussian" Distribution, radius = λe/2*0.218849 *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z/.Z->1;
rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
(* rZScale = 1; *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];

VCompositeZitter[r_]:= -((Z α c hbar)/( r ))*Erf[(r/((Sqrt[2]) rZ))]/.Z->1;
Vmod1[r_]:= ((Z α c hbar)/( r ))(1-Erf[(r/((Sqrt[2]) rZ))])/.Z->1;
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2)/.Z->1;
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
LambShift2STargetHz= 1.045032731917778*10^9;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ ]];
μr1Sval = μrval(Sqrt[((Log[(2/(α^2))]-lnk0[2,0])/(Log[(2/(α^2))]-lnk0[1,0]))])/.α->alpha;
Print["μr1Sval = ",μr1Sval,"     (scaled μr value for 1S state, accounts for lnk0 adjustment)"];
Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μr1Sval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz (scaled)    target is ",GroundStateShiftHz/10^9," GHz"];
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShift2STargetHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Df = -εgeneral (( ((μr)^2))/( (Z^2)));
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-εgeneral,"                   εgeneral = ",εgeneral]; 
Print["Distribution Factor Df = ",Df,"            target Df = 26 α =  ",26 alpha]; 
ComptonWavelength=(hbarval/(mval cval ));
ChargeDistribution[r_]:= ((E^(-((r^2)/(2 (rZ^2)))))/(2 (Sqrt[2]) (π^(3/2)) (rZ^3))) ;
ChargeDistributionNormalized[r_]:= (E^(-((r^2)/(2 (rZ^2))))) ;
VCompositeZitterAtOrigin= ((Z α c hbar)/( rZ))/.rz->rZval/.Z->1;
VTruncatedCoulomb[r_]:= -((Z α c hbar)/(  ((((r^n)+(rT^n)))^(1/n))))/.Z->1/.n->2.5;
rTval = 1.25rZval;
plot1b = Plot[{V0[Abs[rr]]/VCompositeZitterAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitter[r]/VCompositeZitterAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]
(*,
VTruncatedCoulomb[r]/VCompositeZitterAtOrigin/.rT->rTval/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr] *)
},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-1.2,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue,Purple},ImageSize->408];
plot1a = Plot[{ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
plot1c = Plot[{1.36(r/rZ)^2ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ComptonWavelength/2,0} , {ComptonWavelength/2,1} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ComptonWavelength/2,0} , {-ComptonWavelength/2,1} }]}} ];
Grid[{{Show[plot1a,line1,line2]},{Show[plot1c,line1,line2]},{plot1b}}]

(* Modified Potential for 1S Zitterbewegung state - "Gaussian" derivation *)

Normal3DDistribution[r_,rZ_]:= ((E^(-((r^2)/(2(rZ^2)))))/(2 (Sqrt[2]) (π^(3/2)) (rZ^3)));  (* definition of normalized 3D Gaussian Distribution *)

volume = Integrate[4 π Normal3DDistribution[r,rN](r^2),{r,0,Infinity},Assumptions->{Element[rN,Reals],rN>0}];  (* verify unit volume *)
Print["Normal3DDistribution[r,rN] = ",Normal3DDistribution[r,rZ]];
Print["volume = ",volume];
Clear[rB,rA,rZ,r];
Fr1SZitter=((q^2)/(4 π epsilon0 ))(1/(2 (Sqrt[2]) (π^(3/2)) (rZ^3)))Integrate[((2 π (E^(-((rB^2)/(2 (rZ^2)))))(rA-rB Cos[θ])Sin[θ])/((((rA^2) -2rA rB  Cos[θ] + (rB^2)))^(3/2)))(rB^2),{rB,0,Infinity},{θ,0,Pi},Assumptions->{Element[{rA,rZ},Reals],rA>0,rZ>0,rA≠rZ}];
Print["Fr1SZitter = ",Fr1SZitter];
Vr1SZitter = Integrate[Fr1SZitter,{rA,Infinity,r},Assumptions->{Element[{rA,rZ,r},Reals],rA>0,rZ>0,r>0,rA≠rZ}];
Print["Vr1SZitter = ",Vr1SZitter];

rZScale = 1;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
(* rZScale = 1; *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];
plot1a=Plot[Fr1SZitter/.rZ->rZval/.epsilon0->(Subscript[ϵ, 0])/.q->e/.rA->Abs[r],{r,-.025 a0val,.025 a0val},Frame->True,AspectRatio->0.8,PlotRange->{-.0002,.0015}];
plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval,
Vr1SZitter/.rZ->rZval/.epsilon0->(Subscript[ϵ, 0])/.q->e/.r->Abs[rr]},{rr,-.025 a0val,.025 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-1.0*10^-15,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue}];
plot1c = Plot[{Erf[((Abs[rr])/((Sqrt[2]) rZ))]/.rZ->rZval},{rr,-.025 a0val,.025 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->All,PlotStyle->{Blue}];

Show[GraphicsRow[{plot1a,plot1b,plot1c}]]

(* Gaussian vs. Exponential Radial Function - familiarization *)

PDF[MultinormalDistribution[{0,0,0},{{(rN^2),0,0},{0,(rN^2),0},{0,0,(rN^2)}}],{x,y,z}]

Normal3DDistribution[r_,rN_]:= ((E^(-((r^2)/(2(rN^2)))))/(2 (Sqrt[2]) (π^(3/2)) (rN^3)));  (* definition of normalized 3D Gaussian Distribution *)

volume = Integrate[4 π Normal3DDistribution[r,rN](r^2),{r,0,Infinity},Assumptions->{Element[rN,Reals],rN>0}];  (* verify unit volume *)
Print["Normal3DDistribution[r,rN] = ",Normal3DDistribution[r,rN]];Print["volume = ",volume];

Exp3DDistribution[r_,rX_]:= ((E^(-((2r)/rX)))/( π (rX^3)));  (* definition of normalized 3D Gaussian Distribution *)

volume = Integrate[4 π Exp3DDistribution[r,rX](r^2),{r,0,Infinity},Assumptions->{Element[rX,Reals],rX>0}];  (* verify unit volume *)
Print["Exp3DDistribution[r,rX] = ",Exp3DDistribution[r,rX]];
Print["volume = ",volume];

plot1=Plot[{Exp3DDistribution[r,rX]/.rX->1/.r->Abs[r2],
Normal3DDistribution[r,rN]/.rN->1/.r->Abs[r2]},{r2,-5,5},Frame->True,PlotRange->All,PlotStyle->{Blue,Darker[Green]},AspectRatio->0.8];
plot2=Plot[{(r^2)Exp3DDistribution[r,rX]/.rX->1/.r->Abs[r2],
(r^2)Normal3DDistribution[r,rN]/.rN->1/.r->Abs[r2]},{r2,-5,5},Frame->True,PlotRange->All,PlotStyle->{Blue,Darker[Green]},AspectRatio->0.8];
Show[GraphicsRow[{plot1,plot2}]]

(* David J. Maker's Modified Potential - doesn't seem to work *)

rH = ((2 (e^2))/(4 Pi (Subscript[ϵ, 0])m (c^2) ))/.c->cval;
Print["rp       = ",rp,"       Proton Radius"];
Print["rH       = ",rH,"     David J. Maker's rH"];
rZval = (hbarval/(2mval cval ));
Print["rZ       = ",rZval,"      David Hestene's rZ"];
reducedComptonWavelengthElectron = (hbarval/(mval cval ));
Print["\!\(\*FractionBox[\(λe\), \(2\\ π\)]\)      = ",reducedComptonWavelengthElectron,"     Reduced Compton Wavelength for Electron"];
Print["a0       = ",a0val,"     Bohr Radius"];
Print["rZ/rH    = ",rZval/rH," = \!\(\*FractionBox[\(1\), \(4\\ α\)]\)"];
Print["rH/rp    = ",rH/rp];

(* David J. Maker's Modified Potential *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z/.Z->1;
rH = ((2 (e^2))/(4 Pi (Subscript[ϵ, 0])m (c^2) ))/.c->cval;
Print["rp       = ",rp,"       Proton Radius"];
Print["rH       = ",rH,"     David J. Maker's rH"];

Vmod1[r_]:= (3/( 8 ))((((rH/( r ))))^2);
VCompositeMaker[r_]:= -((Z α c hbar)/( r ))+Vmod1[r];
Print["V[r] = ",VCompositeMaker[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2)/.Z->1;
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
LambShift2STargetHz= 1.045032731917778*10^9;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->a0val];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->a0val ]];
μr1Sval = μrval(Sqrt[((Log[(2/(α^2))]-lnk0[2,0])/(Log[(2/(α^2))]-lnk0[1,0]))])/.α->alpha;
Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μr1Sval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz (scaled)    target is ",GroundStateShiftHz/10^9," GHz"];
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShift2STargetHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Df = -εgeneral (( ((μr)^2))/( (Z^2)));
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-εgeneral,"                   εgeneral = ",εgeneral]; 
Print["Distribution Factor Df = ",Df,"            target Df = 26 α =  ",26 alpha]; 
ComptonWavelength=(hbarval/(mval cval ));
ChargeDistribution[r_]:= ((2 )/(rZ^3))Exp[-2 r/rZ ] ;
ChargeDistributionNormalized[r_]:= Exp[-2 r/rZ ] ;
VCompositeMakerAtOrigin= ((Z α c hbar)/( rZ))/.rz->rZval/.Z->1;
plot1b = Plot[{V0[Abs[rr]]/VCompositeMakerAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitter[r]/VCompositeMakerAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-1.2,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue},ImageSize->408];
plot1a = Plot[{ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
plot1c = Plot[{7.4(r/rZ)^2ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ComptonWavelength/2,0} , {ComptonWavelength/2,1} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ComptonWavelength/2,0} , {-ComptonWavelength/2,1} }]}} ];
Grid[{{Show[plot1a,line1,line2]},{Show[plot1c,line1,line2]},{plot1b}}]

(* Modified Potential for 1S Zitterbewegung state - "Ring of Charge" derivation *)

(* Derive modified Coulomb potential for Zitterbewegung with "Ring of Charge" charge distribution *)
(* First get the force on the electron *)
Clear[rB,rA,rZ,r];
Fr1SZitter=((q^2)/(4  (π^2)epsilon0 ))Integrate[(((rA-rZ Cos[θ]))/((((rA^2) -2rA rZ  Cos[θ] + (rZ^2)))^(3/2))),{θ,0,Pi},Assumptions->{Element[{rA,rZ},Reals],rA>0,rZ>0,rA≠rZ}];
Print["Fr1SZitter = ",Fr1SZitter];
rZval = (hbarval/(2 mval cval ));           (* Zitterbewegung helix radius, from Hestenes *)
Fr1SZitterEvaluated = Fr1SZitter/.rZ->rZval/.epsilon0->(Subscript[ϵ, 0])/.q->e;
CenterClip[x_,epsilon_] := Max[Sign[x]x,epsilon]/Sign[x];
rClip = 50rp;
Fr1SZitterClipped = ((7.343654973654792`*^-29 (((EllipticE[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(CenterClip[-1.9307963218967875`*^-13+rA,rClip]))+((EllipticK[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(1.9307963218967875`*^-13+rA))))/rA);
Fr1SZitterClippedTerm1 = ((7.343654973654792`*^-29 (((EllipticE[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(CenterClip[-1.9307963218967875`*^-13+rA,rClip]))))/rA);
Fr1SZitterClippedTerm2 = ((7.343654973654792`*^-29 (((EllipticK[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(1.9307963218967875`*^-13+rA))))/rA);

(* now integrate numerically to get the potential (closed-form integration is apparently not possible) *)  

Off[NIntegrate::precw];
Off[NIntegrate::slwcon];
rClip = 2rp;
Fr1SZitterClipped = ((7.343654973654792`*^-29 (((EllipticE[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(CenterClip[-1.9307963218967875`*^-13+rA,rClip]))+((EllipticK[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(1.9307963218967875`*^-13+rA))))/rA);
Fr1SZitterClippedTerm1 = ((7.343654973654792`*^-29 (((EllipticE[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(CenterClip[-1.9307963218967875`*^-13+rA,rClip]))))/rA);
Fr1SZitterClippedTerm2 = ((7.343654973654792`*^-29 (((EllipticK[((7.72318528758715`*^-13 rA)/(((1.9307963218967875`*^-13+rA))^2))])/(1.9307963218967875`*^-13+rA))))/rA);
rtiny = a0/100000000;
point0 = 0;
point1 = rtiny;
point2 =rZval-rClip;
point3 = rZval;
point4 = rZval + rClip;
point5 = rRange;
point6 = Infinity;
numpointsUpper = 500;
numpointsLower = 100;
TotalPoints = numpointsLower+numpointsUpper+3;
Vr1SZitterTable = Table[{0,0},{n,1,TotalPoints}];
SetupPrintMonitor[];
index=1;
Monitor[
Do[
(* PrintMonitor[ToString[n]]; *)
index = n;
rvalue = point5-(n-1)(point5-point4)/(numpointsUpper-1);

Vr1SZittervalueTerm1 = NIntegrate[Fr1SZitterClippedTerm1,{rA,Infinity,rvalue} ,WorkingPrecision->48];
Vr1SZittervalueTerm2= NIntegrate[Fr1SZitterClippedTerm2,{rA,Infinity,rvalue} ,WorkingPrecision->48];
Vr1SZittervalue=Vr1SZittervalueTerm1+Vr1SZittervalueTerm2;

Vr1SZitterTable[[n]] = {rvalue,Vr1SZittervalue};
,{n,1,numpointsUpper}];

index=numpointsUpper+1;
Vr1SZittervalueTerm1 = NIntegrate[Fr1SZitterClippedTerm1,{rA,rvalue,rZval+rtiny} ,WorkingPrecision->72];
Vr1SZittervalueTerm2= NIntegrate[Fr1SZitterClippedTerm2,{rA,rvalue,rZval+rtiny} ,WorkingPrecision->72];
Vr1SZittervalue=Vr1SZittervalue+Vr1SZittervalueTerm1+Vr1SZittervalueTerm2;
Vr1SZitterTable[[numpointsUpper+1]] = {rZval,Vr1SZittervalue};

index=numpointsUpper+2;
Vr1SZittervalueTerm1 = NIntegrate[Fr1SZitterClippedTerm1,{rA,rZval-rtiny,point2} ,WorkingPrecision->72];
Vr1SZittervalueTerm2= NIntegrate[Fr1SZitterClippedTerm2,{rA,rZval-rtiny,point2} ,WorkingPrecision->72];
Vr1SZittervalue=Vr1SZittervalue+Vr1SZittervalueTerm1+Vr1SZittervalueTerm2;
Vr1SZitterTable[[numpointsUpper+2]] = {point2,Vr1SZittervalue};
lastrvalue=point2;
Do[
index=n;
rvalue = point2-(n-(numpointsUpper+2))(point2-point1)/(numpointsLower);

Vr1SZittervalueTerm1 = NIntegrate[Fr1SZitterClippedTerm1,{rA,lastrvalue,rvalue} ,WorkingPrecision->96];
Vr1SZittervalueTerm2= NIntegrate[Fr1SZitterClippedTerm2,{rA,lastrvalue,rvalue} ,WorkingPrecision->96];
Vr1SZittervalue=Vr1SZittervalue+Vr1SZittervalueTerm1+Vr1SZittervalueTerm2;
lastrvalue=rvalue;
Vr1SZitterTable[[n]] = {rvalue,Vr1SZittervalue};
,{n,numpointsUpper+2+1,numpointsUpper+2+numpointsLower}];
Vr1SZitterTable[[numpointsUpper+2+numpointsLower+1]] = {0,Vr1SZittervalue};
,
"index = "<>ToString[index]<>" = "<>ToString[Round[index/(numpointsUpper+2+numpointsLower+1)*100//N]]<>"%"
];

Vr1SZitterTableScale = Transpose[{Transpose[Vr1SZitterTable][[1]],Transpose[Vr1SZitterTable][[2]]/V1AtOrigin}];
Vr1SZitterTableFlipScale = Transpose[{-Transpose[Vr1SZitterTable][[1]],Transpose[Vr1SZitterTable][[2]]/V1AtOrigin}];
Vr1SZitter=Interpolation[Vr1SZitterTable,InterpolationOrder->1];
Vr1SZitterMod[r_] := Vr1SZitter[Abs[r]]-V0[Abs[r]];

(* compare with potential from exponential distribution *)
rZExponentialScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZExponentialval = (hbarval/(2 mval cval ))*rZExponentialScale;           (* Zitterbewegung helix radius from Hestenes, modified to get approximate fit to target data *)
VExponentialZitter[r_]:= -((Z α c hbar)/( r ))*( 1 - Exp[-2 r/rZ](1 + r /rZ)  )/.Z->1/.rZ->rZExponentialval/.α->alpha;


plot1a=Plot[{-V0[Abs[r]]/Abs[r],Fr1SZitter/.rA->Abs[r]/.q->e/.epsilon0->(Subscript[ϵ, 0])/.rZ->rZval ,Fr1SZitterClipped/.rA->Abs[r]},{r,-.04 a0val,.04 a0val},Frame->True,AspectRatio->0.8,PlotRange->{-.006,.006},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue,Purple},PlotPoints->1000];
plot1b=Plot[{V0[Abs[r]]/V1AtOrigin },{r,-.04 a0val,.04 a0val},Frame->True,AspectRatio->0.8,PlotRange->{-.4,.03},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]}}];
plot1c=ListPlot[Vr1SZitterTableScale,PlotRange->All,Joined->False];
plot1cc=ListPlot[Vr1SZitterTableScale,PlotRange->All,Joined->True];
plot1d=ListPlot[Vr1SZitterTableFlipScale,PlotRange->All,Joined->False];
plot1dd=ListPlot[Vr1SZitterTableFlipScale,PlotRange->All,Joined->True];
plot1e=Plot[{Vr1SZitter[Abs[r]]/V1AtOrigin,  (Vr1SZitterMod[Abs[r]])/V1AtOrigin},{r,-rRange,rRange},Frame->True,AspectRatio->0.8,PlotPoints->10000,PlotRange->{-.4,.4}];

plot1f=Plot[{Vr1SZitter[Abs[r]]/V1AtOrigin,  (V0[Abs[r]])/V1AtOrigin,VExponentialZitter[Abs[r]]/V1AtOrigin},{r,-rRange/3,rRange/3},Frame->True,AspectRatio->0.8,PlotPoints->10000,PlotRange->{-0.75,.03},PlotStyle->{Blue,{Darker[Green],Dashing[{Tiny,Tiny}]},Purple}];
Show[GraphicsGrid[{{plot1a,Show[plot1b,(*plot1c,*)plot1cc,(*plot1d,*)plot1dd],plot1e},{plot1f}}]]

(* "Ring of Charge" Distribution, radius = λe/2 *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z/.Z->1;
rZScale = 1;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];

VCompositeZitter[r_]:=Vr1SZitter[r];
Vmod1[r_]:= Vr1SZitterMod[r];
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2)/.Z->1;
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
LambShift2STargetHz= 1.045032731917778*10^9;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,rRange},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ ]];
μr1Sval = μrval(Sqrt[((Log[(2/(α^2))]-lnk0[2,0])/(Log[(2/(α^2))]-lnk0[1,0]))])/.α->alpha
Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μr1Sval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz (scaled)    target is ",GroundStateShiftHz/10^9," GHz"];
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,rRange},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShift2STargetHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Df = -εgeneral (( ((μr)^2))/( (Z^2)));
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-εgeneral,"                   εgeneral = ",εgeneral]; 
Print["Distribution Factor Df = ",Df,"            target Df = 26 α =  ",26 alpha]; 
ComptonWavelength=(hbarval/(mval cval ));
ChargeDistribution[r_]:= ((2 )/(rZ^3))Exp[-2 r/rZ ] ;
ChargeDistributionNormalized[r_]:= Exp[-2 r/rZ ] ;
VCompositeZitterAtOrigin= ((Z α c hbar)/( rZ))/.rz->rZval/.Z->1;
plot1b = Plot[{V0[Abs[rr]]/VCompositeZitterAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitter[r]/VCompositeZitterAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-1.2,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue},ImageSize->408];
plot1a = Plot[{ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
plot1c = Plot[{7.4(r/rZ)^2ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ComptonWavelength/2,0} , {ComptonWavelength/2,1} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ComptonWavelength/2,0} , {-ComptonWavelength/2,1} }]}} ];
Grid[{{Show[plot1a,line1,line2]},{Show[plot1c,line1,line2]},{plot1b}}]

(* Table of Bethe Logarithms *)

BetheLogarithmk0NLplusOneTable[[20,1]]

(* Table of Bethe Logarithms *)
BetheLogarithmk0NLplusOneTable = Transpose[{
{0.298412856×10^1,
0.281176989×10^1,
0.276766361×10^1,
0.274981184×10^1,
0.274082373×10^1,
0.273566421×10^1,
0.273242913×10^1,
0.273026726×10^1,
0.272875117×10^1,
0.272764694×10^1,
0.272681778×10^1,
0.272617934×10^1,
0.272567729×10^1,
0.272527537×10^1,
0.272494860×10^1,
0.272467936×10^1,
0.272445488×10^1,
0.272426577×10^1,
0.272410496×10^1,
0.272396708×10^1
},
{Infinity,
−0.300167086×10^-1,
−0.381902294×10^-1,
−0.419548946×10^-1,
−0.440346956×10^-1,
−0.453121977×10^-1,
−0.461551773×10^-1,
−0.467413520×10^-1,
−0.471657000×10^-1,
−0.474828934×10^-1,
−0.477262681×10^-1,
−0.479171116×10^-1,
−0.480695436×10^-1,
−0.481932338×10^-1,
−0.482949864×10^-1,
−0.483797030×10^-1,
−0.484509878×10^-1,
−0.485115392×10^-1,
−0.485634100×10^-1,
−0.486081845×10^-1
}}];
lnk0[n_,l_]:= BetheLogarithmk0NLplusOneTable[[n,l+1]];
lnk0n200l0=2.72266810;
lnk0n200l1 = -0.0490494865;
lnk0nInfinityl0=2.7226543;
lnk0nInfinityl1 = -0.0490545;
Print["lnk0[1,0] = ",InputForm[lnk0[1,0]]];
Print["lnk0[2,0] = ",InputForm[lnk0[2,0]]];
Print["lnk0[2,1] = ",InputForm[lnk0[2,1]]];
Print["lnk0[20,0] = ",InputForm[lnk0[20,0]]];
Print["lnk0[20,1] = ",InputForm[lnk0[20,1]]];
Print["lnk0n200l0 = ",InputForm[lnk0n200l0]];
Print["lnk0n200l1 = ",InputForm[lnk0n200l1]];
Print["lnk0nInfinityl0 = ",InputForm[lnk0nInfinityl0]];
Print["lnk0nInfinityl1 = ",InputForm[lnk0nInfinityl1]];

Print["Relative Change in lnk0[n,0] over n=1 to n=20 is ", -(((lnk0[1,0]-lnk0[20,0]))/(lnk0[1,0]))*100,"%"];
plotBethe1=ListPlot[Transpose[BetheLogarithmk0NLplusOneTable][[1]],Frame->True,AspectRatio->0.8,PlotStyle-> PointSize[.013],PlotRange->{{0,25},{-.5,3.1}},FrameTicks->{{0,5,10,15,20,{22,200},{24,Infinity}},Automatic,None,None}];
plotBethe1a=Plot[Interpolation[Transpose[BetheLogarithmk0NLplusOneTable][[1]]][n],{n,1,20},Frame->True,AspectRatio->0.8,PlotRange->{-.5,3.1}];
plotBethe1b=ListPlot[{{22,lnk0n200l0},{24,lnk0nInfinityl0}},Frame->True,AspectRatio->0.8,PlotStyle-> PointSize[.013],PlotRange->{{0,23},{-.5,3.1}}];
plotBethe1c=ListPlot[{{20,BetheLogarithmk0NLplusOneTable[[20,1]]},{22,lnk0n200l0},{24,lnk0nInfinityl0}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle->{Blue,Dashing[{Tiny,Tiny}] },PlotRange->{{0,25},{-.5,3.1}}];
plotBethe2=ListPlot[Transpose[BetheLogarithmk0NLplusOneTable][[2]],Frame->True,AspectRatio->0.8,PlotStyle-> {Darker[Green],PointSize[.013]},PlotRange->{-.5,3.1}];
plotBethe2a=Plot[Interpolation[     Take[Transpose[BetheLogarithmk0NLplusOneTable][[2]],{2,20}]     ][n],{n,2,20},PlotStyle-> Darker[Green],Frame->True,AspectRatio->0.8,PlotRange->{-.5,3.1}];
plotBethe2b=ListPlot[{{22,lnk0n200l1},{24,lnk0nInfinityl1}},Frame->True,AspectRatio->0.8,PlotStyle-> {Darker[Green],PointSize[.013]},PlotRange->{-.5,3.1}];
plotBethe2c=ListPlot[{{20,BetheLogarithmk0NLplusOneTable[[20,2]]},{22,lnk0n200l1},{24,lnk0nInfinityl1}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle->{Darker[Green],Dashing[{Tiny,Tiny}] },PlotRange->{{0,25},{-.5,3.1}}];
Show[plotBethe1,plotBethe1a,plotBethe1b,plotBethe1c,plotBethe2,plotBethe2a,plotBethe2b,plotBethe2c]

MatrixForm[Transpose[BetheLogarithmk0NLplusOneTable][[1]]-lnk0nInfinityl0]
lnk0n200l0-lnk0nInfinityl0
plot1 = ListPlot[Transpose[{Table[n,{n,1,20}],Transpose[BetheLogarithmk0NLplusOneTable][[1]]-lnk0nInfinityl0}],PlotRange->{{0,23},All},Frame->True,AspectRatio->0.8];
plot1a = Plot[Interpolation[Transpose[{Table[n,{n,1,20}],Transpose[BetheLogarithmk0NLplusOneTable][[1]]-lnk0nInfinityl0}],InterpolationOrder->5][n],{n,1,20},PlotRange->{{0,23},All},Frame->True,AspectRatio->0.8];

newlist=Transpose[{Table[1/n,{n,1,20}],Transpose[BetheLogarithmk0NLplusOneTable][[1]]-lnk0nInfinityl0}];
AppendTo[newlist,{1/200,lnk0n200l0-lnk0nInfinityl0}];
AppendTo[newlist,{0,0}];
plot2 = ListPlot[newlist,PlotRange->{{0,1.1},All},Frame->True,AspectRatio->0.8];
plot2a = Plot[Interpolation[newlist,InterpolationOrder->5][n],{n,0,1},PlotRange->{{0,1.1},{0,0.27}},Frame->True,AspectRatio->0.8];
plot2b = Plot[0.2614742600000004` x^2,{x,0,1},PlotRange->{{0,1.1},{0,0.27}},Frame->True,AspectRatio->0.8,PlotStyle->Darker[Green]];
Show[GraphicsRow[{Show[plot1,plot1a],Show[plot2,plot2a,plot2b]}]]

BetheFit[n_]:=Exp[1]+.004+.5/n^2-.25/n^3+.0125/n^4;
plotBethe1=ListPlot[Transpose[BetheLogarithmk0NLplusOneTable][[1]],Frame->True,AspectRatio->0.8,PlotStyle-> PointSize[.013],PlotRange->{{0,25},{2.67,3.0}},FrameTicks->{{0,5,10,15,20,{22,200},{24,Infinity}},Automatic,None,None}];
plotBethe1a=Plot[Interpolation[Transpose[BetheLogarithmk0NLplusOneTable][[1]]][n],{n,1,20},Frame->True,AspectRatio->0.8,PlotRange->{-.5,3.1}];
plotBethe1b=ListPlot[{{22,lnk0n200l0},{24,lnk0nInfinityl0}},Frame->True,AspectRatio->0.8,PlotStyle-> PointSize[.013],PlotRange->{{0,23},{-.5,3.1}}];
plotBethe1c=ListPlot[{{1,Exp[1]+.004},{24,Exp[1]+.004}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle-> {Gray,Dashing[{Tiny,Tiny}]},PlotRange->{{0,23},{-.5,3.1}}];
plotBethe1f=ListPlot[{{1,Exp[1]},{24,Exp[1]}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle-> {Gray,Dashing[{Tiny,Tiny}]},PlotRange->{{0,23},{-.5,3.1}}];
plotBethe1d=ListPlot[{{20,BetheFit[n]/.n->20},{22,BetheFit[n]/.n->200},{24,Exp[1]+.004}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle-> {Blue,Dashing[{Tiny,Tiny}]},PlotRange->{{0,23},{-.5,3.1}}];
plotBethe1e=Plot[BetheFit[n],{n,1,20},Frame->True,AspectRatio->0.8,PlotStyle->Blue,PlotRange->{-.5,3.1}];
Show[plotBethe1 (*,plotBethe1a *),plotBethe1b, plotBethe1c,plotBethe1d,plotBethe1e (* ,plotBethe1f *)]

mr c^2 / Abs[(Subscript[E, 0])]
Log[mr c^2 / Abs[(Subscript[E, 0])]]
Log[mr c^2 / Abs[(Subscript[E, 0])]]-BetheFit[1]
Log[mr c^2 / Abs[(Subscript[E, 0])]]-BetheFit[2]
Log[mr c^2 / Abs[(Subscript[E, 0])]]-lnk0nInfinityl0
Exp[Log[mr c^2 / Abs[(Subscript[E, 0])]]-lnk0nInfinityl0]
Exp[lnk0nInfinityl0]
(1-(Log[mr c^2 / Abs[(Subscript[E, 0])]]-BetheFit[1])/(Log[mr c^2 / Abs[(Subscript[E, 0])]]-lnk0nInfinityl0))*100
Exp[Exp[1]]//N

Log[mr c^2 / Abs[(Subscript[E, 0])]]-Transpose[BetheLogarithmk0NLplusOneTable][[1]]

plotEratio1=ListPlot[Log[mr c^2 / Abs[(Subscript[E, 0])]]-Transpose[BetheLogarithmk0NLplusOneTable][[1]],Frame->True,AspectRatio->0.8,PlotStyle-> PointSize[.013],PlotRange->{{0,25},{7.5,7.84}},FrameTicks->{{0,5,10,15,20,{22,200},{24,Infinity}},Automatic,None,None}];
plotEratio1a=Plot[Interpolation[(Log[mr c^2 / Abs[(Subscript[E, 0])]]-Transpose[BetheLogarithmk0NLplusOneTable][[1]])][n],{n,1,20},Frame->True,AspectRatio->0.8,PlotRange->{7.5,7.84}];
plotEratio1b=ListPlot[{{22,Log[mr c^2 / Abs[(Subscript[E, 0])]]-lnk0n200l0},{24,Log[mr c^2 / Abs[(Subscript[E, 0])]]-lnk0nInfinityl0}},Frame->True,AspectRatio->0.8,PlotStyle-> PointSize[.013],PlotRange->{{0,23},{7.5,7.84}}];
plotEratio1c=ListPlot[{{1,Log[mr c^2 / Abs[(Subscript[E, 0])]]-Exp[1]-.004},{24,Log[mr c^2 / Abs[(Subscript[E, 0])]]-Exp[1]-.004}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle-> {Gray,Dashing[{Tiny,Tiny}]},PlotRange->{{0,23},{7.5,7.84}}];
plotEratio1f=ListPlot[{{1,Log[mr c^2 / Abs[(Subscript[E, 0])]]-Exp[1]},{24,Log[mr c^2 / Abs[(Subscript[E, 0])]]-Exp[1]}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle-> {Gray,Dashing[{Tiny,Tiny}]},PlotRange->{{0,23},{7.5,7.84}}];
plotEratio1d=ListPlot[{{20,Log[mr c^2 / Abs[(Subscript[E, 0])]]-BetheFit[n]/.n->20},{22,Log[mr c^2 / Abs[(Subscript[E, 0])]]-BetheFit[n]/.n->200},{24,Log[mr c^2 / Abs[(Subscript[E, 0])]]-Exp[1]-.004}},Frame->True,AspectRatio->0.8,Joined->True,PlotStyle-> {Blue,Dashing[{Tiny,Tiny}]},PlotRange->{{0,23},{7.5,7.84}}];
plotEratio1e=Plot[Log[mr c^2 / Abs[(Subscript[E, 0])]]-BetheFit[n],{n,1,20},Frame->True,AspectRatio->0.8,PlotStyle->Blue,PlotRange->{7.5,7.84}];
Show[plotEratio1 (*,plotEratio1a *),plotEratio1b, plotEratio1c,plotEratio1d,plotEratio1e (* ,plotEratio1f *)]

BetheFit[n]

-Log[2]+(5/6)-(1/5)//N

1/.0125

lnk0nInfinityl0/Exp[1]

Log[lnk0nInfinityl0 ]

Log[2.7226543]

MatrixForm[newlist]

(* Review of Bethe, French & Weisskopf.  My goal is to match French & Weisskopf, with no divergent intermediate steps *)

LambShiftBetheHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))Log[ (( mr (c^2) )/(17.8(-(Subscript[E, 0])) )) ] /.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheOriginalLog = Log[ (( mr (c^2) )/(17.8(-(Subscript[E, 0])) )) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheCutoff = Log[ (( mr (c^2) )/((-(Subscript[E, 0])) )) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheLogarithm2S = Log[ 17.8 ];
Print["BetheOriginalLog             = Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(17.8\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]                                               = ",BetheOriginalLog];
Print["BetheCutoff                  = Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]                                                   = ",BetheCutoff];
Print["BetheLogarithm2S             = Log[17.8]                                                     = ",BetheLogarithm2S];Print["LambShiftBetheHz             = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)Log[ \!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(17.8\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\) ]                             = ",LambShiftBetheHz/10^9," GHz"];
Shift2SFrenchWeisskopfHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))(Log[ (( mr (c^2) )/(16.64(-(Subscript[E, 0])) )) ]-Log[2]+(( 5 )/6) -(( 1 )/5))/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
Shift2PFrenchWeisskopfHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))(Log[ (( 1 )/(0.97 )) ]-(( 1 )/8) )/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
LambShiftFrenchWeisskopfHz = Shift2SFrenchWeisskopfHz-Shift2PFrenchWeisskopfHz;
LambShiftFrenchWeisskopfSEHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))(Log[ (( mr (c^2) )/(16.64(-(Subscript[E, 0])) )) ]-Log[2]+(( 5 )/6)-(Log[ (( 1 )/(0.97 )) ]-(( 1 )/8)) )/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
LambShiftFrenchWeisskopfVPHz =(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))( -(( 1 )/5))/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
Shift2SMohrHz = 6.294*10^6;
LambShiftMohrHz = LambShiftFrenchWeisskopfHz+Shift2SMohrHz;

Print["Shift2SFrenchWeisskopfHz     = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)(Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(16.64\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]-Log[2]+\!\(\*FractionBox[\(\(\\ \)\(5\)\(\\ \)\), \(6\)]\)-\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(5\)]\))              = ",Shift2SFrenchWeisskopfHz/10^9," GHz"];
Print["Shift2SFrenchWeisskopfHz     = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)(Log[ \!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(\(0.97\)\(\\ \)\)]\) ]-\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(8\)]\))                             = ",Shift2PFrenchWeisskopfHz/10^9," GHz"];
Print["LambShiftFrenchWeisskopfHz   = Shift2SFrenchWeisskopfHz-Shift2PFrenchWeisskopfHz             = ",LambShiftFrenchWeisskopfHz/10^9," GHz"];
Print["LambShiftFrenchWeisskopfSEHz = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)(Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(16.64\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]-Log[2]+\!\(\*FractionBox[\(\(\\ \)\(5\)\(\\ \)\), \(6\)]\)-(Log[\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(\(0.97\)\(\\ \)\)]\)]-\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(8\)]\))) = ",LambShiftFrenchWeisskopfSEHz/10^9," GHz"];
Print["LambShiftFrenchWeisskopfVPHz =  \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)( -\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(5\)]\))                                       = ",LambShiftFrenchWeisskopfVPHz/10^9," GHz"];
Print["Shift2SMohrHz                =                                                               = ",Shift2SMohrHz/10^9," GHz"];
Print["LambShiftMohrHz              = LambShiftFrenchWeisskopfHz+Shift2SMohrHz                      = ",LambShiftMohrHz/10^9," GHz"];
LambShift2STargetHz = Shift2SFrenchWeisskopfHz+Shift2SMohrHz;

Print["\nComponents of Lamb Shift, at the level of French and Weisskopf (1948):"];
SummaryArray = {{ "ΔE(GHz)","SE" ,"VP" ,"Total" },{"2S" ,(Shift2SFrenchWeisskopfHz- LambShiftFrenchWeisskopfVPHz)/10^9 ,LambShiftFrenchWeisskopfVPHz /10^9 ,Shift2SFrenchWeisskopfHz /10^9},{"2P" ,Shift2PFrenchWeisskopfHz /10^9 ,"0" ,Shift2PFrenchWeisskopfHz /10^9 },{"Total" ,LambShiftFrenchWeisskopfSEHz/10^9 ,LambShiftFrenchWeisskopfVPHz /10^9,LambShiftFrenchWeisskopfHz/10^9 }};
Print[Grid[SummaryArray,Frame->All]];
Print["\nComponents of Lamb Shift, at the level of Mohr (1975):"];
SummaryArray = {{ "ΔE(GHz)","SE" ,"VP" ,"Other","Total" },{"2S" ,(Shift2SFrenchWeisskopfHz- LambShiftFrenchWeisskopfVPHz)/10^9 ,LambShiftFrenchWeisskopfVPHz /10^9 ,Shift2SMohrHz/10^9,(Shift2SFrenchWeisskopfHz+Shift2SMohrHz) /10^9},{"2P" ,Shift2PFrenchWeisskopfHz /10^9 ,"0" ,"0",Shift2PFrenchWeisskopfHz /10^9 },{"Total" ,LambShiftFrenchWeisskopfSEHz/10^9 ,LambShiftFrenchWeisskopfVPHz /10^9,Shift2SMohrHz/10^9,LambShiftMohrHz/10^9 }};
Print[Grid[SummaryArray,Frame->All]];
Print["LambShift2STargetHz = ",LambShift2STargetHz/10^9," GHz"];

(* My goal will be to match French and Weisskopf, with no divergent intermediate steps *)

(* could replace the crude values above with modern lnk0[n,l] table values *)
Log[ (( 1 )/(16.64 )) ]
-lnk0[2,0]
Log[ (( 1 )/(0.97 )) ]
-lnk0[2,1]

μrWorkBackwards = ((1 )/(Z α))(Sqrt[((3π )/(2 α(Log[((mr (c^2) )/((-E1)))]-lnk20)))])/.lnk20->2.8818/.mr->mrval/.c->cval/.Z->1/.α->alpha
Log[((mr (c^2) )/((-E1)))]/.mr->mrval/.c->cval/.α->alpha
(Log[((mr (c^2) )/((-E1)))]-lnk20)/.lnk20->2.81177/.mr->mrval/.c->cval/.α->alpha
lnk0[2,0]
(Log[((mr (c^2) )/((-E1)))]-lnk0[2,0]-Log[2]+5/6-1/5)/.lnk20->2.8818/.mr->mrval/.c->cval/.α->alpha

(* 1S, 2S Zitterbewegung state - Exponential Distribution with radius = λe/2*0.218849 - scaling fits distribution inside cube of Compton wavelength,
   looks like Feynman's F(s^2) function           *)

(* "Exponential" Distribution, radius = λe/2*0.218849 *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z/.Z->1;
rZScale = 0.218849;  (* scale factor needed to match experiment with this choice of amplitude distribution (Exponential) *)
(* rZScale = 1; *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];

VCompositeZitter[r_]:= -((Z α c hbar)/( r ))*( 1 - Exp[-2 r/rZ](1 + r /rZ)  )/.Z->1;
Vmod1[r_]:= ((Z α c hbar)/( r ))Exp[-2 r/rZ](1 + r /rZ)/.Z->1;
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2)/.Z->1;
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
LambShift2STargetHz= 1.045032731917778*10^9;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ ]];
μr1Sval = μrval(Sqrt[((Log[(2/(α^2))]-lnk0[2,0])/(Log[(2/(α^2))]-lnk0[1,0]))])/.α->alpha;
Print["μr1Sval = ",μr1Sval,"     (scaled μr value for 1S state, accounts for lnk0 adjustment)"];
Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μr1Sval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz (scaled)    target is ",GroundStateShiftHz/10^9," GHz"];
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShift2STargetHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Df = -εgeneral (( ((μr)^2))/( (Z^2)));
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-εgeneral,"                   εgeneral = ",εgeneral]; 
Print["Distribution Factor Df = ",Df,"            target Df = 26 α =  ",26 alpha]; 
ComptonWavelength=(hbarval/(mval cval ));
ChargeDistribution[r_]:= ((2 )/(rZ^3))Exp[-2 r/rZ ] ;
ChargeDistributionNormalized[r_]:= Exp[-2 r/rZ ] ;
VCompositeZitterAtOrigin= ((Z α c hbar)/( rZ))/.rz->rZval/.Z->1;
plot1b = Plot[{V0[Abs[rr]]/VCompositeZitterAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval,
VCompositeZitter[r]/VCompositeZitterAtOrigin/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]},{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-1.2,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue},ImageSize->408];
plot1a = Plot[{ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
plot1c = Plot[{7.4(r/rZ)^2ChargeDistributionNormalized[r]/.rZ->rZval/.r->Abs[rr]},
{rr,-.006 a0val,.006 a0val},Frame->True,AspectRatio->0.2,PlotPoints->1000,PlotRange->{-.1,1.1},PlotStyle->{Blue},Filling->Axis,ImageSize->400];
line1 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{ComptonWavelength/2,0} , {ComptonWavelength/2,1} }]}} ];
line2 = Graphics[{Dashing[{Tiny,Tiny}],{Gray,Line[{{-ComptonWavelength/2,0} , {-ComptonWavelength/2,1} }]}} ];
Grid[{{Show[plot1a,line1,line2]},{Show[plot1c,line1,line2]},{plot1b}}]

1/Sqrt[6 Pi]//N

Sqrt[x Pi/(y z^3)]

(Sqrt[((3π)/(2 (α^3)(7.66205)))])/.α->alpha
(Sqrt[((8 α(7.66205))/(3π))])/.α->alpha

8.360252984998993`*(((Log[(2/(α^2))]-lnk0[1,0])/(Log[(2/(α^2))]-lnk0[2,0])))/.α->alpha

HDarwin2S =  ((m (c^2) (((Z α ))^4))/(h 2 (n^3)))/.n->2/.c->cval/.Z->1/.α->alpha;
HDarwin2SeV = HDarwin2S h / e;
Print["HDarwin2S = ",HDarwin2S/10^9," GHz = ",HDarwin2SeV," eV"];

(* Bethe's expression for Lamb Shift in Hz *)
LambShiftBetheHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))Log[ (( mr (c^2) )/(17.8(-(Subscript[E, 0])) )) ] /.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheOriginalLog = Log[ (( mr (c^2) )/(17.8(-(Subscript[E, 0])) )) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheCutoff = Log[ (( mr (c^2) )/((-(Subscript[E, 0])) )) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheLogarithm2S = Log[ 17.8 ];
Print["BetheOriginalLog           = Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(17.8\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]                                  = ",BetheOriginalLog];
Print["BetheCutoff                = Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]                                      = ",BetheCutoff];
Print["BetheLogarithm2S           = Log[17.8]                                        = ",BetheLogarithm2S];Print["LambShiftBetheHz           = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)Log[ \!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(17.8\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\) ]                = ",LambShiftBetheHz/10^9," GHz"];
LambShiftFrenchWeisskopfHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))(Log[ (( mr (c^2) )/(16.64(-(Subscript[E, 0])) )) ]-Log[2]+(( 5 )/6) -(( 1 )/5))/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
Print["LambShiftFrenchWeisskopfHz = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)(Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(16.64\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]-Log[2]+\!\(\*FractionBox[\(\(\\ \)\(5\)\(\\ \)\), \(6\)]\)-\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(5\)]\)) = ",LambShiftFrenchWeisskopfHz/10^9," GHz"];

(* French and Weisskopf expression for Lamb Shift in Hz *)

(Log[ m  (c^2) ]- Log[17.8 (-(Subscript[E, 0]))] )/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2
Log[17.8]
Log[(( m  (c^2) )/((-(Subscript[E, 0])) ))]/. c->cval
(Log[(( m  (c^2) )/((-(Subscript[E, 0])) ))]-Log[17.8])/. c->cval
2 Log [1/α]/.α->alpha
Log[ 2/ (α^2) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval
19/30//N
(2 Log [1/α]-(Log[ m  (c^2) ]- Log[17.8 (-(Subscript[E, 0]))] )+19/30)/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2

Log[2]//N
19/30//N
-Log[2]+19/30//N

Log[2]//N

Log[(( m  (c^2) )/((-(Subscript[E, 0])) ))]/. c->cval
2 Log [1/α]/.α->alpha
5/6//N
19/30//N
(2 Log [1/α]+19/30//N)/.α->alpha

((( (e^2) )/(4 π (Subscript[ϵ, 0])hbar c )))/.hbar->hbarval /. c->cval
alpha

(Sqrt[(8/(39 (alpha^3)))])

(* find empirical electron radius that agrees with target for ground state *)
(* using non-relativistic units *)
Clear[a0, μ,R00,hbar,mr, re];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0;
rZval = (hbarval/(2 mval cval ))*.380496;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*.380496 = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];


VCompositeZitter[r_]:= -((hbar^2)/(mr a0 Max[r,rZ] ));
Vmod1[r_]:= VCompositeZitter[r]-V0[r];
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = -((hbar^2)/(2mr (a0^2)));
E2 = -((hbar^2)/(8mr (a0^2)));

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
deltaE1 = Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ]];

Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval)/10^9//N)," GHz          target is ",GroundStateShiftHz/10^9," GHz"];

deltaE2 = Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]; 

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval)/10^9//N," GHz          target is ",LambShiftHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\)",-εgeneral,"               εgeneral = ",εgeneral]; 

plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval,
VCompositeZitter[r]/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.r->Abs[rr]},{rr,-.010 a0val,.010 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-4.0*10^-15,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue}];
Show[GraphicsRow[{plot1b}]]

Print["ε1perturb1 = (",ε1perturb1,")                     = ",
(( ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval)//N)];
ε1perturb1/.μr->1/μrinv
-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr
ε2perturb1/.μr->1/μrinv
-2Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr

GroupKeepAll[ε1perturb1,(E^(-2/μr))]
ε2perturb1
GroupKeepAll[ε2perturb1,(E^(-1/μr))]

(* Zitterbewegung nubbin plot *)

r=1.010;
spin=1/2;
plot1 = Graphics3D[{Opacity[0.8],Sphere[{0,0,0}]},Boxed->False];
plot2 = ParametricPlot3D[{r Cos[π/2-ϕ/spin]Sin[ϕ],r Sin[π/2-ϕ/spin]Sin[ϕ],r Cos[ϕ]},{ϕ,0,4 π},PlotStyle->Thickness[0.019],PlotPoints-> 8000,Boxed->False];
plot3 = ParametricPlot3D[{r Cos[π/2-ϕ/spin-π/2]Sin[ϕ],r Sin[π/2-ϕ/spin-π/2]Sin[ϕ],r Cos[ϕ]},{ϕ,0,4 π},PlotStyle->Thickness[0.019],PlotPoints-> 8000,Boxed->False];
Show[GraphicsGrid[{{Show[plot1,plot3,ViewPoint-> {0,0,Infinity}],},{Show[plot1,plot2,ViewPoint-> {Infinity,0,0}],Show[plot1,plot2,ViewPoint-> {0,Infinity,0}]}},Frame->All]]

r=1.010;
spin=2;
plot1 = Graphics3D[{Opacity[0.8],Sphere[{0,0,0}]},Boxed->False];
plot2 = ParametricPlot3D[{r Cos[π/2-ϕ/spin]Sin[ϕ],r Sin[π/2-ϕ/spin]Sin[ϕ],r Cos[ϕ]},{ϕ,0,4 π},PlotStyle->Thickness[0.019],PlotPoints-> 8000,Boxed->False];
plot3 = ParametricPlot3D[{r Cos[π/2-ϕ/spin-π/2]Sin[ϕ],r Sin[π/2-ϕ/spin-π/2]Sin[ϕ],r Cos[ϕ]},{ϕ,0,4 π},PlotStyle->Thickness[0.019],PlotPoints-> 8000,Boxed->False];
Show[GraphicsGrid[{{Show[plot1,plot3,ViewPoint-> {0,0,Infinity}],},{Show[plot1,plot2,ViewPoint-> {Infinity,0,0}],Show[plot1,plot2,ViewPoint-> {0,Infinity,0}]}},Frame->All]]

r=1.000;
plot1 = Graphics3D[{Opacity[0.8],Sphere[{0,0,0}]}];
plot2 = ParametricPlot3D[{r Cos[π/2-ϕ*2]Sin[ϕ],r Sin[π/2-ϕ*2]Sin[ϕ],r Cos[ϕ]},{ϕ,0,4 π},PlotStyle->Thickness[0.019],PlotPoints-> 2000];
Show[plot1,plot2,ViewPoint->{0,Infinity,0}]

Sqrt[a]
a^2

rnet = (Sqrt[(Rne^2)+2Rne rZ Cos[θ] +(rZ^2) ]);
Plot[{rnet/.rZ->1/.Rne->.01,
rnet/.rZ->1/.Rne->.1,
rnet/.rZ->1/.Rne->.5,
rnet/.rZ->1/.Rne->0.9,
rnet/.rZ->1/.Rne->1,
rnet/.rZ->1/.Rne->1.1,
rnet/.rZ->1/.Rne->2
},{θ,0,4Pi},PlotRange->{0,All},Frame->True,AspectRatio->0.8]

rnet = (Sqrt[(Rne^2)+2Rne rZ Cos[θ] +(rZ^2) ]);
Plot[{rnet/.Rne->1/.rZ->.01,
rnet/.Rne->1/.rZ->.1,
rnet/.Rne->1/.rZ->.5,
rnet/.Rne->1/.rZ->0.9,
rnet/.Rne->1/.rZ->1,
rnet/.Rne->1/.rZ->1.1,
rnet/.Rne->1/.rZ->2,
},{θ,0,4Pi},PlotRange->{0,All},Frame->True,AspectRatio->0.8]

(* 1S, 2S Zitterbewegung state - "Shell of Charge" Distribution with radius = λe/2 0.38126  - Predicted shifts fit data but artificial scaling *)

(* "Shell of Charge" Distribution, radius = λe/2 *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z;
rZScale = 0.38126;  (* scale factor needed to match experiment with this choice of amplitude distribution (ring of charge) *)
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];


VCompositeZitter[r_]:= -((Z α c hbar)/( Max[r,rZ] ));
Vmod1[r_]:= VCompositeZitter[r]+((Z α c hbar)/( r ));
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2);
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ ]];

Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz          target is ",GroundStateShiftHz/10^9," GHz"];
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShiftHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Df = -εgeneral (( ((μr)^2))/( (Z^2)));
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-εgeneral,"                   εgeneral = ",εgeneral]; 
(* Print["Distribution Factor Df = ",Df,"            target Df = 26 α =  ",26 alpha]; *)
plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval,
VCompositeZitter[r]/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]},{rr,-.010 a0val,.010 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-4.0*10^-15,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue}];
Show[GraphicsRow[{plot1b}]]

Exp[-1]//N
1/0.38126
2 Pi//N
1/Sqrt[2 Pi]//N
0.38126*Sqrt[2 Pi]//N
1/(((Log[(2/(α^2))]-lnk0nInfinityl0)/(Log[(2/(α^2))]-lnk0[2,0])))/.α->alpha
1-4(1-(1/(((Log[(2/(α^2))]-lnk0nInfinityl0)/(Log[(2/(α^2))]-lnk0[2,0])))/.α->alpha))
(Exp[-1]+1/Sqrt[2 Pi])/2//N

alpha/2
2/alpha
2/alpha/0.38126
2/alpha/0.218849
1/0.38126

(* 1S, 2S Zitterbewegung state - "Shell of Charge" Distribution with radius = λe/2          - Predicted shifts are too large - Darwin term? *)

(* "Shell of Charge" Distribution, radius = λe/2 *)
Clear[a0, μ,R00,hbar,mr, re, c];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0/Z;
rZScale = 0.38126;  (* scale factor needed to match experiment with this choice of amplitude distribution (ring of charge) *)
rZScale = 1;
rZval = (hbarval/(2 mval cval ))*rZScale;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*",rZScale," = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];


VCompositeZitter[r_]:= -((Z α c hbar)/( Max[r,rZ] ));
Vmod1[r_]:= VCompositeZitter[r]+((Z α c hbar)/( r ));
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = - mr (c^2)((((Z α))^2)/2);
E2 = (E1/4);

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
Print["E1 = ",E1];deltaE1 = Simplify[Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ];
Print["deltaE1 = ",deltaE1];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ ]];

Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N)," GHz          target is ",GroundStateShiftHz/10^9," GHz"];
deltaE2 = Simplify[Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]/.hbar-> a0 α mr c /.a0->μr rZ]; 
Print["deltaE2 = ",deltaE2];

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval/.Z->1/.α->alpha/.c->cval)/10^9//N," GHz          target is ",LambShiftHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Df = -εgeneral (( ((μr)^2))/( (Z^2)));
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-εgeneral,"                   εgeneral = ",εgeneral]; 
Print["Distribution Factor Df = ",Df,"            target Df = 26 α =  ",26 alpha]; 
plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval,
VCompositeZitter[r]/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.Z->1/.α->alpha/.c->cval/.r->Abs[rr]},{rr,-.010 a0val,.010 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-4.0*10^-15,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue}];
Show[GraphicsRow[{plot1b}]]

HDarwin2S =  ((m (c^2) (((Z α ))^4))/(h 2 (n^3)))/.n->2/.c->cval/.Z->1/.α->alpha;
HDarwin2SeV = HDarwin2S h / e;
Print["HDarwin2S = ",HDarwin2S/10^9," GHz = ",HDarwin2SeV," eV"];

(* Bethe's expression for Lamb Shift in Hz *)
LambShiftBetheHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))Log[ (( mr (c^2) )/(17.8(-(Subscript[E, 0])) )) ] /.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheOriginalLog = Log[ (( mr (c^2) )/(17.8(-(Subscript[E, 0])) )) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheCutoff = Log[ (( mr (c^2) )/((-(Subscript[E, 0])) )) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
BetheLogarithm2S = Log[ 17.8 ];
Print["BetheOriginalLog           = Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(17.8\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]                                  = ",BetheOriginalLog];
Print["BetheCutoff                = Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]                                      = ",BetheCutoff];
Print["BetheLogarithm2S           = Log[17.8]                                        = ",BetheLogarithm2S];Print["LambShiftBetheHz           = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)Log[ \!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(17.8\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\) ]                = ",LambShiftBetheHz/10^9," GHz"];
LambShiftFrenchWeisskopfHz=(( 8 )/(3π ))(( (-(Subscript[E, 0])) )/(h ))(( (Z^2)(α^3) )/((n^3) ))(Log[ (( mr (c^2) )/(16.64(-(Subscript[E, 0])) )) ]-Log[2]+(( 5 )/6) -(( 1 )/5))/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2;
Print["LambShiftFrenchWeisskopfHz = \!\(\*FractionBox[\(\(\\ \)\(8\)\(\\ \)\), \(\(3\)  \(π\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[\(\(\\ \)\(\*SuperscriptBox[\(Z\), \(2\)] \*SuperscriptBox[\(α\), \(3\)]\(\\ \)\)\), \(\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)(Log[\!\(\*FractionBox[\(\(\\ \)\(\(mr\)\(\\ \)\*SuperscriptBox[\(c\), \(2\)]\(\\ \)\)\), \(\(16.64\) \((\(-\*SubscriptBox[\(E\), \(0\)]\))\)\(\\ \)\)]\)]-Log[2]+\!\(\*FractionBox[\(\(\\ \)\(5\)\(\\ \)\), \(6\)]\)-\!\(\*FractionBox[\(\(\\ \)\(1\)\(\\ \)\), \(5\)]\)) = ",LambShiftFrenchWeisskopfHz/10^9," GHz"];

(* French and Weisskopf expression for Lamb Shift in Hz *)

(Log[ m  (c^2) ]- Log[17.8 (-(Subscript[E, 0]))] )/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2
Log[17.8]
Log[(( m  (c^2) )/((-(Subscript[E, 0])) ))]/. c->cval
(Log[(( m  (c^2) )/((-(Subscript[E, 0])) ))]-Log[17.8])/. c->cval
2 Log [1/α]/.α->alpha
Log[ 2/ (α^2) ]/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval
19/30//N
(2 Log [1/α]-(Log[ m  (c^2) ]- Log[17.8 (-(Subscript[E, 0]))] )+19/30)/.α->alpha/.mr->mrval/.hbar->hbarval /. c->cval/.Z->1/.n->2

Log[2]//N
19/30//N
-Log[2]+19/30//N

Log[2]//N

Log[(( m  (c^2) )/((-(Subscript[E, 0])) ))]/. c->cval
2 Log [1/α]/.α->alpha
5/6//N
19/30//N
(2 Log [1/α]+19/30//N)/.α->alpha

((( (e^2) )/(4 π (Subscript[ϵ, 0])hbar c )))/.hbar->hbarval /. c->cval
alpha

(Sqrt[(8/(39 (alpha^3)))])

(* find empirical electron radius that agrees with target for ground state *)
(* using non-relativistic units *)
Clear[a0, μ,R00,hbar,mr, re];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0;
rZval = (hbarval/(2 mval cval ))*.380496;           (* Zitterbewegung helix radius, from Hestenes -- had to modify it to get approximate fit to target data *)
Print["rZ = \!\(\*FractionBox[\(hbar\), \(2\\ m\\ c\)]\)*.380496 = ",rZval,"m "];
μrval= (a0val/rZval);
Print["μr = (a0/rZ) = ",μrval];


VCompositeZitter[r_]:= -((hbar^2)/(mr a0 Max[r,rZ] ));
Vmod1[r_]:= VCompositeZitter[r]-V0[r];
Print["V[r] = ",VCompositeZitter[r]];
Print["dV[r] = ",Vmod1[r]];
E1 = -((hbar^2)/(2mr (a0^2)));
E2 = -((hbar^2)/(8mr (a0^2)));

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
deltaE1 = Integrate[ Vmod1[r] (((RSchrodingerS[1, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ,μr},Reals],a0>0,rZ>0,μr>0}];
ε1perturb1 = Expand[Simplify[deltaE1/E1/.a0->μr rZ]];

Print["ΔE1S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε1perturb1,")                     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",
((E1/h ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval)/10^9//N)," GHz          target is ",GroundStateShiftHz/10^9," GHz"];

deltaE2 = Integrate[ Vmod1[r](((RSchrodingerS[2, r]))^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,rZ},Reals],a0>0,rZ>0,μr>0}]; 

ε2perturb1 = Expand[Simplify[deltaE2/E2/.a0->μr rZ]];
Print["ΔE2S = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\) (",ε2perturb1,")     =  \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(3\)]\(\\ \)\)]\)",-2 Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr,"       = ",(E2/h ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval)/10^9//N," GHz          target is ",LambShiftHz/10^9," GHz"]; 
εgeneral = Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr; 
Print["ΔE = \!\(\*FractionBox[\(m\\ \*SuperscriptBox[\(c\), \(2\)]\), \(\(h\)\(\\ \)\)]\)\!\(\*FractionBox[SuperscriptBox[\((Z\\ α)\), \(2\)], \(\(2\)\(\\ \)\*SuperscriptBox[\(n\), \(2\)]\(\\ \)\)]\)",-εgeneral,"               εgeneral = ",εgeneral]; 

plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval,
VCompositeZitter[r]/.rZ->rZval/.hbar->hbarval/.a0->a0val/.mr->mrval/.r->Abs[rr]},{rr,-.010 a0val,.010 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-4.0*10^-15,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue}];
Show[GraphicsRow[{plot1b}]]

Print["ε1perturb1 = (",ε1perturb1,")                     = ",
(( ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.rZ->rZval/.μr ->μrval)//N)];
ε1perturb1/.μr->1/μrinv
-Normal[Series[ε1perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr
ε2perturb1/.μr->1/μrinv
-2Normal[Series[ε2perturb1/.μr->1/μrinv,{μrinv,0,2}]]/.μrinv->1/μr

GroupKeepAll[ε1perturb1,(E^(-2/μr))]
ε2perturb1
GroupKeepAll[ε2perturb1,(E^(-1/μr))]

(* Modified Potential for 1S Zitterbewegung state - "Shell of Charge" derivation *)

(* Derive modified Coulomb potential for Zitterbewegung *)
Clear[rB,rA,rZ,r];
Fr1SZitter=((q^2)/(8 π epsilon0 ))Integrate[(((rA-rZ Cos[θ])Sin[θ])/((((rA^2) -2rA rZ  Cos[θ] + (rZ^2)))^(3/2))),{θ,0,Pi},Assumptions->{Element[{rA,rZ},Reals],rA>0,rZ>0,rA≠rZ}]
Vr1SZitter = Integrate[Fr1SZitter,{rA,Infinity,r},Assumptions->{Element[{rA,rZ,r},Reals],rA>0,rZ>0,r>0,rA≠rZ}]

rZval = (hbarval/(2 mval cval ));           (* Zitterbewegung helix radius, from Hestenes *)
Print["rZval = ",rZval];

plot1a=Plot[Fr1SZitter/.rZ->rZval/.epsilon0->(Subscript[ϵ, 0])/.q->e/.rA->Abs[r],{r,-.025 a0val,.025 a0val},Frame->True,AspectRatio->0.8,PlotRange->{-.0002,.0065}];
plot1b = Plot[{V0[Abs[rr]]/.hbar->hbarval/.a0->a0val/.mr->mrval,
Vr1SZitter/.rZ->rZval/.epsilon0->(Subscript[ϵ, 0])/.q->e/.r->Abs[rr]},{rr,-.025 a0val,.025 a0val},Frame->True,AspectRatio->0.8,PlotPoints->1000,PlotRange->{-1.5*10^-15,0},PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue}];
Show[GraphicsRow[{plot1a,plot1b}]]

(* First-order perturbation analysis for 1S self-energy state (second guess: empirical electron radius -- YES, THIS WORKS) *)

(* find empirical electron radius that agrees with target for ground state *)
Clear[a0, μ,R00,hbar,mr, re];
RSchrodingerS[n_, r_]:= ψSchrodingerRadial[{n, 0, 0}, r, 0,0]/.(Subscript[a, 0])->a0;
μrval = 1247.8963;
reval = a0val/μrval;
re = a0/μr;
Vmod1[r_]:= ((hbar^2)/(mr a0 r))(Exp[((-2 r)/re)](1+r/re));
VComposite[r_]:=-((hbar^2)/(mr a0 r))(1-Exp[((-2 r)/re)](1+r/re));
E1 = -((hbar^2)/(2mr (a0^2)));
E2 = -((hbar^2)/(8mr (a0^2)));

ε1target = -2.5635*10^-6;
ε2target=-1.2868805350711774`*^-6;
deltaE1 = Integrate[ Vmod1[r]((RSchrodingerS[1, r])^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,re,μr},Reals],a0>0,re>0,μr>0}];
ε1perturb1 = deltaE1/E1;
Print["ε1perturb1 = ",ε1perturb1," = ",InputForm[(ε1perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.re->reval/.μr->μrval)//N]];
deltaE2 = Integrate[ Vmod1[r]((RSchrodingerS[2, r])^2) (r^2) ,{r,0,Infinity},Assumptions->{Element[{a0,re},Reals],a0>0,re>0,μr>0}];
ε2perturb1 = deltaE2/E2;
Print["ε2perturb1 = ",ε2perturb1," = ",InputForm[(ε2perturb1/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.re->reval/.μr->μrval)//N]];

Plot[{V0[Abs[r]]/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.re->reval/.μr->μrval,
VComposite[Abs[r]]/.mr->mrval/.hbar->hbarval/.R00->R00val/.a0->a0val/.re->reval/.μr->μrval
},{r,-9reval,9reval},Frame->True,AspectRatio->0.8,PlotStyle->{{Darker[Green],Dashing[{Tiny,Tiny}]},Blue,Purple},PlotPoints->300,PlotRange->{-6*10^-15,1*10^-15}]

(Sqrt[(8/(13 (alpha^3)))])

a0val/μrval