DataMuseum.dk

top - metrics - download

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

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

TextFile

\f



begin
  integer i,j,k,m,s,t,J1,J,k1,k2,Jm,N,dev;
  real F,w,dw,a,b,c,d,e,skalax,skalay,hbr,yymmdd,hhmmss;
  boolean nl, sp, bu, bl, Q, closeres, down;
  integer array qtn(1:2);
  array name(1:2), head,my(1:3);
  zone res,z(128,1,stderror), L(128*2,2,stderror);

  closeres:=outmedium(res);
  readhead(in,head,1);  readhead(in,name,1);
  read(in,dev,my); i:= 1; N:=-1;
  open(L,4,string name(increase(i)),0);
  sp:= false add 32; nl:= false add 10; J1:=100;

nylinie:
  Jm:= 0; N:=(N+1) mod 4; repeatchar(in);
  for j:=1,2 do 
  begin
    read(in,J,k1,k2);
    if Jm<J then 
    begin
      m:= Jm; Jm:= J 
    end else m:= J;
    qtn(j):=  J shift 8 add k1 shift 8 add k2
  end;
  read(in,F,hbr,skalax,skalay); down:=skalax<0; skalax:=abs(1/skalax);

  Q:= m=Jm;  if m<J1+1 then 
  begin
    setposition(L,0,0); k:= 0; inrec(L,128); e:= L(1)
  end;

  begin
    integer nrec; integer array tail(1:10);
    real min,max,X,I;
    array displ,I0(0:Jm);
    for i:=0 step 1 until Jm do displ(i):=0;

repeat:
    for j:=1,2 do 
    begin
      t:= qtn(j);
      s:= if t = e shift (-24) extract 24 then -1 else
      if t = e extract 24 then 1 else 0;
      if s<>0 then 
      begin
        k1:= (e shift (-32) extract 8)-(e shift (-8) extract 8);
        k2:= (e shift (-24) extract 8)-(e extract 8);
        bu:= k1 = k1//2*2;  bl:= k2 = k2//2*2;
        t:= if   bu and -,bl then 1 else
        if -,bu and -,bl then 2 else
        if -,bu and   bl then 3 else 0;
        if t=0 then goto stop;
        if my(t)>0 then 
        begin
          J1:= e shift (-40) extract 8;
          J := e shift (-16) extract 8;
          if j=1 then s:= -s;
          b:= L(k+3)*0.06336397;  d:= L(k+2)*s;
          if J1=J then a:= 0 else
          begin
            a:= b*J*J;  b:= -b 
          end;
          for k1:=1 step 1 until Jm do 
          begin
            m:= if Q then k1 else k1-1;
            c:= (a + b*m*m)*(my(t)*F)**2;
            bu:= c*c>(d*d+c)*abs d*0.0001; dw:= c/d;
            if bu then 
            begin
              w:= (c+c)/(d + sign(d)*sqrt(d*d+4*c));
              dw:= w-dw
            end else w:= dw;
            displ(k1):= displ(k1) + w
          end 
        end 
      end 
    end;
    k:= (k+3) mod 126; if k=0 then inrec(L,128);
    e:= L(k+1); J1:= e shift (-16) extract 8;
    if J1>=0 and J1<=Jm+1 then goto repeat;
    min:=max:=0;
    for i:=0 step 1 until Jm do 
    begin
      a:=displ(i);
      if a>max then max:=a; if a<min then min:=a
    end;
    min:=min-4*hbr; max:=max+4*hbr;
    d:=0.25*hbr*hbr*skalax*skalax;
    for i:=0 step 1 until Jm do
    displ(i):=(if down then max-displ(i) else displ(i)-min)*skalax;
    nrec:=round((max-min)*skalax+0.5);
    tail(1):=nrec; for i:=2 step 1 until 10 do tail(i):=0;
    a:=0;
    if Q then 
    begin
      for i:=1 step 1 until Jm do 
      begin
        I0(i):=-i*i; a:=a+I0(i)
      end
    end else 
    begin
      k:=Jm*Jm;
      for i:=1 step 1 until Jm-1 do 
      begin
        I0(i+1):=i*i-k; a:=a+I0(i+1)
      end;
      I0(1):=-0.5*k; a:=a+I0(1)
    end;
    I0(0):=-a; a:=b:=0;
    open(z,4,<:lineplot:>,0); monitor(40,z,0,tail);
    for j:=0 step 1 until nrec-1 do 
    begin
      outrec(z,128);
      for k:=1 step 1 until 100 do z(k):=0;
      for i:=0 step 1 until Jm do 
      begin
        I:=I0(i); X:=displ(i)-j;
        for k:=1 step 1 until 100 do 
        begin
          X:=X-0.01; z(k):=z(k)+I/(d+X*X);
        end
      end i;
      for k:=1 step 1 until 100 do 
      begin
        c:=z(k);
        if c>b then 
        begin
          dw:=j+0.01*k; b:=c
        end else if c<a then a:=c;
      end k;
    end j;
    systime(1,0,yymmdd); yymmdd:=systime(4,w,hhmmss);
    dw:=(displ(0)-dw)/skalax; if down then dw:=-dw;
    if N=0 then write(res,<:<12>:>,nl,2);
    i:=1; write(res,string head(increase(i)),<< dd dd dd>,
    yymmdd,hhmmss,
    << dd>,qtn(1) shift (-16) extract 8,qtn(1) shift (-8)
    extract 8,qtn(1) extract 8,<: -> :>,qtn(2) shift (-16)
    extract 8,qtn(2) shift (-8) extract 8, qtn(2) extract 8);
    write(res,nl,1,<:Mya = :>,<< d.ddd>,my(1),<:  Myb = :>,
    my(2),<:  Myc = :>,my(3),nl,1,<:corr. to top-frequency: :>,
    dw,<: MHz.:>,<:   Stark-voltage: :>,<<dddd>,F,<: V/cm.:>,
    <<dd.dd>,1/skalax,<: MHz/cm.    hbr = :>,hbr,<: MHz.:>);
    if dev<5 then 
    begin
      c:=(skalay*(b-a))/b;
      catchbuf;
      plotmaxbuf:=byteload(owndescr+26)-1;
      setplotname(case dev of (<:plotter:>,<:calinch:>,<:calcm:>,
      <:tekdisp:>,<:tek4006:>));
      plotform(0,4+nrec,4+c);
      setmargin(1,3+c); i:=1;
      b:=skalay/b; w:=1-a*b;
      penup; plotmove(1,w); pendown;
      for i:=4 step 1 until 4*(nrec+3) do 
      begin
        if i mod 2=0 then penup;
        plotmove(0.25*i,w); pendown
      end;
      if down then 
      begin
        penup; plotmove(1,w); pendown;
        plotmove(1.25,w+0.25); penup;
        plotmove(1,w); pendown;
        plotmove(1.25,w-0.25)
      end else 
      begin
        pendown; plotmove(2.75+nrec,w+0.25);
        penup; plotmove(3+nrec,w);
        pendown; plotmove(2.75+nrec,w-0.25)
      end;
      penup;
      setposition(z,0,0); inrec(z,1); plotmove(2,w+z(1)*b);
      pendown; setposition(z,0,0);
      for j:=0 step 1 until nrec-1 do 
      begin
        inrec(z,128); k:=j+2;
        for i:=1 step 1 until 100 do plotmove(k+0.01*i,w+z(i)*b)
      end;
      b:=b/d;
      for i:=0 step 1 until Jm do 
      begin
        penup; plotmove(2+displ(i),w); pendown;
        plotmove(2+displ(i),w+I0(i)*b)
      end;
      plotclose;
    end dev<5;
    setposition(z,0,0); monitor(48,z,0,tail); close(z,true);
  end;
  for i:=readchar(in,j) while i<>2 and i<>6 and j<>25 do;
  if i=2 then goto ny_linie;
stop:close(L,true);
end
▶EOF◀