⟦56dfd4a58⟧

TextFile

;gosav
clear funcdraw
r=algol list.no index.no xref.no
\f




funcdraw

begin
comment
      Drawing of functions derived from parameters previously
      fitted by funcfit.
      GOS, december. 1979.

   The function to be drawn is defined in the external procedure
funclinda previously used in funcfit. It is assumed that the
following data are stored by funcfit on the disc area <:fdraw:>:
      head(1:12), nt, n, p, N, S, no(1:n), pm(1:nt),
      A(1:n,1:n) and point(1:N,1:p+1).
Further inputs specifies the drawing:
   1)  A number m is required:
          m = 0:  Plotting is stopped.
          m = 1:  Plotting on the Calcomp 563 plotter
          m = 2:  Plotting on the Tektronic 4006 graphical display
          m = 3:  Plotting on the Houston plotter.
   2)  Two numbers fx and fy, specifying the plotformat
   3)  If p>1 the index k of the variable for the abscissa must
       be given as well as the fixed values of the remaining p-1
       variables. If p=1 this is unnecessary.
   4)  Two numbers, xmin and xmax, specifying the interval on the
       x(k)-axis must be given.
   5)  An integer <= 1000, the number of straight lines forming
       the curve.
       After a plot has been finished the program returns to
       the start condition, i.e. a new m is required;
integer i,j,k,l,m,n,nt,p,N,lines;
real S,fx,fy,xmin,xmax,h,y,ymin,ymax,s;
integer array tail(1:10);
array head(1:12);
zone res(128,1,stderror);
open(res,4,<:fdraw:>,0);
if monitor(42,res,0,tail)<>0 then begin
  write(out,<:<10>***fdraw not found<10>:>);
  goto slut
end;
inrec(res,14);
for i:=1 step 1 until 12 do head(i):= res(i);
h:= res(13);
nt:= h shift (-40) extract 8;
n := h shift (-32) extract 8;
p := h shift (-24) extract 8;
N := h extract 24;
S:= res(14);

begin
integer array no(1:n);
array pm,dy(1:nt), c(1:n), A(1:n,1:n), x(1:p), point(1:N,1:p+1);
l:= nt+(n+3)//4+n*n+(p+1)*N;
inrec(res,if l>114 then 114 else l);
for i:=1 step 1 until n do begin
  k:= (i+3)//4;
  no(i):= res(k) shift (-48+12*i) extract 12
end;
for i:=1 step 1 until nt do pm(i):= res(k+i);
k:= k+nt; p:= p+1; m:= 114;
for i:=1 step 1 until n do
for j:=1 step 1 until n do begin
  if k=m then begin
    l:= l-m; k:= 0; m:= 128;
    inrec(res,if l>128 then 128 else l)
  end;
  k:= k+1; A(i,j):= res(k)
end;
for i:=1 step 1 until N do
for j:=1 step 1 until p do begin
  if k=m then begin
    l:= l-m; k:= 0; m:= 128;
    inrec(res,if l>128 then 128 else l)
  end;
  k:= k+1; point(i,j):= res(k)
end;
close(res,true); p:= p-1;

plot:     read(in,m);
if m=0 then goto slut;
read(in,fx,fy);
if p>1 then begin
   read(in,k);
   for i:=1 step 1 until p do
   if i<>k then begin
      read(in,h); x(i):= h
end end else k:= 1;
read(in,xmin,xmax,lines);
begin
boolean B;
integer array f(1:2,0:lines);
x(k):= xmin; ymin:= ymax:= funclinda(x,pm,dy,false);
s:= (xmax-xmin)/10;
for i:=1 step 1 until 10 do begin
   x(k):= xmin + s*i;
   h:= funclinda(x,pm,dy,false);
   if h<ymin then ymin:= h else if h>ymax then ymax:= h;
end;
y:= if abs ymax>abs ymin then abs ymax else abs ymin;
y:= y/5000000;  s:= s*10/lines;

for i:=0 step 1 until lines do begin
   x(k):= xmin + s*i;
   h:= funclinda(x,pm,dy,true);
   f(1,i):= h/y;
   if h<ymin then ymin:= h else if h>ymax then ymax:= h;
   for j:=1 step 1 until n do
      c(j):= sum(A(j,l)*dy(no(l)),l,1,n);
   f(2,i):= sqrt(sum(c(j)*dy(no(j)),j,1,n)*S)*3/y;
end;
setplotname(case m of
(<:calcm:>,<:tek4006a:>,<:houstona:>,<:tek4006c:>,<:tek4006d:>),
if m=5 then 3 else 0);;
plotform(0,fx,fy);
plotsize:=0.2; plotheight:=.28; linediff:=0.56;
setmargin(4,fy-1);
j:= 1; writeplot(<:<12>:>,string head(increase(j)));
plotadmini(xmin,xmax,ymin,ymax,0);
plotcurve(xmin+h*s,f(1,h)*y,h,0,lines,1.0);
setmask(0.2,0.2,0.2);
plotcurve(xmin+h*s,(f(1,h)+f(2,h))*y,h,lines,1,-1.0);
plotcurve(xmin+h*s,(f(1,h)-f(2,h))*y,h,1,lines,1.0);
pointsize:= 0.3;
for i:=N step -1 until 1 do begin
   B:= true;
   for j:=1 step 1 until p do
   if j<>k then B:= B and point(i,j)=x(j);
   if B then   plotpoint(point(i,k),point(i,p+1),1);
end;
end functionplot;
plotclose;
goto plot;
end arrays;

slut: end
rename r.funcdraw
permanent funcdraw.15
r=set
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦56dfd4a58⟧ TextFile

Derivation

TextFile
