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}]]