DataMuseum.dk

top - metrics - download

    Length: 6144 (0x1800)
    Types: TextFile
    Names: »gotdosc«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦1248b0c55⟧ »gobib« 
            └─⟦this⟧ 

TextFile

;gosav
clear tdosc
r=edit algtdosc c.50
l1,d./)/,l./set/,r/6/7/,l1,
r/no/no/,l./Q2,Q4/,r/Q2,Q4,Q6,//,l2,r/nw/ni,nw/,r/v1/v0,v1/
l./array w/,r/10/16/,r/;/,ev0,px(1:N),x2(1:N,1:N),Qa,Qb(1:3,1:N);/,
l./H(1:N/,r/ev/
array ev/,l-1,d,g/m1:m2/1:N/
l3,g8/H(i,/x(i,i-/,l1,i/
   for j:=i-m-1 step -1 until 1 do x(i,j):= 0;
/,l-9,r/-0//,l2,i/
   if i>1 then
/,l3,i/
   if i>2 then
/,l2,r/>2/>2 and i>3/,l2,r/>3/>3 and i>4/,l./banddiag/,d,i/
tridql(N,ev,x);
/,l2,r/v/v0/,l2,r/5/2/,l5,r/v+/v0+/,l./Q4/,r/Q4:= //,i/
array Qp,Qv(1:3,1:N);
/,l2,r/Q2:= Q6:= //,l3,d,l1,d,l2,d1,l4,i?
   Qv(1,j):= u*p-sq1*q/2;
   Qv(2,j):= (u*u*3-t+1)/2*p+(-(u-1)*2*q+sq2*r)*sq1/2;
   Qv(3,j):= (u*u*5-3*t+7)*u/2*p+(-((u-2)*u*5-t+9)*0.75*q
             +((u-2)*3*r-sq3*s)*sq2)*sq1/2;
   if j>1 then begin s:= sq1*p;
   Qv(1,j-1):= Qv(1,j-1)-s;
   Qv(2,j-1):= Qv(2,j-1)-(u-1)*2*s;
   Qv(3,j-1):= Qv(3,j-1)-((u-2)*u*5-t+9)*0.75*s;
   if j>2 then begin s:= s*sq2;
   Qv(2,j-2):= Qv(2,j-2)+s;
   Qv(3,j-2):= Qv(3,j-2)+(u-2)*3*s;
   if j>3 then
   Qv(3,j-3):= Qv(3,j-3)-sq3*s;
   end end;
?,l./case/,r/1/5/,r/case j/case j-4/,i/
w(nw+i,1):= G*ev(i);
/,l2,r/P2/
   (P2/,l-1,d,l1,r/v+/v0+/,l1,i?
comment <v,l! Q**n !v',l> are formed in Qp and stored in Qa for
        v,l= 2,0 and 3,1 and in Qb for v,l= 2,2 and 3,3;
for u:=1,2,3 do for k:=1 step 1 until N do begin
   p:= Qp(u,k):= sum(Qv(u,j)*x(k,j),j,1,N);
   if i=2 and l<=1 or i=1 and 2<=l and l<=3 then
   begin if l<2 then Qa(u,k):= p else Qb(u,k):= p end;
end;
for u:=1,2,3 do w(nw+i,u+1):= Qp(u,i)*LS**u;
ni:= 10;
for u:=1,2,3 do for v:=u step 1 until 3 do begin
   ni:= ni+1; p:= 0;
   for k:=i-1 step -1 until 1,i+1 step 1 until N do
      p:= p + Qp(u,k)*Qp(v,k)/(ev(i)-ev(k));
   w(nw+i,ni):= p*LS**(u+v)/G
end;
?,l./end end;/,d,i?
end;
ni:= 10;
for u:=1,2,3 do for v:=u step 1 until 3 do begin
   ni:= ni+1; write(res,<<d>,nl,1,<:X:>,u+u,<:.X:>,v+v);
   for i:=k1 step 1 until k2 do 
      write(res,string lo,w(nw+i,ni));
end;
if 2<=l and l<=5 and k1=1 then begin
  array xx(1:3,1:N),f,ps(1:3),Qc,Qd,Qe(1:3,1:N),a(1:3,1:3);
  if l<=3 then
  write(res,nl,2,<:Couplings:>,if l=2 then <: !2,0> - !2,2>::>
     else <: !3,1> - !3,3>::>,nl,1,<:First order: X2,X4,X6 =:>);
  for j:=1 step 1 until N do begin
    for k:=1,2 do xx(k,j):= x2(k,j);
    xx(3,j):= x(1,j); end;
  ni:= if l<=3 then 3 else 1;
  for i:=1,2,3 do begin
    if i>1 then begin
    comment we form Q**2 !xx(k,j>;
    v:= l; sq1:= sqrt((v+l+2)*(v-l+2))/2;
    for k:=1 step 1 until ni do
      f(k):= (v+1)*xx(k,1)-sq1*xx(k,2);
    for j:=2 step 1 until N-1 do begin
      v:= v+2; sq2:= sq1;
      sq1:= sqrt((v+l+2)*(v-l+2))/2;
      for k:=1 step 1 until ni do begin
        q:= f(k);
        f(k):= (v+1)*xx(k,j)-sq2*xx(k,j-1)-sq1*xx(k,j+1);
        xx(k,j-1):= q;
    end end;
    for k:=1 step 1 until ni do begin
      xx(k,N):= (v+4)*xx(k,N)-sq1*xx(k,N-1);
      xx(k,N-1):= f(k);
    end end;
    comment we form
      Qc(n/2,j) = <v,2! Q**n !2,0> ,
      Qd(n/2,j) = <2,2! Q**n !v,0> with v<>2,
      Qe(n/2,j) = <v,2! Q**n !0,0> with v<>0,
      and write   <2,2! Q**n !2,0>  .
      Corresponding terms are evaluated for levels with l=1 and 3;
    if l<=3 then begin
    write(res,string lo,
          sum(xx(2,j)*x(1,j),j,1,N)*LS**i);
    ps(i):= sum(xx(3,j)*px(j),j,1,N);
    for v:=2 step 1 until N do
      Qc(i,v):= sum(x(v,j)*xx(2,j),j,1,N);
    for v:=1,3 step 1 until N do
      Qd(i,v):= sum(x2(v,j)*xx(3,j),j,1,N);
    end l<=3;
    for v:=1 step 1 until N do
      Qe(i,v):= sum(x(v,j)*xx(1,j),j,1,N);
  end i;
  if l<=3 then begin
  write(res,nl,1,sp,9,<:P2,P2X2,P2X4 =:>,
        string lo,ps(1)/LS,ps(2),ps(3)*LS);
  for u:=1,2,3 do for v:= 1,2,3 do begin
    p:= 0;
    for k:=1,3 step 1 until N do
      p:= p+Qa(u,k)*Qd(v,k)*(1/(ev0(2)-ev0(k))+1/(ev(1)-ev0(k)));
    for k:=2 step 1 until N do
      p:= p+Qb(u,k)*Qc(v,k)*(1/(ev0(2)-ev(k))+1/(ev(1)-ev(k)));
    a(u,v):= p/2*LS**(u+v)/G;
  end;
  write(res,<:
Second order: X2              X4              X6 (non-diagonal):>);
  for u:=1,2,3 do begin
    write(res,nl,1,<:    X:>,<<d>,u+u);
    for v:=1,2,3 do write(res,string lo,a(u,v));
  end;
  end l<=3;
  ni:= if l<=3 then 3 else 1;
  write(res,nl,2,<:Additional Pert. Sums:    :>);
  for k:=1 step 1 until ni do
    write(res,<<d>,<:!:>,l-(if k=1 then 2 else 0),<:,:>,
      l-(if k=3 then 0 else 2),<:>:>,sp,if k=ni then 0 else 11);
  for u:=1,2,3 do for v:=u step 1 until 3 do begin
    p:= q:= r:= 0; s:= LS**(u+v)/G;
    for j:=1 step 1 until N do
      p:= p+Qe(u,j)*Qe(v,j)/(ev0(1)-ev(j));
    write(res,nl,1,sp,13,<<d>,<:X:>,u+u,<:.X:>,v+v,
          string lo,p*s);
    if l<=3 then begin
      for j:=2 step 1 until N do
        q:= q+Qc(u,j)*Qc(v,j)/(ev0(2)-ev(j));
      for j:=1,3 step 1 until N do
        r:= r+Qd(u,j)*Qd(v,j)/(ev(1)-ev0(j));
      write(res,string lo,q*s,r*s);
  end end;
end 2<= l <=5;
if l<=3 and k1=1 then begin
  comment we form in x2(i,j) and px(j) the vectors
         !x2(i)> =   X**2*cos(2v) !x(i)> and
         ! px  > = 2*p**2*cos(2v) !x(1)>;
  k:= if l<=1 then N else 1;
  for i:=1 step 1 until k do begin ev0(i):= ev(i); v:= l;
  for j:=2 step 1 until N do begin
  v:= v+2;
  p:= sqrt((v-l)*(v+l+2))*x(i,j);
  q:= sqrt((v+l)*(v+l+2))*x(i,j-1)/2;
  r:= if j=N then 0 else sqrt((v-l)*(v-l+2))*x(i,j+1)/2;
  x2(i,j-1):= (p-q-r)/2;
  if l<=1 and i=1 then px(j-1):= -p-q-r;
  end;
  x2(i,N):= -sqrt((v+l+2)*(v+l+4))*x(i,N)/4;
end i;
if l<=1 then px(N):= x2(1,N)*2
end l<=3 end dv>=0;
?,f
i r
▶EOF◀