DataMuseum.dk

top - metrics - download

    Length: 9216 (0x2400)
    Types: TextFile
    Names: »ryproc«

└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
    └─⟦b2ec5d50f⟧ 
        └─⟦7b6e66aaa⟧ »crypr« 
            └─⟦this⟧ 
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦84e44a383⟧ »crypr« 
            └─⟦this⟧ 

TextFile

comment ls-type procedures
  Jtest
  readstate
  writestate
  lexi
  ryalf
  atsym
  atnumber
  readatsym
  writeatsym
  readmul
  writemul
  readJ
  readl
  readnl
  readSL
  writeSL
  SLSM
1980-11-24
;
own boolean finestruct,parentterm;

boolean procedure Jtest(J1,J2,l1,l2,S,de);
value J1,J2,l1,l2,S,de; integer J1,J2,l1,l2,S;
real de;
Jtest:=abs (l2-l1)=2 and
      (if J1=-1 and J2=-1 then true else
       if J2=-1 and de>0 then abs(l2+S-J1)=2 else
       if J2=-1 then l2-S-2<=J1 and J1<=l2+S+2 else
       if J1=-1 and de<0 then abs(J2-l1-S)=2 else
       if J1=-1 then l1-S-2<=J2 and J2<=l1+S+2 else
       abs(J2-J1)<=2);

boolean procedure readstate(in,L,n,l,J);
integer L,n,l,J;
zone in;
begin
  integer s,i,ii,c,char;
  readstate:=true;
  s:=ii:=0;
  repeatchar(in);
  for c:=readchar(in,char) while char<48 and char<>25 do;
  repeatchar(in);
  J:=-1;
  L:=if char>67 and char<93 then ryalf(char) else -1;
  readchar(in,char);
  if char=95 then
  begin
    read(in,ii);
    repeatchar(in);
    readchar(in,char);
    if char=47 then
    begin
      read(in,i);
      ii:=ii//2;
    end /;
    J:=ii;
  end J;
  repeatchar(in);
  i:=read(in,n);
  if i=0 and n<=0 then readstate:=false else begin
    repeatchar(in); readchar(in,l);
    l:=ryalf(l);
    if l>=127 then readstate:=false else begin
      repeatchar(in);
    for ii:=readchar(in,s) while ii<>2 and ii<>3 and s<>32 and
       s<>10 do;
      if s>=48 and s<=48+10 then begin
        repeatchar(in); read(in,s);
        repeatchar(in); readchar(in,i);
        if i=47 then
        begin
         readchar(in,ii);
         J:=s;
        end else J:=2*s;
      end J;
    end l value read;
  end n value read;
if parentterm and L<0 then L:=l;
<*
if n<1 or n=maxinteger then write(out,star,2,<:n-value :>,n) else
if L>=0 and (J<abs(L-S) or J>L+S) then write(out,star,2,<:L-value :>,L) else
if J>=0 and (J<abs(l-S) or J>l+S) then 
write(out,star,2,<:l-value :>,l,S,J,"sp",2);
*>
end readstate;

integer procedure writestate(z,L,n,l,J);
value L,n,l,J; integer L,n,l,J;
zone z;
begin
integer char;
if -,finestruct then begin J:=-1; end;
if -,parentterm then L:=-1;
char:=0;
  if L>=0 then char:=write(z,false add ryalf(L+256),1,
     "sp",if J>=0 then 0 else 1) else
  char:=write(z,<<bd>,n,false add ryalf(l),1);
  if J>=0 then begin
  char:=char+write(z,false add 95,1);
  if J mod 2=1 then char:=char+write(z,<<d>,J,<:/2 :>) else
    char:=char+write(z,<<d>,J//2,<:   :>);
  end;
if L>=0 then char:=char+write(z,<<bd>,n,false add ryalf(l),1);
if finestruct and J=-1 then char:=char+write(out,"sp",5);
writestate:=char;
end writestate;

integer procedure ryalf(l);
value l; integer l;
begin
integer i,j,val;
boolean L;
L:=l>=256 or (l>67 and l<94);
if l>=256 then l:=l-256;
if l>67 and l<94 then l:=l+32;
if l<47 then l:=l//2;
if l<3 then val:=case l+1 of(115,112,100) else
if l<7 then val:=l+102-3 else
if l<12 then val:=l+102-2 else
if l<14 then val:=l+102-1 else
if l<23 then val:=l+102-0 else
if l>=100 and l<=127 then 
  begin
  j:=-1;
  for i:=1,2,3 do begin if l=(case i of (115,112,100)) then j:=i-1; end;
  l:=l-102+3;
  if j=-1 then j:=l;
  if j>6 then j:=j-1;
  if j>12 then j:=j-1;
  if j>14 then j:=j-1;
 val:=2*j;
  end else val:=127;
ryalf:=val-(if L and val>99 and val<127 then 32 else 0);
end ryalf;

integer procedure atnumber(atsym);
value atsym; real atsym;
begin
integer i;
atnumber:=0;
for i:=1 step 1 until 95 do
if atsym=real (case i of(
<:H:>,<:He:>,<:Li:>,<:Be:>,<:B:>,<:C:>,<:N:>,<:O:>,<:F:>,<:Ne:>,
<:Na:>,<:Mg:>,<:Al:>,<:Si:>,<:P:>,<:S:>,<:Cl:>,<:A:>,<:K:>,<:Ca:>,
<:Sc:>,<:Ti:>,<:V:>,<:Cr:>,<:Mn:>,<:Fe:>,<:Co:>,<:Ni:>,<:Cu:>,<:Zn:>,
<:Ga:>,<:Ge:>,<:As:>,<:Se:>,<:Br:>,<:Kr:>,<:Rb:>,<:Sr:>,<:Y:>,<:Zr:>,
<:Nb:>,<:Mo:>,<:Tc:>,<:Ru:>,<:Rh:>,<:Pd:>,<:Ag:>,<:Cd:>,<:In:>,<:Sn:>,<:Sb:>,
<:Te:>,<:I:>,<:Xe:>,<:Cs:>,<:Ba:>,<:La:>,<:Ce:>,<:Pr:>,<:Nd:>,<:Pm:>,<:Sm:>,
<:Eu:>,<:Gd:>,<:Tb:>,<:Dy:>,<:Ho:>,<:Er:>,<:Tm:>,<:Yb:>,<:Lu:>,<:Hf:>,<:Ta:>,
<:W:>,<:Re:>,<:Os:>,<:Ir:>,<:Pt:>,<:Au:>,<:Hg:>,<:Tl:>,<:Pb:>,<:Bi:>,<:Po:>,
<:At:>,<:Rn:>,<:Fr:>,<:Ra:>,<:Ac:>,<:Th:>,<:Pa:>,<:U:>,<:Np:>,<:Pu:>,<:Am:>,
<:Cm:>)) then atnumber:=i;
end;

real procedure atsym(atno);
value atno; integer atno;
atsym:=real (case atno +1 of(<:atom:>,
<:H:>,<:He:>,<:Li:>,<:Be:>,<:B:>,<:C:>,<:N:>,<:O:>,<:F:>,<:Ne:>,
<:Na:>,<:Mg:>,<:Al:>,<:Si:>,<:P:>,<:S:>,<:Cl:>,<:A:>,<:K:>,<:Ca:>,
<:Sc:>,<:Ti:>,<:V:>,<:Cr:>,<:Mn:>,<:Fe:>,<:Co:>,<:Ni:>,<:Cu:>,<:Zn:>,
<:Ga:>,<:Ge:>,<:As:>,<:Se:>,<:Br:>,<:Kr:>,<:Rb:>,<:Sr:>,<:Y:>,<:Zr:>,
<:Nb:>,<:Mo:>,<:Tc:>,<:Ru:>,<:Rh:>,<:Pd:>,<:Ag:>,<:Cd:>,<:In:>,<:Sn:>,<:Sb:>,
<:Te:>,<:I:>,<:Xe:>,<:Cs:>,<:Ba:>,<:La:>,<:Ce:>,<:Pr:>,<:Nd:>,<:Pm:>,<:Sm:>,
<:Eu:>,<:Gd:>,<:Tb:>,<:Dy:>,<:Ho:>,<:Er:>,<:Tm:>,<:Yb:>,<:Lu:>,<:Hf:>,<:Ta:>,
<:W:>,<:Re:>,<:Os:>,<:Ir:>,<:Pt:>,<:Au:>,<:Hg:>,<:Tl:>,<:Pb:>,<:Bi:>,<:Po:>,
<:At:>,<:Rn:>,<:Fr:>,<:Ra:>,<:Ac:>,<:Th:>,<:Pa:>,<:U:>,<:Np:>,<:Pu:>,<:Am:>,
<:Cm:>));


integer procedure readmul(z);
zone z;
begin
array mul(1:3);
integer i,j;
readstring(z,mul,1);
j:=0;
for i:=1 step 1 until 9 do begin
  if mul(1) shift (-8)=(real (case i of(<::>,
  <:singl:>,<:doubl:>,<:tripl:>,
  <:quart:>,<:pente:>,<:sexte:>,
  <:hepte:>,<:octet:>))) shift (-8) then j:=i;
  end;
readmul:=j-1;
end;

integer procedure writemul(z,mul);
value mul; integer mul;
zone z;
begin
writemul:=write(z,case mul+1 of (<::>,
  <:singlet:>,<:doublet:>,<:triplet:>,<:quartet:>,
  <:pentet:>,<:sextet:>,<:heptet:>,
  <:octet:>,<:nonet:>));
end;

boolean procedure readatsym(z,S,atno,Z);
integer S,atno,Z;
zone z;
begin
integer c,char;
array s(1:6);
readatsym:=true;
repeatchar(z);
for c:=readchar(z,char) while char<>25 and c<>2 do;
if c=2 then 
begin
  repeatchar(z);
  read(z,S); S:=S-1;
  repeatchar(in);
  readstring(z,s,1);
  atno:=atnumber(s(1));
  Z:=readroman(z);
  readatsym:=atno>0 and S>=0 and Z>0;
end;
end readatsym;

integer procedure writeatsym(z,S,atno,Z);
value S,atno,Z; integer S,atno,Z;
zone z;
begin
  writeatsym:=(if S>=0 then write(z,<<d>,S+1) else 0)+
  write(z,"sp",1,string atsym(atno),"sp",1)+
  writeroman(z,Z);
end;

integer procedure readJ(in);
zone in;
begin
integer c,char;
readJ:=-1;
repeatchar(in);
c:=readchar(in,char);
if char=95 then
begin
read(in,c);
repeatchar(in);
readchar(in,char);
if char=47 then
begin
  readchar(in,char);
  if char<>50 then write(out,"nl",1,"*",2,<:J-value :>,c);
  end else c:=c*2;
readJ:=c;
end else repeatchar(in);
end readJ;

integer procedure readl(in);
zone in;
begin
integer c,char;
repeatchar(in);
for c:=readchar(in,char) while c<>6 and char<>25 do;
readl:=if c=6 then ryalf(char) else -1;
end readl;

procedure readnl(in,n,l);
integer n,l;
zone in;
begin
integer c,char;
n:=l:=-1;
repeatchar(in);
for c:=readchar(in,char) while char<>25 and c<>2 do;
if c=2 then
begin
  repeatchar(in);
  read(in,n);
  l:=readl(in);
end;
end readnl;

integer procedure writenl(z,n,l);
value n,l; integer n,l;
zone z;
writenl:=write(z,<<bd>,n,false add ryalf(l),1);

procedure readSL(in,S,L);
integer S,L;
zone in;
begin
integer c,char;
S:=L:=-1;
repeatchar(in);
for c:=readchar(in,char) while char<>25 and c<>2 do;
if c=2 then
begin
  read(in,S); S:=S-1;
  L:=readl(in);
end;
end readSL;

integer procedure writeSL(out,S,L);
value S,L; integer S,L;
zone out;
begin
writeSL:=if parentterm then
  write(out,<<bd>,S+1,false add ryalf(L+256),1) else 0;
end;


comment calculates relative line intensities within
a multiplet;
real procedure SLSM(S,L,J,L2,J2);
value S,L,J,L2,J2; integer S,L,L2,J,J2;
begin
integer fak,La,Ja,dj;
comment 
See Condon and Shortley, The theory of atomic
spectra, Cambridge, Cambridge, 1964, p.238.
or Sobelmann  Introduction to the Theory of Atomic Spectra,
Pergamon Press, Oxford, 1972, p.310-311.
angular momenta is used with twice their value
S is the total spin and is halfintegral.
L is the lower L value (0,1,2,3,4,5...)
L2 is the upper L2 value (0,1,2,3,4,5...)
J is the J value for L, J2 is the J value for L2,
J,J2 is integral or halfintegral;
if S=0 then SLSM:=1 else
if L=0 and L2=0 then SLSM:=1 else
if J=0 and J2=0 then SLSM:=0 else
if abs(L-L2)>2 or (abs(J-J2)>0 and abs(abs(J-J2)-2)>0) then SLSM:=0 else
begin
dj:=J-J2;
if J2>J or (L2>L and dj=0) then
  begin
  Ja:=J; J:=J2; J2:=Ja;
  La:=L; L:=L2; L2:=La;
  dj:=-dj;
  end;
fak:=4*J*(L+1)*(S+1);
SLSM:=
if L=L2 and dj=0 then
  (L*(L+2)+J*(J+2)-S*(S+2))**2*(2*J+2)/fak/L/(L+2)/(J+2)/2 else
if L-2=L2 and dj=0 then 
  (S+L+J+2)*(L+J-S)*(S+L-J)*(S+J-L+2)*(2*J+2)/fak/L/(J+2)/(2*L-2)/2 else
if L=L2 and dj=2 then
  (S+L+J+2)*(L+J-S)*(S+J-L)*(L+S+2-J)/fak/L/(L+2)/2 else
if L-2=L2 and dj=2 then
  (L+S+J)*(L+S+J+2)*(L+J-S-2)*(L+J-S)/fak/(2*L-2)/L/2 else
if L+2=L2 and dj=2 then
  (S+J-L-2)*(S+J-L)*(S+L-J+2)*(S+L-J+4)/fak/(L+2)/(2*L+6)/2 else
-1;
end;
end;
▶EOF◀