DataMuseum.dk

top - metrics - download

    Length: 2304 (0x900)
    Types: TextFile
    Names: »tsperc«

└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
    └─⟦b2ec5d50f⟧ 
        └─⟦09b4e9619⟧ »thcømat« 
            └─⟦this⟧ 

TextFile

;rene moss 12-1-1973/6-8-1980

sperc=algol
external procedure sperc(AR,n,AI);
value n; integer n; real array AR,AI;
begin
  real u,v,w,k,m,f,fm,fc,xm,ym,xr,yr,xc,yc,dx,dy;
  integer i,j,p;
  RED:
  if n>0 then
  begin
    if AR(n)=0 then
    begin
      AI(n):=0; n:=n-1;
      goto RED
    end;
    p:=n-1;
    xc:=yc:=dy:=0;
    fm:=fc:=AR(n)*AR(n);
    dx:=abs(AR(n)/AR(0))**(1/n);
    ITER:
    fm:=fc+fc;
    for i:=1,2,3,4 do
    begin
      u:=-dy; dy:=dx; dx:=u;
      xr:=xc+dx; yr:=yc+dy;
      u:=v:=0;
      k:=xr+xr;
      m:=xr*xr+yr*yr;
      for j:=0 step 1 until p do
      begin
        w:=AR(j)+k*u-m*v; 
        v:=u; u:=w
      end;
      f:=(AR(n)+u*xr-m*v)**2+u*u*yr*yr;
      if f<fm then
      begin
        xm:=xr; ym:=yr; fm:=f
      end
    end;
    if fm<=fc then
    begin
      dx:=dx*1.5; dy:=dy*1.5;
      xc:=xm; yc:=ym; fc:=fm
    end
    else
    begin
      u:=0.4*dx-0.3*dy; dy:=0.4*dy+0.3*dx; dx:=u
    end;
    u:=abs(xc)+abs(yc);
    if u+abs(dx)+abs(dy)>u and fc<>0 then goto ITER;
    u:=v:=0;
    k:=xc+xc;
    m:=xc*xc;
    for j:=0 step 1 until p do
    begin
      w:=AR(j)+k*u-m*v;
      v:=u;  u:=w
    end;
    if (AR(n)+u*xc-m*v)**2<=fc then
    begin
      u:=0;
      for j:=0 step 1 until p do u:=AR(j):=u*xc+AR(j);
      AR(n):=xc; AI(n):=0
    end
    else
    begin
      u:=v:=0;
      k:=xc+xc;
      m:=xc*xc+yc*yc;
      p:=n-2;
      for j:=0 step 1 until p do
      begin
        w:=AR(j):=AR(j)+k*u-m*v;
        v:=u; u:=w
      end;
      AR(n-1):=AR(n):=xc;
      AI(n-1):=-yc; AI(n):=yc
    end;
    n:=p;
    goto RED
  end
end sperc
; end
▶EOF◀