|
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: 20736 (0x5100) Types: TextFile Names: »rydgen1txt«
└─⟦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⟧
;ali time.200 lines.2500 (mode list.yes o allist lookup rydgen1txt rydgen1=set 200 disc3 scope day rydgen1 kjh=lookup alutproc ryproc rydseg rydstruct ryglobal, statevar stateloop ionloop coreproc if ok.no extract from.crypr alutproc ryproc rydseg rydstruct ryglobal , statevar stateloop ionloop coreproc lkj=lookup allstatel if ok.no extract from.crypr allstatel lkj=lookup rydritz if ok.no extract from.cryprog rydritz clear temp lkj lookup rydterm if ok.yes mode 11.yes lookup rydlist if ok.yes mode 15.yes if 11.yes 15.no o rydterm rydgen1=algol blocks.yes o c finisb mode 10.no 15.no list.no) rydgen1 1980-11-10 begin integer i,j,k,inpi,maxseries,maxparents; boolean plus,extendl,linelist,inch, pass1,pass2,pass3,sortlines,fit; array output,FP(1:3),BSi(1:10,1:3); zone out1(128,1,stderror); procedure writeinch(out,l); value l; real l; zone out; if inch and abs l<1200 then begin real k,m,a,sina,d; l:=abs l; k:=87.282; a:=82/180*pi; d:='7/600; m:=1; write(out,"sp",2,<<dd.dd>,k*sqrt(1-((d*sin(a)-m*l)/d)**2)); end writeinch; procedure liststates(bsname,parterm); array bsname; integer array parterm; begin algol list.off copy.statevar; integer lg,trans; boolean first; first:=true; lg:=0; algol list.off copy.stateloop; if first then begin write(out,"nl",2,<:state:>,"sp",10,<:cm-1:>,"sp",8,<:n*:>); if pass2 and -,pass1 then write(out,"sp",8,<:trans:>); first:=false end first; write(out,"nl",if l<>lg and -,first then 2 else 1); lg:=l; writestate(out,L,n,l,J); write(out,<<-dd ddd ddd.ddd>,Ecm,<< dddd.dddddd>,nstar); if pass2 and -,pass1 then begin trans:=gettransno(states,state); write(out,"sp",4,<< ddd>,trans); end; end end end end stateloop; end list states; procedure write_line_list(out,S,series,first,last,state,parterm,inch); value S,first,last,inch; integer S,first,last; boolean inch; integer array series,state,parterm; zone out; begin integer serno,state1,state2,n1,n2,l1,l2,J1,J2,L1,L2, app1,app2,i1,i2,lines,maxlines,z2,lcount; real Ecm,lambda,e1,e2,nstar1,nstar2,Ecm1,Ecm2; boolean test; integer array field ser2; real field lam; integer field s1,s2; integer array field ia; array linelist(1:(if sortlines then chargestate(7)*2 else 0)+1); procedure linesort(lin,no); value no; integer no; array lin; begin array field a1,a2; boolean exchange; integer i,j,k,max; real w; max:=5000; no:=no-1; for k:=1,k+1 while exchange and k<max do begin exchange:=false; for i:=1 step 1 until no do begin a2:=i*8; a1:=a2-8; if lin.a1(2)>lin.a2(2) then begin for j:=1,2 do begin w:=lin.a1(j); lin.a1(j):=lin.a2(j); lin.a2(j):=w; end move; exchange:=true; end -,inorder; end loop states; end k loop if k>=max then write(out,"nl",1,"*",2,<:sorting error k =:>, k,<: records =:>,no+1); end linesort; procedure writeNL; begin if lines mod maxlines<>0 then write(out,"nl",1) else begin if lines>=maxlines then write(out,"ff",1); write(out,"nl",1,"sp",21,<:lambda Å:>,"sp",2); if inch then write(out,"sp",2,<:inch:>); write(out,"nl",1); lines:=lines+2; end; lines:=lines+1; end writeNL; test:=false; lcount:=0; s1:=2; s2:=4; lam:=8; ia:=0; lines:=0; maxlines:=60; ser:=first*seriessize; z2:=chargestate(1)**2; Ip:=getIp(series.ser(4),parterm); write(out,"ff",1,"nl",2,<:Linelist for :>); writeatsym(out,chargestate(2),chargestate(3),chargestate(1)); write(out,"nl",1,<:Ionisation potential :>,<< dddddddddd.dd>,Ip); write(out,"nl",2); writeNL; lines:=lines+4; if test then write(out,"nl",3,<:first :>,first,<: last :>,last); for serno:=first step 1 until last-1 do begin ser:=serno*seriessize; ser2:=ser+seriessize; l1:=series.ser(1); l2:=series.ser2(1); writeNL; if test then write(out,"nl",2,false add ryalf(l1),1, <:-1.state :>,series.ser(2), false add ryalf(l2),1,<:-2. state :>,series.ser(3)); for state1:=series.ser(2) step 1 until series.ser(3) do begin getstate(state,state1,n1,J1,i1,nstar1,Ecm1,L1,app1); e1:=-1/2/nstar1/nstar1; for state2:=series.ser2(2) step 1 until series.ser2(3) do begin getstate(state,state2,n2,J2,i2,nstar2,Ecm2,L2,app2); e2:=-1/2/nstar2/nstar2; lambda:=if abs(e2-e1)>'-11 then '8/(Econv*(e2-e1)*z2) else maxreal; if Jtest(J1,J2,l1,l2,S,nstar2-nstar1) and abs(L2-L1)<=2 and i1+1=i2 and lambda<maxreal then begin if -,sortlines then begin writeNL; writestate(out,L1,n1,l1,J1); write(out,"sp",2); writestate(out,L2,n2,l2,J2); write(out,<< -dddddddddd.dd>,lambda); writeinch(out,lambda); end else begin linelist.ia.s1:=state1; linelist.ia.s2:=state2; linelist.ia.lam:=abs lambda; lcount:=lcount+1; ia:=ia+8; end sortlines; end allowed; end state2; end state1; end series; if sortlines then begin linesort(linelist,lcount); for i:=1 step 1 until lcount do begin ia:=(i-1)*8; state1:=linelist.ia.s1; state2:=linelist.ia.s2; getstate(state,state1,n1,J1,i1,nstar1,Ecm1,L1,app1); ser:=i1*seriessize; l1:=series.ser(1); getstate(state,state2,n2,J2,i2,nstar2,Ecm2,L2,app2); ser2:=i2*seriessize; l2:=series.ser2(1); writeNL; writestate(out,L1,n1,l1,J1); write(out,"sp",2); writestate(out,L2,n2,l2,J2); write(out,<< -ddddddddd.ddd>,linelist.ia.lam); end lcount; end sortlines; end write_line_list; procedure rydgen_pass_1(name); array name; if pass1 then begin integer res,c,char,L,n,l,J,cor,cores,state, charge_states,series_index,stateno,app, stateindex,diptrans,charge_seg_no,diasegm,dipsegm; real Eau,Ecm,nstar; boolean endcond,endion,endstate,b,keystat,segstat,cm1; array bsrefname,bsname(1:3),txt(1:10); integer array tail(1:10); zone ref(128,1,stderror); initrydproc(1,1,1,1); initrydseg; initrydfile(name(1),real <:ref:>,2*Zmax+2,false); for c:=1,2 do bsrefname(c):=segdes.refname(c); cm1:=false; c:=1; open(ref,4,string bsrefname(increase(c)),0); setposition(ref,0,0); connectin(name); for c:=readchar(in,char) while c>6 and char<>59 and char<>25 do; if char= 59 <*;*> then begin if survey then outchar(out,10); outchar(ref,10); for c:=readchar(in,char) while char<>59 and char<>25 do begin if survey then outchar(out,char); outchar(ref,char); end; if survey then outchar(out,10); outchar(ref,10); end; repeatchar(in); for c:=readchar(in,char) while c>6 and char<>25 do; electrons:=1; if char=101 <*electrons*> then read(in,electrons); if electrons<1 or electrons>3 then alarm("nl",1,"*",3,<:electrons:>,electrons); if survey then write(out,"nl",1,<:electrons = :>,electrons); finestruct:=true; repeatchar(in); for c:=readchar(in,char) while c>6 and char<>25 do; if char=102<*finestruct*> then begin for c:=readchar(in,char) while c=6 do; finestruct:=readb(<:finestructure:>); end; initrydproc(electrons,maxstates,maxseries,maxparents); initrydseg; cleararray(chargestate); keystat:=lookupentry(<:keystat:>)=0; segstat:=lookupentry(<:segstat:>)=0; begin integer array series(1:seriesul),parterm(1:parentul), states(1:stateul); cleararray(series); endcond:=endstate:=false; initrydfile(name(1),real <:dat:>,250,false); for c:=1,2 do bsname(c):=segdes.dataname(c); charge_seg_no:=chargesegdes(1):=segdes(3); diasegm:=dipsegm:=0; Z:=0; for chargestates:=1,chargestates+1 while -,endcond and Z<=Zmax do begin diptrans:=0; cleararray(parterm); S:=atno:=Z:=0; repeatchar(in); repion: if -,readatsym(in,S,atno,Z) then write(out,"nl",1,"*",2,<:atom S,atno,Z :>,S,atno,Z); chargestate(1):=Z; chargestate(2):=S; chargestate(3):=atno; if Z<Zmin then begin repeat readstring(in,txt,1); until txt(1)=real <:ion:>; goto repion; end; if Z>=Zmin and Z<=Zmax then begin if chargestates=1 then begin segdes(1):=atno-Z+1; end; segdes(2):=chargestates; if survey then begin write(out,"nl",2); writeatsym(out,S,atno,Z); write(out,"sp",2); end; endion:=false; seriesindex:=stateindex:=0; stateno:=-1; cleararray(states); for cor:=0,cor+1 while -,endion do begin integer array statesinseries(0:maxseries); cores:=cor; cleararray(statesinseries); readcore(in,cores,parterm); Ip:=getIp(cores,parterm); repeatchar(in); if survey then begin write(out,"nl",1); writecore(out,cores,parterm); write(out,<< dd ddd ddd.dd>,Ip); end; for c:=readchar(in,char) while c>6 and char<>59 and char<>25 do; if char=59 <*;*> then begin setposition(ref,0,1+2*Z); outchar(ref,10); if survey then outchar(out,10); for c:=readchar(in,char) while char<>59 and char<>25 do begin if survey then outchar(out,char); outchar(ref,char); end; if survey then outchar(out,10); outchar(ref,10); setposition(ref,0,0); for c:=readchar(in,char) while c>6 and char<>25 do; repeatchar(in); end ; lmax:=0; endstate:=false; for state:=1,state+1 while -, end_state do begin b:=readstate(in,L,n,l,J) and n>0 and n<128 and l<128-1 and l>=0; if list and b then begin write(out,"nl",1); writestate(out,L,n,l,J); end else if -,b then write(out,"nl",1,"*",2,<: state error:>,L,n,l,J); read(in,Ecm); cm1:=cm1 or Ecm=0 or Ecm>100; repeatchar(in); readchar(in,char); if char='n' <*nstar values*> then cm1:=false; if -,cm1 then Ecm:=Ip-Econv/2*Z*Z/Ecm/Ecm; app:= if char= 'f' <*fitted *> then 1 else if char= 'e' <*extended *> then 2 else if char= '*' or char = 'n' <*interpol *> then 3 else if char= '!' <*extrapol *> then 4 else 0; Eau:=(-Ip+Ecm)/Econv; if Eau>0 then begin write(out,"nl",1); if -,list then writestate(out,L,n,l,J); write(out,<< ddddddddd.dd>,Ecm,<: Ecm>Ip :>); end else begin nstar:=Z*sqrt(-1/2/Eau); if nstar<=nsmax and n<=nmax and l//2<=nmax-1 then begin if l>lmax then lmax:=l; states_in_series(l//2):=states_in_series(l//2)+1; stateno:=stateno+1; if stateno> maxstates then alarm("nl",1,"*",3,<:statenumber :>,stateno); putstate(states,stateno,n,J,seriesindex+l//2,nstar,Ecm,L,app); end nstar<nstar max; if list then begin write(out,<< dddddddddd.ddd>,Ecm,"sp",4, <<ddd.dddd>,nstar); if nstar<=nsmax then write(out,"sp",2,"*",1); end listing; end; for c:=readchar(in,char) while char=32 or char=10 do; repeatchar(in); if char>96 then begin <*test some end condition*> readstring(in,txt,1); end_cond:=txt(1)=real <:end:>; endion:=end_cond or txt(1)=real <:ion:>; if -,endion then write(out,"*",2,<: syntax end :>, string inc(txt)); end test end_states else if char= 60 <* < *> then end_state:=true; endstate:=endstate or endion or endcond; end read states; pardes:=cores*parentsize; parterm.pardes(4):=seriesindex; parterm.pardes(5):=seriesindex+lmax//2; parterm.pardes(6):=S; parterm.pardes(9):=stateindex; parterm.pardes(10):=stateno; k:=stateindex-1; for l:=0 step 2 until lmax do begin ser:=(seriesindex+l//2)*seriessize; series.ser(1):=l; series.ser(2):=k+1; series.ser(3):=k+states_in_series(l//2); series.ser(4):=cores; k:=k+states_in_series(l//2); if keystat then write(out,"nl",1,false add ryalf(l),1,<:-from :>,<<d>,series.ser(2), <: to :>,series.ser(3),<: coreno = :>,cores); end l; for l:=0 step 2 until lmax do begin if fit then begin <*rydberg ritz fit*> integer jta,jtno,i,st,l2,serno; boolean found; integer array jtab(1:5); boolean array nofit(1:nmax,1:5); array E,ns(1:nmax,1:5),Ef,nsf(1:nmax); jtno:=0; for jta:=1 step 1 until 5 do for i:=1 step 1 until nmax do begin nofit(i,jta):=false; E(i,jta):=ns(i,jta):=0; end init E,ns; for i:=1 step 1 until 5 do jtab(i):=-128; for st:=stateindex step 1 until stateno do begin getstate(states,st,n,J,serno,nstar,Ecm,L,app); ser:=serno*seriessize; l2:=series.ser(1); if l=l2 then begin jta:=0; found:=false; repeat jta:=jta+1; if jtab(jta)=J or jta>jtno then begin nofit(n,jta):=true; E(n,jta):=(-Ip+Ecm)/Econv; ns(n,jta):=nstar; found:=true; if jta>jtno then begin jtno:=jta; jtab(jta):=J; end; end; until found; end l=l2; end state; for jta:=1 step 1 until jtno do begin J:=jtab(jta); for i:=1 step 1 until nmax do begin Ef(i):=E(i,jta); nsf(i):=ns(i,jta); end move; rydritz(Ef,nsf,nmin,nmax,L,l,jtab(jta),Z); for i:=1 step 1 until nmax do begin if nsf(i)>0 and -,nofit(i,jta) then begin app:=1 <*fitted*>; Ecm:=Ef(i)*Econv+Ip; stateno:=stateno+1; statesinseries(l//2):=statesinseries(l//2)+1; if stateno>maxstates then alarm("nl",1,"*",3, <:statenumber :>,stateno); putstate(states,stateno,i,J,seriesindex+l//2,nsf(i),Ecm,L,app); if list then begin write(out,"nl",1); writestate(out,L,i,l,jtab(jta)); write(out,<< dddddddddd.ddd>,Ecm,"sp",4, <<ddd.ddd>,nsf(i)); if nstar<nmax then write(out,"sp",2,"*",1); end list; end inserted; end nmax loop; end jta; end fit; end; k:=stateindex-1; for l:=0 step 2 until lmax do begin ser:=(seriesindex+l//2)*seriessize; series.ser(2):=k+1; k:=k+states_in_series(l//2); series.ser(3):=k; end update; sortstates(states,stateindex,stateno); diptrans:=diptrans+ dip_trans_parent(S,series,seriesindex,seriesindex+lmax//2,states,parterm); parterm.pardes(11):=diptrans; parterm.pardes(12):=0; stateindex:=stateno+1; seriesindex:=seriesindex+lmax//2+1; end parent; chargestate(4):=cores; chargestate(5):=seriesindex; chargestate(6):=stateno; chargestate(7):=diptrans; chargestate(8):=chargestate(8)+cores+1; chargestate(9):=chargestate(9)+seriesindex+1; chargestate(10):=chargestate(10)+stateno+1; chargestate(11):=chargestate(11)+diptrans; chargestate(12):=if finestruct then -1 else 0; chargestate(18):=chargestates; chargestate(19):=electrons; chargesegdes(9):=diasegm; chargesegdes(11):=dipsegm; diasegm:=diasegm+(stateno+1)/(512//diarecsize)+1; dipsegm:=dipsegm+diptrans/(512//diprecsize)+1; chargesegdes(10):=diasegm-1; chargesegdes(12):=dipsegm-1; if keystat then write(out,"nl",2,<:no of states :>,stateno+1); charge_segno:=chargesegdes(1); if segstat then write(out,"nl",1,<:first segment parent :>,charge_seg_no, "nl",1,<:parents :>,cores+1,"nl",1,<:size :>,parentsize); if survey then begin write(out,"sp",6); for i:=0 step 1 until cores do writecore(out,i,parterm); end survey; charge_segno:=chargesegdes(2):= putstruct(bsname,parterm,0,cores, parentsize,chargesegdes(1)); chargesegdes(3):=chargesegdes(2)+1; charge_seg_no:=chargesegdes(3); if segstat then write(out,"nl",1,<:first segment series :>,charge_seg_no, "nl",1,<:series :>,seriesindex+1,"nl",1,<:size :>,seriessize); chargesegdes(4):= putstruct(bsname,series,0,seriesindex,seriessize,chargesegdes(3)); chargesegdes(5):=chargesegdes(4)+1; charge_seg_no:=chargesegdes(5); if segstat then write(out,"nl",1,<:first segment states :>,charge_seg_no, "nl",1,<:states :>,stateno+1,"nl",1,<:size :>,statesize); chargesegdes(6):= putstruct(bsname,states,0,stateno,statesize,chargesegdes(5)); charge_seg_no:=chargesegdes(6)+1; putstruct(bsname,chargestate,2*chargestates-2,2*chargestates-2,chargesize,1); putstruct(bsname,chargesegdes,2*chargestates-1,2*chargestates-1,chargerecsize,1); chargesegdes(1):=chargesegno; segdes(2):=segdes(4):=chargestates; putstruct(bsname,segdes,0,0,segdesrecsize,0); if segstat then begin write(out,"nl",2,<:segment description:>); writerec(out,segdes,0,0,segdesrecsize); write(out,"nl",2,<:charge segment description:>); writerec(out,chargesegdes,0,0,chargerecsize); end segstat; if keystat then writechargerec(out); end Z>=Zmin and Z<=Zmax; end chargestate; end array block; segdes.datasize:=chargesegno+1; segdes.diasize:=diasegm; segdes.dipsize:=dipsegm; cleararray(tail); tail(1):=chargesegno+1; res:=changetail(bsname,tail); if res<>0 then alarm("nl",1,"*",3,<:cut of :>,string inc(bsname),res); if true then write(out,"nl",3,<:dat segments :>,chargesegno+1, "nl",1,<:dia segments :>,diasegm, "nl",1,<:dip segments :>,dipsegm); putstruct(bsname,segdes,0,0,segdesrecsize,0); disconnectin; end rydgen pass 1; integer procedure dip_trans_parent(S,series,first,last,state,parterm); value S,first,last; integer S,first,last; integer array series,state,parterm; begin integer serno,state1,state2,n1,n2,l1,l2,J1,J2,L1,L2, app1,app2,i1,i2,trans,trans_s,seriestrans; real e1,e2,nstar1,nstar2,Ecm1,Ecm2; boolean test; integer array field ser2; test:=false; if test then write(out,"nl",3,<:calculation of dipole transitions:>, "nl",1,<:first :>,first,<: last :>,last); trans:=0; for serno:=first step 1 until last-1 do begin seriestrans:=0; ser:=serno*seriessize; l1:=series.ser(1); if test then write(out,"nl",2, <:1.state :>,series.ser(2),<: 2. state :>,series.ser(3)); for state1:=series.ser(2) step 1 until series.ser(3) do begin getstate(state,state1,n1,J1,i1,nstar1,Ecm1,L1,app1); if serno<>i1 then write(out,"nl",1,"*",2,<:wrong seriesindex :>, serno,i1); trans_s:=0; if test then begin write(out,"nl",1); writestate(out,L1,n1,l1,J1); end; ser2:=(i1+1)*seriessize; for state2:=series.ser2(2) step 1 until series.ser2(3) do begin getstate(state,state2,n2,J2,i2,nstar2,Ecm2,L2,app2); if i2<>i1+1 then write(out,"nl",1,<:wrong 2. seriesindex:>, i1+1,i2); l2:=series.ser2(1); if Jtest(J1,J2,l1,l2,S,nstar2-nstar1) and abs(L2-L1)<=2 and i1+1=i2 then begin trans_s:=trans_s+1; trans:=trans+1; end allowed; end state2; if test then write(out,"sp",3,<:trans:>,trans,transs); put_trans_no(state,state1,trans_s); seriestrans:=seriestrans+transs; end state1; series.ser(5):=seriestrans; if test then write(out,"nl",1,<:transitions from :>, false add ryalf(series.ser(1)),1,seriestrans); end series; dip_trans_parent:=trans; if test then write(out,"nl",1,<:transitions :>,trans); end dip_transparent; procedure rydgen_pass_2(name); array name; if pass2 then begin algol list.off copy.statevar; algol list.off copy.ionloop; if list then liststates(bsname,parterm); if linelist then begin integer array series(1:seriesul),states(1:stateul); getstruct(bsname,series,0,chargestate(5),seriessize,chargesegdes(3)); getstruct(bsname,states,0,chargestate(6),statesize,chargesegdes(5)); pardes:=0; writelinelist(out,S, series,parterm.pardes(4),parterm.pardes(5),states,parterm,inch); end linelist; end end end ionloop; end rydgen pass 2; procedure rydgen_pass_3(name); array name; if pass3 then begin integer cut; algol list.off copy.statevar; algol list.off copy.ionloop; algol list.off copy.stateloop; end state; end state array; end series; end parent; end parent and series array; end Z; end declarations; end rydgen_pass_3; algol copy.rydritz; algol list.off copy.alutproc; algol list.off copy.rydstruct; algol list.off copy.rydseg; algol list.off copy.coreproc; algol list.off copy.ryproc <*lsproc*>; algol list.off copy.ryglobal; plus:=false add 43; readifp(<:maxstates:>,maxstates ,250); readifp(<:maxseries:>,maxseries,25); readifp(<:maxparents:>,maxparents,3); packtext(output,<: unknown:>); cleararray(BSi); if readlsfp(output) then begin i:=lookupentry(output); if i<>0 then alarm(<:***left side area :>,string inc(output),i); open(out1,4,string inc(output),0); end; readbfp(<:fit:>,fit,false); readbfp(<:extendl:>,extendl,extendl); readbfp(<:linelist:>,linelist,false); readbfp(<:sort:>,sortlines,false); readbfp(<:inch:>,inch,false); linelist:=linelist or inch or sortlines; readbfp(<:pass1:>,pass1,true); readbfp(<:pass2:>,pass2,-,pass1); readbfp(<:pass3:>,pass3,false); for i:=1 step 1 until fpinareas do begin readinfp(FP,i); for k:=1,2 do BSi(i,k):=FP(k); end; connectlso; for inpi:=1 step 1 until fpinareas do begin for i:=1,2 do FP(i):=BSi(inpi,i); rydgen_pass_1(FP); rydgen_pass_2(FP); rydgen_pass_3(FP); end for inputarea; if fpout then closeout; end ▶EOF◀