DataMuseum.dk

top - metrics - download

    Length: 9216 (0x2400)
    Types: TextFile
    Names: »algfortrat«

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

TextFile

;gosav
lookup fortrat
if ok.no
(fortrat=set 150
permanent fortrat.17
fortrat=algol index.yes list.yes)
\f


Input-regler:
1) Overskrift i < >, max 71 karakterer. Denne overskrift
   kommer på plotteroutput.
2) Navnet på zonen hvor output fra plotfrekv findes, i < >.
3) Et heltal, 1, 2 el. 3, for valg af plotter:
      henholdsvis calcm, tek4006a, eller houstona.
4) Jmax samt 1 el. -1 for henhv. oblat el. prolat.
5) Fmin,Fmax samt C i MHz.
6) X-aksen (frekvensaksen) i cm.
7) Intensitetsgrænser som brøkdele af den maximale intensitet.
   Overgangene klassificeres som følger:
   Stærke: overgange med intensitet>I(1)*Imax.
   Middel: overgange med intensitet>I(2)*Imax.
   Svage: overgange med intensitet>I(3)*Imax.
8) Mya,myb,myc. Hvis myi<>0 plottes myi-spektret. 
9) Et tal, M, med følgende virkning: M=>0 plotning ophører
   efter den aktuelle plotning. M<0 nye data (pkt.1-8) indlæses;
begin
boolean ka,kb,kc,no,nl,closeres;
integer i,j,k,l,n,nr,myi,p,k1,k2,k3,k4,J,J1,J2,
        Jmax,signkappa,Fmin,Fmax,dF,kmax,bmin,bmax;
real a,I,maxI,C,X,dX,b,cpu,time;
integer array my(1:3),s,r(1:50);
array Imax,dI(1:3),head(1:12),zonename,drawname(1:2);
zone res,L(128,1,stderror);
nl:=false add 10; closeres:=outmedium(res);
write(res,<:<12>:>); nr:= 0;

spectrum: nr:=nr+1;
readhead(in,head,1); readhead(in,zonename,1);
read(in,p,Jmax,signkappa,Fmin,Fmax,C,X,dI,my); plotunit:=100.0;
a:=zonename(1);
drawname(1):= real <:plot:> add (a shift (-32));
j:=8;
for i:=a extract 8 while i=0 do begin
 a:=a shift (-8); j:=j+8 end;
drawname(2):= a shift 8 add (nr+48) shift j;
i:=1; open(L,4,string drawname(increase(i)),0);
for i:=2 step 1 until 10 do s(i):=0;
monitor(48,L,0,s); s(1):=Jmax;
monitor(40,L,0,s); monitor(50,L,15,s); close(L,true);
setplotname(case p of(<:calcm:>,<:tek4006a:>,<:houstona:>),0);
i:=1; saveplot(0,string drawname(increase(i)),0);
dF:=Fmax-Fmin; dX:=X/30;
begin
boolean array B(0:round(100*(X-dX)));
i:=1; open(L,4,string zonename(increase(i)),0);

comment
I denne blok findes den maximale intensitet
for henholdsvis a-, b- og c-type overgange;

Imax(1):=Imax(2):=Imax(3):=0;
p:=kmax:=0; inrec(L,128); a:=L(1);
ny_overgang:
k1:=a shift (-32) extract 8; k2:=a shift (-24) extract 8;
k3:=a shift (-8) extract 8; k4:=a extract 8;
if signkappa=-1 then begin k:=k1; l:=k3 end
                else begin k:=k2; l:=k4 end;
for i:=k,l do if i>kmax then kmax:=i;
ka:= (k1+k3) mod 2=0; kc:= (k2+k4) mod 2=0; I:=L(p+3);
j:= if (ka and -,kc) then 1 else if (-,ka and kc) then 3 else 2;
a:=abs L(p+2); if I>Imax(j) and a<Fmax and a>Fmin then Imax(j):=I;
p:=(p+3) mod 126; if p=0 then inrec(L,128);
a:=L(p+1);if a shift (-16) extract 8<=Jmax then goto ny_overgang;

comment
I denne blok læses zonen L igennem 3 gange
for henholdsvis a- ,b- og c-type overgange.
Hvis intensiteten af en overgang er større
end I(3)*Imax, plottes denne;

for myi:=1,2,3 do begin
if my(myi)<>0 then begin
integer array branch(1:Jmax,0:kmax*2);
boolean array br(0:kmax*2);
bmax:=0; bmin:= Jmax*2;
for i:=1 step 1 until Jmax do
for j:=kmax*2 step -1 until 0 do branch(i,j):=0;
 cpu:=systime(1,0,time);
 for i:=0 step 1 until 100*(X-dX) do B(i):=false;
 setposition(L,0,0); maxI:=Imax(myi);

 i:=1; write(res,nl,3,string head(increase(i)),nl,1,
 case myi of(<:a-:>,<:b-:>,<:c-:>),<:type spectrum.:>,nl,1,
 <:Den maximale intensitet::>,<<ddddd.d>,maxI,nl,1,
 <:Intensitetsgrænser i procent::>,<<  dd.dd>,
 dI(1)*100,dI(2)*100,dI(3)*100,nl,1,
 <:  Jmax=:>,<<dd>,Jmax,<:  Fmin=:>,<<dddddd>,Fmin,<:  Fmax=:>,
 Fmax,<:  C=:>,C); if -,closeres then setposition(res,0,0);
 plotform(0,X+4,0.6*X+5); setmargin(0.5,0.3);
 i:=1; writeplot(<:<12>:>,string head(increase(i)),<:  :>,
 case myi of(<:a-:>,<:b-:>,<:c-:>),<:type spectrum.:>);
 i:=-1; penup; plotmove(2,3); pendown;
 for i:=i+1 while 5.0*i<=Jmax do begin
  a:=3+(1+12.5*i/Jmax)*X/6; plotmove(2,a);
  plotmove(2+0.2*dX,a); plotmove(2,a);
 end;
 plotmove(2,0.6*X+3); plotmove(X+2,0.6*X+3);
 for i:=i-1 while 5*i>=0 do begin
  a:=3+(1+12.5*i/Jmax)*X/6; plotmove(X+2,a);
  plotmove(X+2-0.2*dX,a); plotmove(X+2,a);
 end;
 plotmove(X+2,3); plotmove(2,3); penup;
 plotsubform(2,X+2,3,0.6*X+3,false);
 i:=-1; I:=9*X/60; plotmove(0,I); pendown;
 for i:=i+1 while C*i<=dF do begin
  a:=0.5*dX + C*i*(X-dX)/dF; plotmove(a,I);
  plotmove(a,I-0.15*dX); plotmove(a,I+0.15*dX); plotmove(a,I);
 end;
 plotmove(X,I); penup;

 n:=p:=i:=0; b:=100*(X-dX)/dF; no:=true;
 J:=1; inrec(L,128); a:=L(1);
 fler_J:
 J1:=a shift (-40) extract 8;k1:=a shift (-32) extract 8;
 k2:=a shift (-24) extract 8;J2:=a shift (-16) extract 8;
 k3:=a shift (-8) extract 8; k4:=a extract 8;
 ka:=(k1+k3) mod 2=0; kc:=(k2+k4) mod 2=0;
 kb:= case myi of (ka and -,kc, -,ka and -,kc, -,ka and kc);
 j:=abs(L(p+2)); I:=L(p+3);
 kb:=kb and I>maxI*dI(3) and j>Fmin and j<Fmax;
 if J1<=J then begin
  if kb then begin
   j:=j-Fmin; l:=b*j; B(l):=B(l) add round(I/25);
   if J1=J2 and abs(k1-k3)<3 and abs(k2-k4)<3 then begin
    l:=J+(if L(p+2)>0 then k2-k1 else k4-k3)*signkappa;
    if l>bmax then bmax:=l; if l<bmin then bmin:=l;
    branch(J,l):=j
   end else begin
    n:=n+1;
    i:=4095*I/maxI;
    s(n):= 0 add (if J1<J2 then J1 else J2) shift 2 add
    (if J1=J2 then 2 else 1) shift 14 add i; r(n):=j;
  end end;
 end else begin
  slut_J:
  if n>0 then begin
   for i:=1 step 1 until n do begin
    k1:=r(i); k:=s(i);
    for j:=i+1 step 1 until n do begin
     if k1>r(j) then begin
      r(i):=r(j); r(j):=k1; k1:=r(i);
      s(i):=s(j); s(j):=k; k:=s(i);
     end hr;
    end j;
   end i;
   for i:=2 step 1 until n do
    if r(i)-r(i-1)<b then begin
     s(i-1):= s(i-1) + (s(i) extract 14); r(i):=0 end;
   if J mod 2=1 then begin
    i:=n; k:=-1; j:=1;
   end else begin
    i:=1; k:=1; j:=n;
   end J;
   for n:=i step k until j do if r(n)>0 then begin
    I:= (s(n) extract 14)/4095;
    l:= if I>dI(1) then 50 else
        if I>dI(2) then 35 else 20;
    pointsize:=X/3000*l;
    plotpoint(0.5*dX+r(n)*(X-dX)/dF,
    (1.0/6+(s(n) shift (-16) extract 8)*1.25/3/Jmax)
    *X,s(n) shift(-14) extract 2);
   end n;
   n:=0;
  end n>0;
  J:=J+1; if no then goto fler_J;
 end J1<=J;
 if no then begin
  p:=(p+3) mod 126; if p=0 then inrec(L,128); a:=L(p+1);
  if a shift (-16) extract 8<=Jmax then goto fler_J
  else begin no:=false; goto slut_J; end;
 end no;
 for i:=kmax*2 step -1 until 0 do br(i):=false; br(bmin):=true;
 k3:=Jmax; k4:=1;
 for i:=bmin+1 step 1 until bmax do begin
  kc:=false; kb:=true;
  for J:=1 step 1 until Jmax do begin
   k1:=branch(J,i);
   if k1>0 then begin
    if J<k3 then k3:=J;
    if J>k4 then k4:=J
   end;
   ka:=abs(branch(J,i-1)-k1)<b;
   br(i):=br(i) or -,ka and k1>0;
   if ka and kb and kc then branch(J-1,i):=0;
   if J<Jmax then begin kc:=kb; kb:=ka end;
  end;
  if ka and kb then branch(Jmax,i):=0
 end i;
 J1:=k3; Jmax:=k4;
 write(res,nl,3,<:Q-branches::>);
 rep:
 J2:=J1+5; if J2>Jmax then J2:=Jmax;
 write(res,nl,2,<:J =:>);
 for J:=J1 step 1 until J2 do write(res,<<        dd>,J);
 write(res,nl,1);
 for i:=bmin step 1 until bmax do if br(i) then begin
  ka:=false;
  for J:=J1 step 1 until J2 do ka:=ka or branch(J,i)>0;
  if ka then begin
   k:=3-entier(ln(if i=0 then 1 else i)/ln10);
   write(res,nl,1,<:Q:>,<<d>,i,false add 32,k);
   for J:=J1 step 1 until J2 do if branch(J,i)>0 then
    write(res,<<    dddddd>,branch(J,i)+Fmin) else
    write(res,<:          :>);
 end end;
 if J2<Jmax then begin J1:=J2+1; goto rep end;
 I:=1.25/3/Jmax; J1:=Jmax; J2:=1; j:=-1; pointsize:=X/100; penup;
 for i:=bmin step 1 until bmax do if br(i) then begin
  k2:=branch(J1,i); kb:=k2>0; kc:=false;
  for J:=J1 step j until J2 do begin
   k1:=if J<>J2 then branch(J+j,i) else 0; ka:=k1>0;
   if kb then begin
    a:=0.5*dX+k2*(X-dX)/dF;
    b:=(1.0/6+J*I)*X;
    if kc or ka then begin
     plotmove(a,b);
     if ka and -,kc then pendown;
     if ka and abs(k1-k2)*(X-dX)/dF>I*X
     or kc and abs(k2-k3)*(X-dX)/dF>I*X then begin
      plotmove(a,b+0.05*dX); plotmove(a,b-0.05*dX)
     end else begin
      plotmove(a+0.05*dX,b); plotmove(a-0.05*dX,b) end;
     plotmove(a,b)
    end else plotpoint(a,b,2);
    if -,ka and kc then penup;
   end kb;
   kc:=kb; kb:=ka; k3:=k2; k2:=k1;
  end J;
  p:=J1; J1:=J2; J2:=p; j:=-j;
 end;
 k:=round(100*(X-dX)); n:= B(0) extract 12;
 for i:=1 step 1 until k do
 if B(i) extract 12 > n then n:= B(i) extract 12;
 penup; k1:=0;
 for i:=0 step 1 until k do begin
  I:= (B(i) extract 12)*2*X/15/n;
  if I > 0.1 then begin
   k1:=k1+1; a:=0.5*dX+i*0.01;
   if k1 mod 2=0 then plotmove(a,I) else plotmove(a,0);
   pendown;
   if k1 mod 2=0 then plotmove(a,0) else plotmove(a,I);
   penup;
  end I;
 end i;
 cpu:=systime(1,time,time)-cpu; write(res,nl,2,
 <:cpu tid::>,<<ddddd>,cpu,<: sec.   real tid::>,
 time,<: sec.:>);
end end myi;
close(L,true); plotclose; i:=1;
write(res,nl,2,<:Tegning lagret i filen:  :>,
      string drawname(increase(i)));
read(in,J); if J<0 then goto spectrum;
write(res,nl,5,<:<25>:>); close(res,closeres);
end end;
▶EOF◀