DataMuseum.dk

top - metrics - download

    Length: 4608 (0x1200)
    Types: TextFile
    Names: »polfitptxt«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦720b7e52e⟧ »calprog« 
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
    └─⟦4334b4c0b⟧ 
        └─⟦720b7e52e⟧ »calprog« 
            └─⟦this⟧ 

TextFile

; klab3 6 time.12000 lines.2800
lookup polfitlist
if ok.yes
mode list.yes
clear polfitprog
polfitprog=set 160
permanent polfitprog.13
if list.yes
polfitprog=algol list.yes
polfitprog=algol
polfitprog
12 3 76
begin
integer i,i1,i2,j,n,p,no,tno,res,layp;
array input,output(1:2);
boolean plot,sim,list;
real r,r1,r2,r3,r4,s,ymin,ymax,x,y,lay;
list:=sim:=plot:=false;
fplist:=true;
initfp;
if fpitems>0 then begin
  readbfp(<:plot:>,plot);
  readbfp(<:simulation:>,sim);
  readbfp(<:list:>,list);
  end;
if sim then begin
 i1:=readi(<:ran1:>);
 i2:=readi(<:ran2:>);
end;
if readifp(<:points:>,n) then else
n:=readi(<:no of points:>);
if -,readifp(<:degree:>,p) then
p:=readi(<:order of polynomial:>);
begin
array A,B,S,AM,AM2,SM(0:p),X,Y(1:n);
no:=if sim then readi(<:no of experiments:>) else 1;
if sim then begin
 s:=readr(<:deviation:>);
 write(out,<:<10>Coefficients<10>:>); writeend;
 read(in,A);
end;
if fpinareas>0 then begin
stackcuri;
readinfp(input,1);
res:=connectcuri(input);
i:=1;
if res<>0 then alarm(<:***connect input :>,string input(increase(i)));
end;
cleararray(AM); cleararray(AM2);
cleararray(SM);
if sim then
   begin write(out,<:x values<10>:>); writeend; read(in,X) end
   else begin
  if fpinareas=0 then write(out,<:<10> X, Y :>);
  outend(10);
  for i:=1 step 1 until n do read(in,X(i),Y(i));
  end;
for tno:=1 step 1 until no do
begin

   real procedure pol(A,x);
   value x; real x;
   array A;
   begin
   y:= A(p);
   for i:=p-1 step -1 until 0 do y:=y*x+A(i);
   pol:=y;
   end;
   if sim then begin

   r3:=r4:=0;
   for j:=1 step 1 until n do
      begin
       r1:=random(i1); r2:=random(i2);
       r3:=r3+r1; r4:=r4+r2;
       r:=sqrt(-2*ln(r1))*cos(2*pi*r2);
       Y(j):=pol(A,X(j))+s*r;
       end;
   write(out,<:<10>r1 = :>,r3/n,
             <:<10>r2 = :>,r4/n);
   end sim;
  i:=n;
  s:=polfit(i,1.0,X(i),Y(i),B,S,p);
  for j:=0 step 1 until p do begin
    AM(j):=AM(j)+B(j);
    AM2(j):=AM2(j)+B(j)**2;
    SM(j):=SM(j)+S(j);
    end;
  if readlsfp(output) then begin
    reservesegm(output,no*p*.1);
    permentry(output,13);
    stackcuro;
    res:=connectcuro(output);
    i:=1;
    if res<>0 then begin
     unstackcuro;
     alarm(<:***connect output :>, string output(increase(i)));
     end;
    end;
  write(out,<:<10>s = :>,<< -d.ddd'+d>,sqrt(s));
  for j:=0 step 1 until p do
  write(out,<:<10>A(:>,<<d>,j,<:) =  :>,
            string minlay(B(j),S(j)/10,0),B(j),
    <: +- :>,<<d.d'd>,S(j));
if -,sim and s>'-100*smallreal and list then begin
  for j:=p step -1 until 0 do 
   begin
   i:=entier(ln(S(j))/ln(10));
   B(j):=round(B(j)*10**(-i+1))*10**(i-1);
  end;
  end;
if list then begin
  write(out,false add 10,2,<:        X(j)           Y(j):>);
  if -,sim then write(out,<:        Y(j)(comp):>);
  for j:=1 step 1 until n do
      begin
      write(out,<:<10>:>);
      lay:=minlay(X(j),sqrt(s),layp);
      write(out,string lay,false add 32,12-layp,X(j),<:  , :>);
       lay:=minlay(Y(j),sqrt(s),layp);
       write(out,string lay,false add 32,12-layp,Y(j));
       if -,sim then write(out,<:  ,  :>,
        string lay,false add 32,12-layp,pol(B,X(j)));
      end;
  end;
   if fpout then begin
    write(out,false add 10,3);
    closeout;
    end;
if plot then begin
   plotform(0,20,20);
   ymin:=ymax:=Y(1);
   for i:=1 step 1 until n do begin
       if Y(i)>ymax then ymax:=Y(i) else
       if Y(i)<ymin then ymin:=Y(i); end;
       setmargin(2,plotyform-1);
       writeplot(<:<12>:>);
       plotadmini(X(1),X(n),ymin,ymax,0);
       for i:=1 step 1 until n do
           plotpoint(X(i),Y(i),2);
           setmask(0.5,0.5,0.5);
           plotcurve(x,pol(A,x),x,X(n),X(1),-(X(n)-X(1))/200);
           setmask(1,0,0);
           plotcurve(x,pol(B,x),x,X(n),X(1),-(X(n)-X(1))/200);
       end;
   end;
if no>1 then
for j:=0 step 1 until p do
  write(out,<:<10>AM(:>,<<d>,j,<:) = :>,
     string minlay(AM(j)/no,SM(j)/no/10,0),AM(j)/(no-1),
     <: +- :>,<<d.d'd>,SM(j)/(no-1));
outend(10);
end;
end;
▶EOF◀