|
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: 13824 (0x3600)
Types: TextFile
Names: »pe580acc«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »pe580acc«
clear day irst
irts=set 6 disc5
scope day irst
irst=algol list.yes
Program til opsamling af spektre og accumulerede data (irst).
begin
integer res,i,buf,speed,rep,
start_w,final_w,no_all,stdsw,stdfw,stdr,stdna;
real s,ism,ny,stdism,stddw;
real array READSTR(1:2),micro(1:3),program,param(1:2);
integer array M,A(1:8),C(0:255);
own boolean standard,timedrive,singlebeam,shutter,zero,kinetic,
udskrift;
boolean setup,ok,st_exp,stdp;
boolean procedure fejl;
begin
if res<>1 or netiosw extract 7 <> 0 then
begin
fejl:=true;
fejlinet(out,micro,res,netiosw);
end
else
fejl:=false;
end fejl;
boolean procedure send_wait(op);
integer op;
begin
M(1):=op;
M(2):=firstaddr(C);
M(3):=M(2)+510;
buf:=sendmessage(micro,M);
if buf=0 then
alarm(<:buffer lack:>);
for i:=waitanswer(buf,A) while
i=1 and A(1)=0 and A(2)=0 do buf:=sendmessage(micro,M);
if A(1)<>0 or i<>1 then
begin
send_wait:=false;
fejlinet(out,micro,i,A(1));
end
else
send_wait:=true;
end send_wait;
\f
procedure command(str,found);
string str;
label found;
begin
if s<>real str then goto fin;
goto found;
fin:
end command;
\f
standard:=ok:=stdp:=true;
setup:=neterror:=false;
stdsw:=4000;
stdfw:=180;
stddw:=0.5;
stdism:=2;
stdr:=0;
stdna:=11284;
program(1):=real (long <:irmon:> + long <:1:> shift (-40));
program(2):=real <::>;
micro(1):=real (long <:miclo:> + long <:c:> shift (-40));
micro(2):=real <:al4:>;
micro(3):=real <::>;
nextparam:
res:=readparam(param);
nextp:
if res=2 then
begin
param(1):=param(1) shift (-40) shift 40;
if param(1)=real <:p:> then
begin
res:=readparam(param);
if res=4 then
begin
program(1):=param(1);
program(2):=param(2);
end
else
goto nextp;
end
else
if param(1)=real <:m:> then
begin
res:=readparam(param);
if res=4 then
begin
micro(1):=param(1);
micro(2):=param(2);
micro(3):=real <::>;
end
else
goto nextp;
end;
end;
if res<>0 then goto nextparam;
\f
l1:
READSTR(1):=READSTR(2):=real <::>;
write(out,nl,1,<:command =:>);
fpproc(33<*outend*>,0,out,32<*sp*>);
readstring(in,READSTR,1);
s:=READSTR(1) shift (-24) shift 24;
command(<:sto:>,STOP);
command(<:loa:>,INIT);
command(<:end:>,END);
command(<:hen:>,DUMP);
command(<:dum:>,DUMP);
command(<:set:>,SETUP);
command(<:ven:>,VENT);
command(<:res:>,RESER);
command(<:fri:>,FRI);
command(<:mic:>,MICRO);
command(<:pro:>,PROGRAM);
command(<:con:>,TEST);
command(<:qui:>,QUIT);
command(<:rel:>,REL);
command(<:lis:>,LIST);
command(<:sta:>,START);
command(<:aut:>,AUTO);
command(<:man:>,MANU);
command(<:std:>,STD);
command(<:got:>,GOTO);
write(out,nl,1,<:***command :>,string inc(READSTR),
<: unknown.:>);
if readb(<:Command list:>) then ircoml;
goto l1;
\f
INIT:
netoperat(string inc(micro),opstop,0);
res:=netprogload(string inc(micro),string inc(program));
if fejl then
begin
ok:=false;
goto l1;
end;
write(out,nl,1,string inc(micro),<: loaded:>);
ok:=true;
goto l1;
\f
SETUP:
<* input parameters *>
st_exp:=readb(<:standard experiment:>);
if st_exp then
begin
start_w:=stdsw;
final_w:=stdfw;
ny:=stddw;
no_all:=stdna;
ism:=stdism;
rep:=stdr;
udskrift:=stdp;
end
else
begin
start_w:=readil(<:starting wavenumber:>,180,4000);
final_w:=readil(<:final wavenumber:>,180,start_w);
ny:=readrl(<:delta ny:>,0.025,1);
i:=ny/0.025;
if abs(i*0.025-ny) > 1'-3 then
write(out,<<dd.ddd>,<:<10>selected delta ny changed from :>
,ny,<: into :>,
i*.025,nl,1);
ny:=i*0.025;
if start_w>=2000 and final_w<2000 then
no_all:=(start_w-2000)/ny + (2000-final_w)/ny*2 else
if start_w<2000 then
no_all:=(start_w-final_w)/ny*2 else
if start_w>=2000 and final_w>=2000 then
no_all:=(start_w-final_w)/ny;
no_all:=(no_all//6+1)*6 -2;
ism:=readr(<:integrated scanmode.multiplier setting (ex: 10.2):>);
if entier(ism)=0 then ism:=ism+12;
if-, standard then
begin
comment nonstandard input parameters;
time_drive:=readb(<:select time drive yes/no:>);
zero:=readb(<:select chartdrive yes/no:>);
if zero then
speed:=readi(<:chart speed cm/min:>);
kinetic:=readb(<:kinetic experiment,wavenumber frosen yes/no:>);
end nonstandard input parameters;
rp: rep:=readi(<:number of times to repeat experiment:>);
if rep<0 then goto l1;
if no_all>29600 then
begin
write(out,<:<10>***number of points too large.:>);
goto l1;
end;
if no_all>11800 and rep>0 then
begin
write(out,<:<10>***number of points too large for accumulated spectrum.:>);
goto rp;
end;
end of input parameters;
\f
comment evaluating setupblock;
begin
integer i ,j;
clear_array(C);
res:=netoperat(string inc(micro),opstart,0);
if fejl then goto l1;
<* 117 (u) informs the micro to receive a setup *>
C(0):=117;
i:=ism*10;
i:=i mod 10;
i:=i+1;
i:=case i of (0,2,1);
j:=ism;
j:=j shift 2;
C(1):=(i+j+64) shift 16 ;
comment setup char 1;
if shutter then
i:=4+32 else
i:=32;
if time_drive then
i:=i+2;
C(1):=C(1)+(i shift 8);
comment of setup char 2;
if -,st_exp then
udskrift:=readb(<:output on PE580 while recording :>);
if udskrift then C(1):=C(1)+72 else
C(1):=C(1)+64;
comment of setup char 3;
if udskrift then
C(2):=(32) shift 16 else
C(2):=34 shift 16 ;
if single_beam then
C(2):=C(2)+(8 shift 16);
if zero then
begin
speed:=(128*speed - 60)/speed;
if speed>64 then
C(2):=C(2)+(3 shift 16) else
C(2):=C(2)+(2 shift 16);
comment of setup char 4;
C(2):=C(2)+(((speed extract 6)+64) shift 8);
comment of setupchar 5;
end
else
C(2):=(64 shift 8)+ C(2);
if kinetic then
C(2):=C(2)+16;
i:=1024-(ny/0.025);
C(2):=C(2)+32+(i shift (-6) extract 4);
comment of setup char 6;
C(3):=(64+(i extract 6))shift 16;
comment of setup char 7;
C(3):=C(3)+(((C(1) shift (-8))extract 8)shift 8);
comment of setup char 8;
C(3):=C(3)+((C(1) shift (-16) extract 8));
comment of setup char 9;
C(4):=start_w*10;
C(5):=no_all;
C(6):=rep;
C(255):=-1;
setup:=send_wait(opoutput+1);
write(out,nl,1,if setup then <:setup ok:> else <:setup not ok:>);
if -,setup then goto l1;
fpproc(33,0,out,0);
end of evaluating setupblock;
for i:=i while C(0) extract 8 <> 114 <* 114 = r *> and ok do
ok:=ok and send_wait(opinput+1);
write(out,nl,1,<:init :>,if ok then <:ok:> else <:not ok:>);
fpproc(33,0,out,0);
if -,ok then goto l1;
C(0):=115;
C(255):=-1;
ok:=sendwait(opoutput+1);
if -,ok then
goto l1;
TEST:
res:=netabsio(string inc(micro),opinput,C,4);
if fejl then
goto l1
else
if C(0) extract 8 = 101 <*e*> then
goto DUMP
else
if C(0) extract 8 = 102 <* f *> then
write(out,nl,1,<:***Error in data-collection:>)
else
begin
integer buf,cbuf,abuf;
integer array cm(1:8);
for buf:=1 step 1 until 8 do cm(buf):=0;
cm(2):=20;
abuf:=att;
cbuf:=sendmessage(<:clock:>,cm);
buf:=0;
for buf:=buf while buf<>cbuf and buf<>abuf do
waitevent(buf);
if buf=cbuf then
begin
regretmess(abuf);
waitanswer(cbuf,A);
goto TEST;
end
else
begin
regretmess(cbuf);
waitanswer(abuf,A);
end;
end;
goto l1;
\f
DUMP:
begin
comment dump from microprocessor;
long array N(1:2);
integer array T(1:10);
if -,setup then
begin
write(out,<:fmax, fmin, delta<95>f, ism.mult, rep::>);
fpproc(33,0,out,32);
read(in,start_w);
if start_w<=0 then
begin
start_w:=stdsw;
final_w:=stdfw;
ny:=stddw;
ism:=std_ism;
rep:=stdr;
end
else
read(in,final_w,ny,ism,rep);
no_all:=if start_w>=2000 and final_w<2000 then
((start_w-2000)/ny+(2000-final_w)/ny*2)
else
if start_w>=2000 and final_w>=2000 then
((start_w-final_w)/ny)
else
((start_w-final_w)/ny*2);
no_all:=(no_all//6+1)*6-2;
setup:=true;
end;
if irdump(micro,N,3000,3000+
(if rep=0 then no_all else (no_all//2*5+2))) then
begin
lookup_tail(N,T);
T(6):=entier(ism) shift 12 +
(entier(ism*10) mod 10);
T(7):=round(1/ny);
T(9):=start_w shift 12+final_w;
T(10):=no_all;
change_entry(N,T);
write(out,nl,1,<:Data area is :>,N,nl,1);
if rep>0 then
begin
irca1;
ircb1;
if readb(<:12 bits conv. of accum. spectrum:>)
then irc1;
end else irc1;
end
else
write(out,nl,1,<:***Dumpfejl:>);
goto l1;
end;
LIST:
ircoml;
goto l1;
\f
MICRO:
write(out,<:present micro: :>,string inc(micro),nl,1,
<:new micro::>);
fpproc(33,0,out,32);
readchar(in,i);
if i <>10 then
begin
micro(1):=micro(2):=real <::>;
repeatchar(in);
readstring(in,micro,1);
end;
goto l1;
PROGRAM:
write(out,<:present program: :>,string inc(program),nl,1,
<:new program::>);
fpproc(33,0,out,32);
readchar(in,i);
if i<>10 then
begin
program(1):=program(2):=real <::>;
repeatchar(in);
readstring(in,program,1);
end;
goto l1;
QUIT:
C(0):=113; <* 113=q for quit *>
C(255):=-1;
ok:=send_wait(opoutput+1);
if ok then
goto TEST
else
goto l1;
START:
res:=netoperat(string inc(micro),opstart,0);
fejl;
goto l1;
STOP:
res:=netoperat(string inc(micro),opstop,0);
fejl;
goto l1;
AUTO:
res:=netoperat(string inc(micro),opstart,0);
if fejl then goto l1;
C(0):=97; <* 97 = a for automatic *>
C(255):=-1;
send_wait(opoutput+1);
goto l1;
MANU:
res:=netoperat(string inc(micro),opstart,0);
if fejl then goto l1;
C(0):=109; <* 109 = m for manual *>
C(255):=-1;
send_wait(opoutput+1);
goto l1;
\f
REL:
netoperat(string inc(micro),opstop,0);
res:=netprogload(string inc(micro),<:irmonstop:>);
if fejl then goto l1;
res:=netoperat(string inc(micro),opstart,0);
if fejl then goto l1;
res:=netoperat(string inc(micro),opstop,0);
if fejl then goto l1;
res:=netprogload(string inc(micro),string inc(program));
fejl;
goto l1;
goto l1;
RESER:
res:=reserve_proc(micro,0);
if res<>0 then
fejlinet(out,micro,res+8,0);
goto l1;
FRI:
release_proc(micro);
goto l1;
VENT:
wait_answer(att,A);
goto l1;
END:
write(out,<:slut:>);
fpproc(33<*outend*>,0,out,10<*nl*>);
fpproc(7<*endprogram*>,0,0,0);
\f
STD:
<* definition of own standard experiment *>
sw:write(out,nl,1,<:starting wavenumber::>,stdsw);
fpproc(33,0,out,32);
readchar(in,res);
if res<>10 then
begin
repeatchar(in);
read(in,stdsw);
if stdsw>4000 or stdsw<180 then
begin
write(out,<:***out of range 4000, 180:>,nl,1);
goto sw;
end;
end;
fw:
write(out,nl,1,<:final wavenumber::>,stdfw);
fpproc(33,0,out,32);
readchar(in,res);
if res<>10 then
begin
repeatchar(in);
read(in,stdfw);
if stdfw>stdsw or stdfw<180 then
begin
write(out,<:***out of range:>,stdsw,<:, 180:>,nl,1);
goto fw;
end;
end;
dw:
write(out,nl,1,<:delta ny::>,<< d.ddd>,stddw);
fpproc(33,0,out,32);
readchar(in,res);
if res<>10 then
begin
repeatchar(in);
read(in,stddw);
i:=stddw/0.025;
if abs(i*0.025-stddw)>1'-4 then
write(out,<<dd.ddd>,<:<10>selected delta ny changed from :>,
stddw,<: to :>,i*0.025);
stddw:=i*0.025;
if i>40 or i<1 then
begin
write(out,<:***delta ny out of range 1 to 0.025:>,nl,1);
goto dw;
end;
end;
isw:
write(out,nl,1,<:integrated scanmode.multiplier setting::>,<< dd.d>,
if entier(stdism)=12 then stdism-12 else stdism);
fpproc(33,0,out,32);
readchar(in,res);
if res<>10 then
begin
repeatchar(in);
read(in,stdism);
if entier(stdism)=0 then stdism:=stdism+12;
end;
if stdsw>=2000 and stdfw<2000 then
stdna:=(stdsw-2000)/stddw + (2000-stdfw)/stddw*2 else
if stdsw<2000 then
stdna:=(stdsw-stdfw)/stddw*2 else
if stdsw>=2000 and stdfw>=2000 then
stdna:=(stdsw-stdfw)/stddw;
stdna:=(stdna//6+1)*6-2;
if stdna<11800 then
begin
write(out,nl,1,<:number of times to repeat experiment::>,stdr);
fpproc(33,0,out,32);
readchar(in,res);
if res<>10 then
begin
repeatchar(in);
read(in,stdr);
end;
end
else
stdr:=0;
if stdna>29600 then
begin
write(out,nl,1,<:***number of points too large.:>,nl,1);
goto STD;
end;
stp:
write(out,nl,1,<:output on PE-580 while recording ? :>,
if stdp then <:yes:> else <:no:>);
fpproc(33,0,out,32);
readchar(in,res);
if res<>10 then
begin
long array tt(1:2);
tt(1):=tt(2):=long <::>;
repeatchar(in);
readstring(in,tt,1);
if tt(1)=long <:ja:> or tt(1)=long <:yes:> or tt(1)=long<:true:> then
stdp:=true
else
if tt(1)=long <:nej:> or tt(1)=long <:no:> or tt(1)=long <:false:> then
stdp:=false
else
begin
write(out,<:***ikke forstået:>,nl,1);
goto stp;
end;
end;
goto l1;
\f
GOTO:
repeatchar(in);
readchar(in,i);
if i=10 then
begin
write(out,<:wavenumber::>);
fpproc(33<*outend*>,0,out,32<*space*>);
end;
read(in,s);
if s>4000 or s<180 then
begin
write(out,<<dddd.d>,nl,1,s, <: out of range:>,nl,1);
goto l1;
end;
netoperat(string inc(micro),opstart,0);
C(0):=103<*103 = g for goto*>;
C(1):=s*10;
C(255):=-1;
send_wait(opoutput+1);
goto l1;
end;
▶EOF◀