|
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: 6912 (0x1b00)
Types: TextFile
Names: »printoscpr«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦e6c2bcfa6⟧ »cryprog«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦e6c2bcfa6⟧ »cryprog«
└─⟦this⟧
<* printosc prints lifetimes oscillatorstrengths etc. *>
integer procedure writelines(l);
value l; integer l;
begin
write(out,"nl",l);
lines:=writelines:=lines+l;
end;
integer procedure writeff;
begin
write(out,"ff",1);
totpage:=totpage+1;
end;
procedure setformat(c,l);
value c,l; integer c,l;
begin
<*
integer array M(1:8);
reserveproc(<:printer:>);
M(1):=2 shift 12;
M(2):=c;
M(3):=l;
i:=waitanswer(sendmessage(<:printer:>,M),M);
if i<>1 then write(out,<:<10>setformat :>,i);
outendcur(0);
releaseproc(<:printer:>);
*>
end;
procedure writetablehead(parentno,parterm,tablenr);
value parentno,tablenr; integer parentno,tablenr;
integer array parterm;
begin
writelines(5);
if tablenr>0 then write(out,<:Table :>,tablenr,"sp",2,
<:-:>,"sp",2);
writeatsym(out,S,atno,Z);
write(out,<: (:>);
writeatsym(out,S,segdes(1),1);
write(out,"sp",2,<:sequence):>,"sp",2);
writelines(1);
write(out,<:Ionisation Potential :>,
<<dd ddd ddd.dd>,getIp(parentno,parterm));
Zold:=Z;
end writetablehead;
procedure printosc(bsname,parterm,nuitr);
value nuitr; integer nuitr;
array bsname;
integer array parterm;
if lifetimes and chargesegdes(15)<0 and chargesegdes(16)<0 then
begin comment local block for printosc;
integer i,trans,tottrans,sta,coresold;
real tau,tau2,osc,A,Sl,lambda,c,
cut,b,lay,lay3;
boolean prkey;
array bsdipname(1:2);
algol list.off copy.statevar;
algol list.off copy.statevar2;
integer array field dipi;
array field dipf;
procedure writeoffline(A,f,S,lambda,b,canc,app,cutcase,app2,cutcase2);
value A,f,S,lambda,b,canc,app,cutcase,app2,cutcase2;
real A,f,S,lambda,b,canc;
integer app,cutcase,app2,cutcase2;
if -,list then
begin
boolean markb,markf;
if lambda<>0 and b>=brmin and A<>0 then begin
markb:=false add (if cutcase=5 or
cutcase2=5 then 42 else 32);
markf:=false add (if( app>0 or
app2>0) and -,(app=2 and app2=2) and -,(app=4 and app2=4)
then 120 else 32);
writelines(1);
write(out,markb,1);
writestate(out,L2,n2,l2,J2);
write(out,string lay,A,f);
if line then write(out,"sp",1,string lay,S);
write(out,if abs lambda< 100 then << -ddd.dd> else
if abs lambda<1000 then << -ddd.d> else
if abs lambda< '6 then << -dddddd> else
if lambda< '10 then << -ddd'+d> else
<< -dd'+dd>,
lambda,markf,1,string lay3,
b);
write(out,string lay3,100-abs canc);
end;
end writeoffline;
procedure writeofflinetext(trans);
value trans; integer trans;
if trans>0 and l>=llmin then begin
boolean markb,markf;
markf:=markb:="sp";
writelines(1);
if notext then write(out,<:to :>,"sp",
if finestruct then 9 else 4,<:A:>,
"sp",8,<:f:>,"sp",4) else
write(out,<:to :>,"sp",if finestruct then 5 else 0,<:A(decay):>,
"sp",2,<:f(abs):>,"sp",1);
if line and notext then write(out,"sp",5,<:S:>,"sp",4) else
if line then write(out,"sp",3,<:S(line):>,"sp",0);
if notext then write(out,"sp",2,<:lambda:>,"sp",2,markf,1,"sp",1,<:b:>,
"sp",3,<:c:>) else
write(out,"sp",1,<:lambda Å:>,"sp",1,markf,1,<:b<37>:>,"sp",2,<:c<37>:>);
end writeofflinetext;
procedure writetauline(trans,cutcase,app,tau);
value trans,cutcase,app,tau;
integer trans,cutcase,app;
real tau;
begin
boolean tprint,markb,markf;
tprint:=(abs tau>smallreal or (nuitr=0
and computed)) and l>=llmin and -,list;
if lines+trans+(if tprint then 6 else 4)>=maxlines then
writepage(cores,parterm,tablenr);
if cores<>coresold or Z<>Zold then
writetablehead(cores,parterm,tablenr);
if tprint then
begin
markb:="sp";
markf:=false add (if app>0 then 120 else 32);
writelines(2);
write(out,if notext then <: :> else <:state:>,
"sp",if finestruct then 5 else 0);
if abs tau<smallreal then write(out,"sp",8) else
if notext then write(out,"sp",3,<:t:>,"sp",4) else
write(out,"sp",3,if tau<1 then <:t(ps):> else <:t(ns):>);
if -,notext and tau<1 then tau:=1000*tau;
if Ip>0 then write(out,"sp",2,
if notext then <: E :> else <:E(cm-1):>);
if publish then write(out,"sp",3,<:n*:>,"sp",2) else
write(out,"sp",3,<:n*:>,"sp",2);
if nocase then write(out,"sp",7,<:cut:>) else
if nuitr=0 then write(out,case cutcase+1 of (
<: no:>,<: min:>,<: max:>,<: div:>,<: zero:>,
<:n*<l+1:>,<: error:>,<: exact:>),"sp",1,<:cut:>);
markb:=false add (if cutcase=5 then 42 else 32);
writelines(1);
write(out,markb,1);
writestate(out,L,n,l,J);
if abs tau<smallreal then write(out,"sp",9) else write(out,
if tau>1 and tau <10 then << -d.ddd> else
if tau>1 and tau< 100 then << -dd.dd> else
if tau>1 and tau<10000 then << -dddd.d> else
if tau>=10000 and tau<'8 then << -ddddddd> else
if tau>='8 then <<-d.dd'+dd> else
if tau>=.1 then << -d.ddd> else
if tau>=.01 then << -d.dddd> else
if tau>=.001 then << -d.ddddd> else
<<-d.ddd'+d>,tau);
if Ip>0 and Ecm<.01 then write(out,"sp",4,<:0:>,"sp",5) else
if Ip>0 then write(out,if Ecm>='6 then << dddddddd> else
if Ecm>='5 then << dddddd.d> else << ddddd.dd>,
Ecm,markf,1);
write(out,"sp",if Ip>0 then 1 else 2,<<dd.ddd>,nstar);
if nuitr=0 then
write(out,"sp",3,<<dd.ddd>,cut);
end tprint;
coresold:=cores;
end writetauline;
initrydfile(bsname(1) shift 24, real <:dip:>,segdes.dipsize,true);
for i:=1,2 do bsdipname(i):=segdes.dipname(i);
lay:=real <<-d.ddd'+d>;
prkey:=false;
lay3:=real <<-ddd>;
keystat:=lookupentry(<:ryprkey:>)=0;
prkey:=prkey or keystat;
if prkey then write(out,"ff",1,<:printing of branching ratios:>,"nl",2);
begin
integer array dipval(1:
if chargestate(7)=0 then 1 else chargestate(7)*diprecsize//2);
getalldipval(bsdipname,dipval);
algol list.off copy.allstatel;
if prkey then write(out,"nl",1,<:trans :>,trans);
if computed then writetauline(trans,cutcase,app,tau);
if computed and trans>0 then
begin
if cores=0 then coresold:=0;
if prkey then
begin
write(out,"nl",2,<:dipole record for :>);
writestate(out,L,n,l,J);
write(out,"sp",4,<:trans :>,trans);
for i:=0 step 1 until trans-1 do writediprec(dipval,tottrans+i);
end prkey;
if prkey then
begin
write(out,"nl",1);
writestate(out,L,n,l,J);
write(out,<: n* :>,nstar);
end;
writeofflinetext(trans);
algol list.off copy.allstatel2;
if prkey then
begin
write(out,"nl",1,"*",1);
writestate(out,L,n,l,J);
write(out,"sp",1);
writestate(out,L,n2,l2,J2);
end;
writeoffline(A,osc,Sl,lambda,b,c,app,cutcase,app2,cutcase2);
end; tottrans:=tottrans+1; end allstateloop2;
end computed;
end end stateloop
end dipval;
end printosc;
▶EOF◀