m[x_,a_]={{x, 1/x,0,0,0,0},
{-x,1/x,0,0,0,0},
{-1/x,-x,x,1/x,0,0},
{1/x,-x,-x,1/x,0,0}+a/2/Log[x]{1/x,x,x,1/x,0,0},
{0,0,-1/x,-x,x,1/x},
{0,0,1/x,-x,-x,1/x}+a/2/Log[x]{0,0,1/x,x,x,1/x}}

f[x_,a_]=Last[Inverse[m[x,a]].{1,1-a/Log[x],0,0,0,0}]

Show[
Plot[f[x,4],{x,6,9}],
Plot[f[x,2],{x,1.5,3.5}],
Plot[f[x,3/2],{x,1.0001,3.5}],
Plot[f[x,1],{x,1.3,2.3}],
Plot[f[x,1/2],{x,1.0001,1.7}],
Plot[f[x,.4],{x,1.1,1.7}] ]

Show[
Plot[f[x,4],{x,6,9}],
Plot[f[x,2.5],{x,2.5,4.5}],
Plot[f[x,3/2],{x,1.0001,2.8}],
Plot[f[x,1],{x,1.3,2.2}],
Plot[f[x,1/2],{x,1.0001,1.8}] ]

Eigensystem[{{(1+e)/x^2,e},{-e,x^2(1-e)}}]
{{(1 + e + x^4 - e*x^4 - Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/
     (2*x^2), (1 + e + x^4 - e*x^4 + 
       Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/(2*x^2)}, 
   {{(-1 + x^4 - e*(1 + x^4) + Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/
      (2*e*x^2), 1}, {-(1 + e - x^4 + e*x^4 + 
         Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/(2*e*x^2), 1}}}

l1=(1 + e + x^4 - e*x^4 - Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/(2*x^2)
l2=(1 + e + x^4 - e*x^4 +  Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/(2*x^2)

v1={(-1 + x^4 - e*(1 + x^4) + Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/
      (2*e*x^2), 1}

v2={-(1 + e - x^4 + e*x^4 + 
         Sqrt[-4*x^4 + (1 + x^4 - e*(-1 + x^4))^2])/(2*e*x^2), 1}

Solve[{0,1}==a v1+b v2,{a,b}]

a l1^n v1 + b l2^n v2 /. First[%]

d[x_,a_,n_]= % /. e-> a/(2 Log[x])

Show[
Plot[Last[d[x,4,3]],{x,6,9}],
Plot[Last[d[x,2.5,3]],{x,2.5,4.5}],
Plot[Last[d[x,3/2,3]],{x,1.0001,2.8}],
Plot[Last[d[x,1,3]],{x,1.3,2.2}],
Plot[Last[d[x,1/2,3]],{x,1.0001,1.8}] ]

Plot[Last[d[7,a,3]],{a,3,5}]

xspace=(10.)^(.025)

xv=Table[xspace^i,{i,40}]
xv[[23]]=3.75837
xv[[25]]=4.21697
xv[[27]]=4.7
xv[[40]]=10.1


e1=Table[{0,0},{i,40}]
e2=Table[{0,0},{i,40}]
e3=Table[{0,0},{i,40}]
e4=Table[{0,0},{i,40}]
e5=Table[{0,0},{i,40}]
e6=Table[{0,0},{i,40}]
e7=Table[{0,0},{i,40}]
e8=Table[{0,0},{i,40}]


Do[
atemp= Re[a] /. Solve[Last[d[xv[[i]],a,3]]==0,{a}];
atemp2=Sort[Union[atemp]];
e1[[i]]={1/atemp2[[1]],-(1/2)(2 Log[xv[[i]]]/atemp2[[1]])^2};
e2[[i]]={1/atemp2[[2]],-(1/2)(2 Log[xv[[i]]]/atemp2[[2]])^2};
e3[[i]]={1/atemp2[[3]],-(1/2)(2 Log[xv[[i]]]/atemp2[[3]])^2};
Print[i," ",atemp2],{i,40,23,-1}]

Show[
ListPlot[e1,PlotJoined->True],
ListPlot[e2,PlotJoined->True],
ListPlot[e3,PlotJoined->True]]

xv[[15]]=2.37137
xv[[21]]=3.34965
xv[[33]]=6.68344

Do[
atemp= Re[a] /. Solve[Last[d[xv[[i]],a,4]]==0,{a}];
atemp2=Sort[Union[atemp]];
e1[[i]]={1/atemp2[[1]],-(1/2)(2 Log[xv[[i]]]/atemp2[[1]])^2};
e2[[i]]={1/atemp2[[2]],-(1/2)(2 Log[xv[[i]]]/atemp2[[2]])^2};
e3[[i]]={1/atemp2[[3]],-(1/2)(2 Log[xv[[i]]]/atemp2[[3]])^2};
e4[[i]]={1/atemp2[[4]],-(1/2)(2 Log[xv[[i]]]/atemp2[[4]])^2};
Print[i," ",atemp2],{i,33,40}]

Show[
ListPlot[e1,PlotJoined->True],
ListPlot[e2,PlotJoined->True],
ListPlot[e3,PlotJoined->True],
ListPlot[e4,PlotJoined->True]]


Do[
atemp= Re[a] /. Solve[Last[d[xv[[i]],a,8]]==0,{a}];
atemp2=Sort[Union[atemp]];
e1[[i]]={1/atemp2[[1]],-(1/2)(2 Log[xv[[i]]]/atemp2[[1]])^2};
e2[[i]]={1/atemp2[[2]],-(1/2)(2 Log[xv[[i]]]/atemp2[[2]])^2};
e3[[i]]={1/atemp2[[3]],-(1/2)(2 Log[xv[[i]]]/atemp2[[3]])^2};
e4[[i]]={1/atemp2[[4]],-(1/2)(2 Log[xv[[i]]]/atemp2[[4]])^2};
e5[[i]]={1/atemp2[[5]],-(1/2)(2 Log[xv[[i]]]/atemp2[[5]])^2};
e6[[i]]={1/atemp2[[6]],-(1/2)(2 Log[xv[[i]]]/atemp2[[6]])^2};
e7[[i]]={1/atemp2[[7]],-(1/2)(2 Log[xv[[i]]]/atemp2[[7]])^2};
e8[[i]]={1/atemp2[[8]],-(1/2)(2 Log[xv[[i]]]/atemp2[[8]])^2};
Print[i," ",atemp2],{i,40}]

%%--Problems:i=8,11,15,16,17,22,25-28,30,36,37
xv[[2]]=1.12
xv[[5]]=1.33
xv[[8]]=1.58
xv[[11]]=1.88
xv[[15]]=2.37
xv[[16]]=2.6
xv[[17]]=2.7
xv[[22]]=3.55
xv[[25]]=4.2
xv[[26]]=4.47
xv[[27]]=4.77
xv[[28]]=5.01
xv[[30]]=5.6
xv[[36]]=8.05
xv[[37]]=8.45

Show[
ListPlot[e1,PlotJoined->True],
ListPlot[e2,PlotJoined->True],
ListPlot[e3,PlotJoined->True],
ListPlot[e4,PlotJoined->True],
ListPlot[e5,PlotJoined->True],
ListPlot[e6,PlotJoined->True],
ListPlot[e7,PlotJoined->True],
ListPlot[e8,PlotJoined->True]]

Plot[Last[d[x,4,8]],{x,6.7,8}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,6.83}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,6.94}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,7.1}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,7.29}]
k5=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,7.47}]
k6=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,7.65}]
k7=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,7.77}]
k8=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,7.86}]

x1=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,6.83}]
x2=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,6.94}]
x3=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,7.1}]
x4=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,7.29}]
x5=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,7.47}]
x6=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,7.65}]
x7=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,7.77}]
x8=Re[x] /. FindRoot[Last[d[x,4,8]]==0,{x,7.86}]

roots:
Out[497]= 6.82621
Out[498]= 6.93636
Out[499]= 7.09787
Out[500]= 7.28556
Out[501]= 7.4745
Out[502]= 7.64332
Out[503]= 7.77544
Out[504]= 7.85927

ks:
Out[505]= 0.960385
Out[506]= 0.968389
Out[507]= 0.979898
Out[508]= 0.992947
Out[509]= 1.00575
Out[510]= 1.01692
Out[511]= 1.02549
Out[512]= 1.03085

psi[x_,k_,a_,n_]:=(If[x<0,Return[Exp[k(x+a/2)]]];itemp=Min[n-1,IntegerPart[x/a]]+1;
vtemp=d[Exp[k a/2],a,itemp];
Return[vtemp[[1]] Exp[-k(x-(itemp-1/2) a)]+vtemp[[2]] Exp[+k(x-(itemp-1/2) a)] ] )

ListPlot[Table[{4 i,0},{i,0,7}],PlotStyle->{RGBColor[1,0,0]}]
Plot[psi[x,k8,4,8],{x,-4,32}]
Show[%,%%]

etc

n0=1/Sqrt[NIntegrate[psi[x,k8,4,8]^2,{x,-4,32}]]
n1=1/Sqrt[NIntegrate[psi[x,k7,4,8]^2,{x,-4,32}]]
n2=1/Sqrt[NIntegrate[psi[x,k6,4,8]^2,{x,-4,32}]]
n3=1/Sqrt[NIntegrate[psi[x,k5,4,8]^2,{x,-4,32}]]
n4=1/Sqrt[NIntegrate[psi[x,k4,4,8]^2,{x,-4,32}]]
n5=1/Sqrt[NIntegrate[psi[x,k3,4,8]^2,{x,-4,32}]]
n6=1/Sqrt[NIntegrate[psi[x,k2,4,8]^2,{x,-4,32}]]
n7=1/Sqrt[NIntegrate[psi[x,k1,4,8]^2,{x,-4,32}]]

test[x_]=Exp[-Abs[x]]

a0=NIntegrate[psi[x,k8,4,8] test[x],{x,-8,8}]
a1=NIntegrate[psi[x,k7,4,8] test[x],{x,-8,8}]
a2=NIntegrate[psi[x,k6,4,8] test[x],{x,-8,8}]
a3=NIntegrate[psi[x,k5,4,8] test[x],{x,-8,8}]
a4=NIntegrate[psi[x,k4,4,8] test[x],{x,-8,8}]
a5=NIntegrate[psi[x,k3,4,8] test[x],{x,-8,8}]
a6=NIntegrate[psi[x,k2,4,8] test[x],{x,-8,8}]
a7=NIntegrate[psi[x,k1,4,8] test[x],{x,-8,8}]

Plot[a0 psi[x,k8,4,8] n0^2+
a1 psi[x,k7,4,8] n1^2+
a2 psi[x,k6,4,8] n2^2+
a3 psi[x,k5,4,8] n3^2+
a4 psi[x,k4,4,8] n4^2+
a5 psi[x,k3,4,8] n5^2+
a6 psi[x,k2,4,8] n6^2+
a7 psi[x,k1,4,8] n7^2,{x,-4,32}]


psit[x_,t_]:=Abs[a0 psi[x,k8,4,8] n0^2 Exp[-I (1/2)(k8^2-k1^2) t]+
a1 psi[x,k7,4,8] n1^2 Exp[-I (1/2)(k7^2-k1^2) t]+
a2 psi[x,k6,4,8] n2^2 Exp[-I (1/2)(k6^2-k1^2) t]+
a3 psi[x,k5,4,8] n3^2 Exp[-I (1/2)(k5^2-k1^2) t]+
a4 psi[x,k4,4,8] n4^2 Exp[-I (1/2)(k4^2-k1^2) t]+
a5 psi[x,k3,4,8] n5^2 Exp[-I (1/2)(k3^2-k1^2) t]+
a6 psi[x,k2,4,8] n6^2 Exp[-I (1/2)(k2^2-k1^2) t]+
a7 psi[x,k1,4,8] n7^2 ]^2
-(1/2)(k8^2*a0^2+k7^2*a1^2+k6^2*a2^2+k5^2*a3^2+k4^2*a4^2+k3^2*a5^2+k2^2*a6^2+k1^2*a7^2)/
(a0^2+a1^2+a2^2+a3^2+a4^2+a5^2+a6^2+a7^2)
-0.504364

Plot[{-(1/2)k8^2,-(1/2)k7^2,-(1/2)k6^2,-(1/2)k5^2,-(1/2)k4^2,-(1/2)k3^2,-(1/2)k2^2,
-(1/2)k1^2},{x,.15,.45},PlotRange->{{0,2},{-.55,-.44}},Axes->{False,True}]



Plot[Last[d[x,4,16]],{x,6.7,8}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,6.8}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,6.83}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,6.88}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,6.95}]
k5=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.04}]
k6=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.13}]
k7=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.22}]
k8=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.33}]
k9=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.43}]
k10=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.53}]
k11=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.61}]
k12=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.7}]
k13=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.76}]
k14=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.82}]
k15=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.85}]
k16=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,16]]==0,{x,7.88}]

Out[615]= 0.958319
Out[616]= 0.960713
Out[617]= 0.964534
Out[618]= 0.969555
Out[619]= 0.975501
Out[620]= 0.982077
Out[621]= 0.988989
Out[622]= 0.995968
Out[623]= 1.00277
Out[624]= 1.00919
Out[625]= 1.01506
Out[626]= 1.02024
Out[627]= 1.02461
Out[628]= 1.02809
Out[629]= 1.03062
Out[630]= 1.03215

Plot[{-(1/2)k16^2,-(1/2)k15^2,-(1/2)k14^2,-(1/2)k13^2,-(1/2)k12^2,-(1/2)k11^2,-(1/2)k10^2,
-(1/2)k9^2,-(1/2)k8^2,-(1/2)k7^2,-(1/2)k6^2,-(1/2)k5^2,-(1/2)k4^2,-(1/2)k3^2,-(1/2)k2^2,
-(1/2)k1^2},{x,.15,.45},PlotRange->{{0,2},{-.55,-.44}},Axes->{False,True}]

---



Plot[Last[d[x,4,32]],{x,6.7,8},PlotRange->{-6,6}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.79}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.8}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.812}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.833}]
k5=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.858}]
k6=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.89}]
k7=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.92}]
k8=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,6.97}]
k9=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.0}]
k10=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.05}]
k11=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.1}]
k12=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.15}]
k13=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.2}]
k14=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.24}]
k15=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.3}]
k16=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.35}]
k17=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.4}]
k18=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.45}]
k19=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.5}]
k20=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.55}]
k21=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.6}]
k22=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.64}]
k23=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.68}]
k24=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.72}]
k25=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.75}]
k26=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.78}]
k27=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.81}]
k28=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.835}]
k29=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.85}]
k30=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.87}]
k31=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.88}]
k32=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,32]]==0,{x,7.89}]

Out[646]= 0.957721
Out[647]= 0.958367
Out[648]= 0.959432
Out[649]= 0.960898
Out[650]= 0.96274
Out[651]= 0.964929
Out[652]= 0.96743
Out[653]= 0.970208
Out[654]= 0.973222
Out[655]= 0.976432
Out[656]= 0.979798
Out[657]= 0.983279
Out[658]= 0.986837
Out[659]= 0.990433
Out[660]= 0.994033
Out[661]= 0.997603
Out[662]= 1.00111
Out[663]= 1.00453
Out[664]= 1.00784
Out[665]= 1.01101
Out[666]= 1.01402
Out[667]= 1.01685
Out[668]= 1.01948
Out[669]= 1.02191
Out[670]= 1.02411
Out[671]= 1.02608
Out[672]= 1.0278
Out[673]= 1.02928
Out[674]= 1.03049
Out[675]= 1.03144
Out[676]= 1.03212
Out[677]= 1.03253


Plot[{-(1/2)k32^2,-(1/2)k31^2,-(1/2)k30^2,-(1/2)k29^2,-(1/2)k28^2,-(1/2)k27^2,-(1/2)k26^2,
-(1/2)k25^2,-(1/2)k24^2,-(1/2)k23^2,-(1/2)k22^2,-(1/2)k21^2,-(1/2)k20^2,-(1/2)k19^2,
-(1/2)k18^2,-(1/2)k17^2,
-(1/2)k16^2,-(1/2)k15^2,-(1/2)k14^2,-(1/2)k13^2,-(1/2)k12^2,-(1/2)k11^2,-(1/2)k10^2,
-(1/2)k9^2,-(1/2)k8^2,-(1/2)k7^2,-(1/2)k6^2,-(1/2)k5^2,-(1/2)k4^2,-(1/2)k3^2,-(1/2)k2^2,
-(1/2)k1^2},{x,.15,.45},PlotRange->{{0,2},{-.55,-.44}},Axes->{False,True}]

---
Plot[y(Tanh[y]+1),{y,0,2}]
Plot[y(Coth[y]+1),{y,0,2},PlotRange->{0,4.2}]

Do[
atemp= Re[a] /. Solve[Last[d[xv[[i]],a,2]]==0,{a}];
atemp2=Sort[Union[atemp]];
e1[[i]]={1/atemp2[[1]],-(1/2)(2 Log[xv[[i]]]/atemp2[[1]])^2};
e2[[i]]={1/atemp2[[2]],-(1/2)(2 Log[xv[[i]]]/atemp2[[2]])^2};
Print[i," ",atemp2],{i,40}]

problems at i=38,27

Plot[Last[d[x,4,2]],{x,6.7,8},PlotRange->{-6,6}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,2]]==0,{x,7.1}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,2]]==0,{x,7.65}]

psi[x_,k_,a_,n_]:=(If[x<0,Return[Exp[k(x+a/2)]]];itemp=Min[n-1,IntegerPart[x/a]]+1;
vtemp=d[Exp[k a/2],a,itemp];
Return[vtemp[[1]] Exp[-k(x-(itemp-1/2) a)]+vtemp[[2]] Exp[+k(x-(itemp-1/2) a)] ] )

Plot[psi[x+2,k1,4,2],{x,-7,7}]
Plot[psi[x+2,k2,4,2],{x,-7,7}]

---

Do[
e3[[i]]={1/e1[[i]][[1]],e1[[i]][[2]]+.25 e1[[i]][[1]]};
e4[[i]]={1/e2[[i]][[1]],e2[[i]][[2]]+.25 e2[[i]][[1]]},{i,40}]

ListPlot[e3,PlotJoined->True]
ListPlot[e4,PlotJoined->True]
Show[%,%%,PlotRange->{-.6,-.3}]

--

-(1.00111^2+1.00453^2+1.0078462+1.01101^2+1.01402^2+1.01685^2+1.01948^2+1.02191^2+
1.02411^2+1.02608^2+1.0278^2+1.02928^2+1.03049^2+1.03144^2+1.03212^2+1.03253^2)/2/16

-(1.00277^2+1.00919^2+1.01506^2+1.02024^2+1.02461^2+1.02809^2+1.03062^2+1.03215^2)/2/8
0.520597

-(1.00575^2+1.01692^2+1.02549^2+1.03085^2)/2/4
-0.519993

Plot[Last[d[x,4,2]],{x,6.7,8},PlotRange->{-6,6}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,2]]==0,{x,7.1}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,2]]==0,{x,7.6}]

-(1.0171^2)/2
-0.517246

Plot[Last[d[x,4,4]],{x,6.7,8},PlotRange->{-6,6}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,6.9}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,7.2}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,7.5}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,7.8}]

-( 1.01057^2+1.02686^2)/2/2


Plot[Last[d[x,4,3]],{x,6.7,8},PlotRange->{-6,6}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,7.0}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,7.4}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,4]]==0,{x,7.75}]
Out[739]= 0.966505
Out[740]= 0.987787
Out[741]= 1.02686
-(1.02686^2+1.02686^2+0.987787^2)/2/3

Plot[Last[d[x,4,5]],{x,6.7,8},PlotRange->{-6,6}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,5]]==0,{x,6.9}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,5]]==0,{x,7.1}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,5]]==0,{x,7.4}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,5]]==0,{x,7.65}]
k5=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,5]]==0,{x,7.8}]

-(2*1.02861^2+2*1.01696^2+0.999551^2)/2/5

Plot[Last[d[x,4,7]],{x,6.7,8},PlotRange->{-6,6}]
k0=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,7]]==0,{x,6.85}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,7]]==0,{x,7.2}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,7]]==0,{x,7.4}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,7]]==0,{x,7.6}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,7]]==0,{x,7.75}]
k5=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,7]]==0,{x,7.85}]

-(2*1.03037^2+2*1.02363^2+2*1.013^2+0.999495^2)/2/7
-0.519306

Plot[Last[d[x,4,6]],{x,6.7,8},PlotRange->{-6,6}]
k0=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,6]]==0,{x,6.85}]
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,6]]==0,{x,7.05}]
k2=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,6]]==0,{x,7.25}]
k3=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,6]]==0,{x,7.5}]
k4=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,6]]==0,{x,7.7}]
k5=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,6]]==0,{x,7.85}]

-(1.00751^2+1.02097^2+1.02967^2)/2/3
-0.519613


{{1,-.5},{2,-0.517246},{3,-0.514101},{4,-0.518923},{5,-0.518359},{8,-0.519993},{16,-0.520597},{32,-0.52068}}



---

m={{(1+1/k)/x^2,1/k},{-1/k,x^2(1-1/k)}}
{{l1,l2},{v1,v2}}=Eigensystem[m]
Solve[{0,1}==a v1+b v2,{a,b}]
a l1^n v1 + b l2^n v2 /. First[%]
d[x_,a_,n_]= % /. k-> (2 Log[x])/a
k1=Log[Re[x]](2/4) /. FindRoot[Last[d[x,4,8]]==0,{x,6.83}]
psi[x_,k_,a_,n_]:=(If[x<0,Return[Exp[k(x+a/2)]]];itemp=Min[n-1,IntegerPart[x/a]]+1;
vtemp=d[Exp[k a/2],a,itemp];
Return[vtemp[[1]] Exp[-k(x-(itemp-1/2) a)]+vtemp[[2]] Exp[+k(x-(itemp-1/2) a)] ] )
Plot[psi[x,k1,4,8],{x,-4,32}]

Together[b v2] /. First[%779]
Together[a v1] /. First[%779]
---
ft[k_,a_]=Cosh[k a]-(1/k)Sinh[k a]

Plot[{ft[k,4],ft[k,2],ft[k,.5],1,-1},{k,0,2.5},PlotRange->{-4,4},
PlotStyle->{{RGBColor[0,0,1]},{RGBColor[0,1,0]},{RGBColor[1,0,0]},{RGBColor[0,0,0]},{RGBColor[0,0,0]}}]
k1=k /. FindRoot[ft[k,4]==1,{k,1}]
k2=k /. FindRoot[ft[k,4]==-1,{k,1}]
ParametricPlot[{Re[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]]/4,-(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]

k1=k /. FindRoot[ft[k,3]==1,{k,1}]
k2=k /. FindRoot[ft[k,3]==-1,{k,1}]
ParametricPlot[{Re[ArcTan[ft[k,3],Sqrt[1-ft[k,3]^2]]]/3,-(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[1,0,0]}}]
Show[%824,%829,PlotRange->{-.6,-.35}]

ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==Pi/4,{k,1}]

vtempb[k_,a_]=v2 /. x->Exp[k a/2]
ltempb[k_,a_]=l2 /. x->Exp[k a/2]
psib[x_,k_,a_]:=(itemp=IntegerPart[x/a]+1;
Return[ltempb[k,a]^itemp(vtempb[k,a][[1]] Exp[-k(x-(itemp-1/2) a)]+vtempb[k,a][[2]] Exp[+k(x-(itemp-1/2) a)]) ] )
 Plot[Abs[psib[x,ktemp,4]]^2,{x,0,8}]
ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==0,{k,1}]
 Plot[Abs[psib[x,ktemp,4]/psib[0,ktemp,4]]^2,{x,0,8},PlotStyle->{RGBColor[1,0,0]}]
ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==Pi/4,{k,1}]
 Plot[Abs[psib[x,ktemp,4]/psib[0,ktemp,4]]^2,{x,0,8},PlotStyle->{RGBColor[0,1,0]}]
ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==Pi/2,{k,1}]
 Plot[Abs[psib[x,ktemp,4]/psib[0,ktemp,4]]^2,{x,0,8},PlotStyle->{RGBColor[0,1,0]}]
ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==3 Pi/4,{k,1}]
 Plot[Abs[psib[x,ktemp,4]/psib[0,ktemp,4]]^2,{x,0,8},PlotStyle->{RGBColor[0,0,1]}]
ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==Pi,{k,1}]
 Plot[Abs[psib[x,ktemp,4]/psib[0,ktemp,4]]^2,{x,0,8},PlotStyle->{RGBColor[0,0,1]}]

ktemp=k /. FindRoot[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]==Pi/8,{k,1}]
Plot[Re[psib[x,ktemp,4]],{x,0,64}]
------
vel[k_]=-4 k/D[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]],k]
ParametricPlot[{-(1/2)k^2,vel[k]},{k,k1,k2}]
---
ftp[k_,a_]=Cos[k a]-(1/k)Sin[k a]

Plot[{ftp[k,4],ftp[k,2],ftp[k,.5],1,-1},{k,0,2 Pi},PlotRange->{-4,4},
PlotStyle->{{RGBColor[0,0,1]},{RGBColor[0,1,0]},{RGBColor[1,0,0]},{RGBColor[0,0,0]},{RGBColor[0,0,0]}}]
k1=k /. FindRoot[ftp[k,4]==1,{k,1}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,1}]
ParametricPlot[{Re[ArcTan[ftp[k,4],Sqrt[1-ftp[k,4]^2]]]/4,(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
k1=k /. FindRoot[ftp[k,4]==1,{k,1.6}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,2.2}]
ParametricPlot[{Re[ArcTan[ftp[k,4],Sqrt[1-ftp[k,4]^2]]]/4,(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
Show[%900,%883,%824]


vtempbp[k_,a_]=v2 /. {x->Exp[I k a/2], k->I k}
ltempbp[k_,a_]=l2 /. {x->Exp[I k a/2], k->I k}
psibp[x_,k_,a_]:=(itemp=IntegerPart[x/a]+1;
Return[ltempbp[k,a]^itemp(vtempbp[k,a][[1]] Exp[-I k(x-(itemp-1/2) a)]+vtempbp[k,a][[2]] Exp[+I k(x-(itemp-1/2) a)]) ] )
k1=k /. FindRoot[ftp[k,4]==1,{k,1}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,1}]
k3=k /. FindRoot[ftp[k,4]==0,{k,1}]
Plot[Abs[psibp[x,k3,4]]^2,{x,0,32}]
 Plot[{Abs[psibp[x,k2,4]/psibp[2,k2,4]]^2,Abs[psibp[x,k3,4]/psibp[2,k3,4]]^2,Abs[psibp[x,k1,4]/psibp[2,k1,4]]^2},{x,0,8},
PlotStyle->{{RGBColor[1,0,0]},{RGBColor[0,1,0]},{RGBColor[0,0,1]}}]

k2=k /. FindRoot[ftp[k,4]==1,{k,1.6}]
k1=k /. FindRoot[ftp[k,4]==-1,{k,2.2}]
k3=k /. FindRoot[ftp[k,4]==0,{k,2}]
Plot[Abs[psibp[x,k3,4]]^2,{x,0,32}]
n1=NIntegrate[Abs[psibp[x,k1,4]]^2,{x,0,4}]
n2=NIntegrate[Abs[psibp[x,k2,4]]^2,{x,0,4}]
n3=NIntegrate[Abs[psibp[x,k3,4]]^2,{x,0,4}]
 Plot[{Abs[psibp[x,k2,4]]^2/n2,Abs[psibp[x,k3,4]]^2/n3,Abs[psibp[x,k1,4]]^2/n1},{x,0,8},
PlotStyle->{{RGBColor[1,0,0]},{RGBColor[0,1,0]},{RGBColor[0,0,1]}}]


----
m={{(1-I/k)Exp[- I k a],-I/k},{I/k,(1+I/k)Exp[+ I k a]}}

{{l1,l2},{v1,v2}}=Eigensystem[m]

Solve[{1,0}==c v1+d v2,{c,d}]

c l1^n v1 + d l2^n v2 /. First[%]

ds[k_,a_,n_]= % 

ref[k_,a_,n_]=Abs[Last[ds[k,a,n]]/First[ds[k,a,n]]]^2

ParametricPlot[{.5 k^2, ref[k,4,32]},{k,0,3}]
ParametricPlot[{.5 k^2, ref[k,4,8]},{k,0,3}]
ParametricPlot[{.5 k^2, ref[k,4,2]},{k,0,3}]
k1=k /. FindRoot[ft[k,4]==1,{k,1}]
k2=k /. FindRoot[ft[k,4]==-1,{k,1}]
ParametricPlot[{Re[ArcTan[ft[k,4],Sqrt[1-ft[k,4]^2]]]/4,-(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
k1=k /. FindRoot[ftp[k,4]==1,{k,1}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,1}]
ParametricPlot[{Re[ArcTan[ftp[k,4],Sqrt[1-ftp[k,4]^2]]]/4,(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
k1=k /. FindRoot[ftp[k,4]==1,{k,1.6}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,2.2}]
ParametricPlot[{Re[ArcTan[ftp[k,4],Sqrt[1-ftp[k,4]^2]]]/4,(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
k1=k /. FindRoot[ftp[k,4]==1,{k,3}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,2.4}]
ParametricPlot[{Re[ArcTan[ftp[k,4],Sqrt[1-ftp[k,4]^2]]]/4,(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
k1=k /. FindRoot[ftp[k,4]==1,{k,3.1}]
k2=k /. FindRoot[ftp[k,4]==-1,{k,3.7}]
ParametricPlot[{Re[ArcTan[ftp[k,4],Sqrt[1-ftp[k,4]^2]]]/4,(1/2)k^2},{k,k1,k2},
PlotStyle->{{RGBColor[0,0,1]}}]
Show[%900,%883,%824,%1029,%1026,PlotRange->{-.6,8},AspectRatio->2/.92]
ParametricPlot[{ref[k,4,32],.5 k^2},{k,0,4}]
Show[%1031,PlotRange->{-.6,8},AspectRatio->2]
Show[GraphicsArray[{%1044,%1038}]]



