|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 14592 (0x3900)
Types: TextFile
Names: »nchanneltxt«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦d3633872f⟧ »cnch«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦d3633872f⟧ »cnch«
└─⟦this⟧
;ali time 3 0 lines.2500
(mode list.yes
lookup nchanneltxt
clear nchannel
nchannel=set 260
permanent nchannel.13
lookup rydrun
if ok.yes
mode 10.yes
lookup rydlist
if ok.yes
mode 15.yes
clear rydlist rydgtest
nchannel=hcalg xref.no
;nchannel mg1two l1.0 l2.1 x1.0.52 x2.0.45 print.no
;nchannel mg1two mix.yes l1.1
;nchannel mg1two print.no l1.1 x1.0.0.5 x2.0.67
;nchannel mg1two mix.yes l1.2 l2.1
mode 10.no 15.no list.no)
1979-09-07
n-channelprogram
begin
boolean print,endstate,mix,plot,weight,myrep;
real ind,rel,Ecm,
minval,
Na,maxns,nsmin,eps,eps1,x,y;
integer L,n,l,J,states,a,b,i,j,k,i1,k1,i2,k2,
maxiter,maxiter1,c,char,par,Jc;
integer channels,mypar,thetapar,maxpar;
if -,readifp(<:channels:>,channels) then channels:=3;
case channels of begin
begin mypar:=1; thetapar:=1; maxpar:=2; par:=1; end;
begin mypar:=2; thetapar:=1; maxpar:=6; par:=5; end;
begin mypar:=3; thetapar:=3; maxpar:=12; par:=9; end;
begin mypar:=4; thetapar:=10; maxpar:=28; par:=18; end;
end case;
begin
integer array li(1:channels);
array PSI(1:maxpar),pname(1:3),cm,zi,A,N,F,C(1:channels,1:channels),
Ipi,nstari,norm,myi,Nn,theta,stheta,ctheta(1:channels);
comment algol copy.platsymtxt;
algol list.off copy.ryproc;
algol list.off copy.rydstruct;
algol list.off copy.alutproc;
algol list.off copy.rydseg;
real procedure detsum(states,par,ny,my,W);
value states; integer states;
array par,ny,my,W;
if states<=0 then detsum:=0 else
begin
own integer eval;
integer i,j,k;
real D,p,q,r;
array s(1:channels,1:channels),mu,nyi,myi(1:mypar),
theta,stheta,ctheta(1:thetapar);
D:=0;
for i:=1 step 1 until thetapar do
begin
theta(i):=par(mypar+i);
stheta(i):=sin(theta(i));
ctheta(i):=cos(theta(i));
end;
for i:=1 step 1 until states do
begin
for k:=1 step 1 until channels do nyi(k):=ny(k,i);
for k:=1 step 1 until mypar do
mu(k):=PSI(k)-PSI(mypar+thetapar+k)/ny(k,i)**2/2;
for j:=1 step 1 until channels do
for k:=1 step 1 until channels do s(j,k):=sin(pi*(nyi(j)+mu(k)));
case channels of
begin
D:=1;
D:=D+(
stheta(1)**2*s(2,1)*s(1,2)+ctheta(1)**2*s(2,2)*s(1,1)
)**2*W(i);
D:=D+(
ctheta(1)*ctheta(2)*(ctheta(1)*ctheta(3)-stheta(1)*stheta(2)*stheta(3))*
ctheta(2)*ctheta(3)*s(1,1)*s(2,2)*s(3,3)+
s(1,2)*s(2,1)*s(3,3)*stheta(1)*ctheta(2)**2*(stheta(1)*ctheta(3)+
ctheta(1)*stheta(2)*stheta(3))*ctheta(3)+
s(1,1)*s(2,3)*s(3,2)*ctheta(1)*ctheta(2)**2*stheta(3)*(ctheta(1)*stheta(3)+
stheta(1)*stheta(2)*ctheta(3))+
s(1,2)*s(2,3)*s(3,1)*stheta(1)*ctheta(2)**2*stheta(3)*(stheta(1)*stheta(3)-
ctheta(1)*stheta(2)*ctheta(3))+
s(1,3)*s(2,1)*s(3,2)*stheta(2)*(stheta(1)*ctheta(3)+ctheta(1)*stheta(2)*stheta(3))*
(ctheta(1)*stheta(3)+stheta(1)*stheta(2)*ctheta(3))+
s(1,3)*s(2,2)*s(3,1)*stheta(2)*(ctheta(1)*ctheta(3)-
stheta(1)*stheta(2)*stheta(3))*
(stheta(1)*stheta(3)-ctheta(1)*stheta(2)*ctheta(3))
)**2*W(i);
D:=D+(
1
)**2*W(i);
end case;
end summing over states;
eval:=eval+1;
detsum:=D;
end detsum;
real procedure hkena(n,PSI,PHI,S,rho,sig,fn,maxeval);
value n,rho,sig,maxeval;
integer n,maxeval;
real rho,sig;
array PSI,PHI,S;
real fn;
comment Hooke and Jeeves direct search
n = number of variables
PSI(1:n) = starting points and subsequent base points
PHI(1:n) = points for call of fn
S(1:n) = step lengths
spsi = function value at base point
rho = reduction factor for step lengths
sig = significant figures required in PSI
fn = the function
maxeval = maximum no of function values permitted
;
begin
boolean cont;
integer l,k,eval;
array theta(1:n);
real sphi,ss,stheta,spsi;
real procedure E;
begin
for k:=1 step 1 until n do
begin
PHI(k):=PHI(k)+S(k);
sphi:=fn;
eval:=eval+1;
if ind=0 or sphi>=ss then
begin
S(k):=-S(k);
PHI(k):=PHI(k)+2*S(k);
sphi:=fn;
eval:=eval+1;
if ind=0 or sphi>=ss then PHI(k):=PHI(k)-S(k) else
ss:=sphi;
end else ss:=sphi;
end k;
printpar;
end E;
procedure printpar;
if print then
begin
write(out,nl,3);
for l:=1 step 1 until n do write(out,PSI(l));
write(out,nl,1,<:spsi =:>,spsi);
write(out,nl,1,<:iteration =:>,eval);
end print;
for k:=1 step 1 until n do PHI(k):=PSI(k);
spsi:=fn;
eval:=1;
printpar;
label1:
cont:=true;
for k:=k while eval<=maxeval and cont do
begin
ss:=spsi;
for k:=1 step 1 until n do PHI(k):=PSI(k);
E;
if ss<spsi then
label2:
begin
for k:=1 step 1 until n do
begin
if PHI(k)>PSI(k) and S(k)<0 then S(k):=-S(k);
if PHI(k)<PSI(k) and S(k)>0 then S(k):=-S(k);
theta(k):=PHI(k);
PHI(k):=2*PHI(k)-PSI(k);
end for k;
stheta:=ss;
ss:=sphi:=fn;
eval:=eval+1;
printpar;
if ind=0 or ss>=stheta then
begin
for k:=1 step 1 until n do
PSI(k):=theta(k);
spsi:=stheta;
goto label1;
end else
begin
for k:=1 step 1 until n do if abs(PHI(k)-PSI(k))>.5*abs S(k) then
goto label2;
end;
end ss<sphi;
cont:=false;
for k:=1 step 1 until n do cont:=cont or abs S(k)>=sig*abs PSI(k);
for k:=1 step 1 until n do S(k):=rho*S(k);
if print then write(out,nl,2,<:step lengths reduced:>);
end main loop;
maxiter:=eval;
hkena:=fn;
end hkena;
algol list.off copy.ryglobal;
comment START OF PROGRAM;
myrep:=false;
if -,readbfp(<:plot:>,plot) then plot:=false;
if -,readbfp(<:mix:>,mix) then mix:=false;
if -,readbfp(<:list:>,list) then list:=true;
if -,readbfp(<:print:>,print) then print:=false;
if -,readbfp(<:weight:>,weight) then weight:=false;
readifp(<:par:>,par);
if -,readifp(<:iterations:>,maxiter) then maxiter:=2000;
maxiter1:=maxiter;
if -,readrfp(<:nsmin:>,nsmin) then nsmin:=3;
if -,readrfp(<:nsmax:>,nsmax) then nsmax:=35;
if readsfp(<:plotter:>,pname) then setplotname(string inc(pname),0) else
setplotname(<:houstona:>,0);
if mix then
begin
unstackcuri;
j:=mypar+thetapar;
for k:=1 step 1 until channels do read(in,PSI(k),PSI(j+k));
for k:=1 step 1 until thetapar do read(in,PSI(mypar+k));
connectinp(1);
end;
readatsym(in,S,atno,Z);
write(out,ff,1,nl,4);
writeatsym(out,S,atno,Z);
read(in,i,i);
for i:=1 step 1 until channels do
begin
if -,readifp(case i of (<:l1:>,<:l2:>,<:l3:>,<:l4:>),li(i)) then
li(i):=case i of (0,2,2,2) else li(i):=2*li(i);
Ipi(i):=readr(case i of(<:Ip1:>,<:Ip2:>,<:Ip3:>,<:Ip4:>));
write(out,sp,4,false add ryalf(li(i)+256),1,<:limit:>);
end i;
if -,readifp(<:j:>,Jc) then Jc:=-1;
if Jc>=0 then write(out,<: J = :>,Jc,if Jc mod 2=1 then <:/2:> else <::>);
if -,readrfp(<:eps:>,eps) then eps:=8;
eps1:=eps:=10**(-eps);
if -,readrfp(<:steplengths:>,rel) then rel:=6;
rel:=10**(-rel);
states:=nsmax-nsmin+10;
begin
array PHI,ACCP,ACCP1(1:maxpar),ny,my(1:channels,1:states),W(1:states);
integer array nn,ll,JJ(1:states);
for i:=1 step 1 until maxpar do
begin
if -,mix then PSI(i):=0;
ACCP(i):=ACCP1(i):=.05;
end;
if -,mix then
begin
for k:=1 step 1 until mypar do
begin
if -,readrfp(case k of(<:x1:>,<:x2:>,<:x3:>,<:x4:>),PSI(k)) then
PSI(k):=.5 else write(out,nl,1,<:x:>,<<d>,k,<: = :>,PSI(k));
end;
for i:=1 step 1 until thetapar do
begin
if -,readrfp(case i of (
<:theta1:>,<:theta2:>,<:theta3:>,<:theta4:>,<:theta5:>,
<:theta6:>,<:theta7:>,<:theta8:>,<:theta9:>,<:theta10:>
),PSI(mypar+i)) then
PSI(mypar+i):=.6 else
write(out,nl,1,<:theta:>,<<d>,i,<: = :>,PSI(mypar+i),cos(PSI(mypar+i)),sin(PSI(mypar+i)));
end i;
end;
states:=0;
endstate:=false;
if list then
begin
write(out,nl,2,<:state:>,sp,6,<:Ecm:>);
for k:=1 step 1 until channels do write(out,sp,4,<:n*:>,<<d>,k);
for k:=1 step 1 until channels do write(out,sp,4,<:my:>,<<d>,k);
end;
maxns:=0;
for states:=states while -,endstate do
begin
readstate(in,L,n,l,J);
if L<0 then L:=l;
read(in,Ecm);
repeatchar(in);
for c:=readchar(in,char) while c>=7 and char<>25 do;
if char=101 or char=105 or char=60 then endstate:=true;
repeatchar(in);
if L=li(1) and (Jc>=0 =>Jc=J) then
begin
for k:=1 step 1 until channels do
nstari(k):=if Ecm<Ipi(k) then Z*sqrt(ryinf/100/(Ipi(k)-Ecm)) else 0;
if nstari(1)>=nsmin and nstari(1)<=nsmax then
begin
j:=states:=states+1;
nn(j):=n;
ll(j):=l;
JJ(j):=J;
for k:=1 step 1 until channels do
begin
ny(k,j):=nstari(k);
my(k,j):=nstari(k) - entier nstari(i);
if k>1 then my(k,j):=1-my(k,j);
end k;
W(j):=if weight then 1/nstari(1) else 1;
if nstari(1)>maxns then maxns:=nstari(1);
if print or list then
begin
write(out,nl,1);
writestate(out,L,n,l,J);
write(out,sp,2,<<ddddddddd.d>,Ecm);
for k:=1 step 1 until channels do write(out,<< dd.ddd>,nstari(k));
for k:=1 step 1 until channels do write(out,<< dd.ddd>,my(k,j));
end;
end nsmin and nsmax;
end l=l1;
end states;
for i:=1 step 1 until maxpar do PHI(i):=PSI(i);
if -,mix and par>=mypar+thetapar then
begin
minval:=hkena(mypar+thetapar,PSI,PHI,ACCP1,.5,rel,detsum(states,PHI,ny,my,W),maxiter1);
write(out,nl,2);
for k:=1 step 1 until channels do write(out,nl,1,<: my:>,<<d>,k,
sp,3,<< d.dddddd>,PSI(k));
for k:=1 step 1 until thetapar do
write(out,nl,1,<:theta:>,<<d>,mypar+k,PSI(mypar+k),cos(PSI(mypar+k)),
sin(PSI(mypar+k)));
write(out,nl,1,<:iterations :>,<< dddddd>,maxiter1,sp,2);
write(out,<:minimum :>,<< d.ddd'-d>,minval);
write(out,nl,1,<:steplength :>,ACCP1(1));
end;
ind:=1;
if mix or par>mypar+thetapar then
minval:=if mix then detsum(states,PSI,ny,my,W) else
hkena(par,PSI,PHI,ACCP,.5,rel,detsum(states,PHI,ny,my,W),maxiter);
write(out,nl,2);
for k:=1 step 1 until mypar do
write(out,nl,1,<:my:>,<<d>,k,<:(0):>,<< d.dddddd>,PSI(k),
<: my:>,<<d>,k,<:(1):>,<< d.dddddd>,PSI(mypar+thetapar+k));
for k:=1 step 1 until thetapar do
write(out,nl,1,<:theta:>,<<d>,k,<< d.dddddd>,
PSI(mypar+k),cos(PSI(mypar+k)),sin(PSI(mypar+k)));
if -,mix then write(out,nl,1,<:iterations:>,<< ddddd>,maxiter,sp,2);
write(out,nl,if mix then 1 else 0,<:minimum :>,
<< d.dddd'-dd>,minval);
if -,mix then write(out,<: steplength :>,ACCP(1));
for i:=1 step 1 until channels do
begin
theta(i):=PSI(mypar+i);
stheta(i):=sin(theta(i)); ctheta(i):=cos(theta(i));
end i;
if mix then write(out,nl,2,<:calculation of mixing coefficients only:>);
write(out,nl,3,<:state:>,sp,1);
for k:=1 step 1 until channels do
write(out,sp,5,<:z:>,<<d>,k);
write(out,sp,5,<:norm:>,sp,6,<:Nn:>);
for k:=1 step 1 until channels do
write(out,sp,5,<:A:>,<<d>,k);
for j:=1 step 1 until states do
begin
for i:=1 step 1 until channels do
myi(i):=PSI(i)-PSI(mypar+thetapar+i)/(ny(i,j)**2)/2;
for i:=1 step 1 until channels do
for k:=1 step 1 until channels do
cm(i,k):=sin(pi*(ny(i,j)+myi(k)));
comment set up F matrix;
case channels of begin
F(1,1):=1;
for i:=1,2 do
for k:=1,2 do
F(i,k):=case (2*k-2)+i of (ctheta(1),-stheta(2),stheta(1),ctheta(2));
for i:=1 step 1 until 3 do
for k:=1 step 1 until 3 do
F(i,k):=case (3*k-3)+i of(
ctheta(1)*ctheta(2),
-(stheta(1)*ctheta(3)+ctheta(1)*stheta(2)*stheta(3)),
stheta(1)*stheta(3)-ctheta(1)*stheta(2)*ctheta(3),
stheta(1)*ctheta(2),
ctheta(1)*ctheta(3)-stheta(1)*stheta(2)*stheta(3),
-(ctheta(1)*stheta(3)+stheta(1)*stheta(2)*ctheta(3)),
stheta(2),
ctheta(2)*stheta(3),
ctheta(2)*ctheta(3));
F(4,4):=1;
end case;
for i:=1 step 1 until channels do
for k:=1 step 1 until channels do
begin
k1:=k mod channels+1;
i1:=i mod channels+1;
k2:=(k+1)mod channels+1;
i2:=(i+1)mod channels+1;
C(i,k):=(((i+k)mod 2)*2-1)*(
case channels of(1,cm(i1,k1)*F(i1,k1),
cm(i1,k1)*F(i1,k1)*
cm(i2,k2)*F(i2,k2)-
cm(i1,k2)*F(i1,k2)*
cm(i2,k1)*F(i2,k1)
));
end i,k;
for i:=1 step 1 until channels do
begin
Na:=0;
for k:=1 step 1 until channels do Na:=Na+C(i,k)**2;
Na:=sqrt(Na);
for k:=1 step 1 until channels do A(i,k):=C(i,k)/Na;
for a:=1 step 1 until channels do
begin
N(i,a):=0;
for b:=1 step 1 until channels do
begin
y:=0;
for k:=1 step 1 until channels do y:=y+(F(b,k)*cos(pi*(ny(b,j)+myi(k)))*A(i,k));
N(i,b):=N(i,b)+y**2;
end b;
end a;
y:=0;
for k:=1 step 1 until channels do y:=y+PSI(mypar+thetapar+k)*A(i,k)**2;
for k:=1 step 1 until channels do y:=y+ny(k,j)**3*N(i,k);
Nn(i):=y;
for b:=1 step 1 until channels do
begin
y:=0;
for k:=1 step 1 until channels do y:=y+F(b,k)*cos(pi*(ny(b,j)+myi(k)));
zi(i,b):=y*A(i,k)/Nn(i)*ny(b,j)**(3/2);
end b;
norm(i):=0;
for k:=1 step 1 until channels do
for b:=1 step 1 until channels do
norm(i):=norm(i)+zi(i,k)*zi(i,b)*(if k=b then 1 else 0);
end i;
write(out,nl,1);
char:=writestate(out,li(1),nn(j),ll(j),JJ(j));
for i:=1 step 1 until channels do
begin
write(out,nl,if i=1 then 0 else 1,sp,if i=1 then 2 else char+2);
for k:=1 step 1 until channels do write(out,zi(i,k));
write(out,norm(i),<< dd.ddd>,Nn(i));
for k:=1 step 1 until channels do write(out,A(i,k));
end i;
end for states;
if plot then
begin
<*
stheta2:=sin(theta)**2;
ctheta2:=cos(theta)**2;
plotform(0,12,14);
setmargin(1,13);
writeplot(ff,1,<:z2**2 :>);
plotatsym(S,atno,Z);
writeplot(sp,3,false add ryalf(l1+256),1,<:-series:>);
if Jc>=0 then writeplot(sp,2,<:J =:>,Jc,if Jc mod 2=1 then <:/2:> else <::>);
plotsubform(0,12,0,12,false);
plotscale(0,maxns,0,1.1);
plotframe(0.0,0.0);
for j:=1 step 1 until states do plotpoint(ny(1,j),z2(1,j)**2,2);
plotform(0,12,14);
setmargin(1,13);
writeplot(ff,1,<:Lu-Fano plot :>);
plotatsym(S,atno,Z);
writeplot(sp,3,false add ryalf(l1+256),1,<:-series:>);
plotsubform(0,12,0,12,false);
plotscale(-.1,1.1,-.1,1.1);
plotframe(0.0,0.0);
for j:=1 step 1 until states do
begin
x:=-my(1,j); y:=ny(2,j);
plotpoint(x,y,1);
if list then write(out,j,x,y);
end;
plotgraph(x,ny1ny2(x),'-2,1,1/100);
*>
end plot;
end block for array
end inner block;
end;
▶EOF◀