DataMuseum.dk

top - metrics - download

    Length: 5376 (0x1500)
    Types: TextFile
    Names: »algstark«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦7e928b248⟧ »algbib« 
            └─⟦this⟧ 

TextFile

;gosav 
stark=set 45
permanent stark.17
stark=algol index.no list.no
\f





STARK PERTURBATION
GOS:  13-3-73.

begin
integer i,j,k,m,mc,s,s0,t,J1,J,k1,k2,Jm,N;
real F,Fc,Cmax,w,dw,a,b,c,d,e;
boolean nl, sp, bu, bl, Q, cpl, closeres;
integer array qtn(1:7);
array head(1:12), name(1:2), my,Acoef,Bcoef(1:3);
zone res(128,1,stderror), L(128*2,2,stderror);
readhead(in,head,1);  readhead(in,name,1);
closeres:= outmedium(res);
read(in,my,N); cpl:= N<0; N:= abs N;  i:= 1;
open(L,4,string name(increase(i)),0);
sp:= false add 32; nl:= false add 10; J1:= 100;

for N:=N-1 while N>=0 do begin
i:= 1;
write(res,<:<12>:>,nl,3,string head(increase(i)), nl,2,
      <:Dipolkomposanter::>,<<  d.dddd>,
      my(1),my(2),my(3),<:  Debye.:>);
Jm:= 0; write(res,nl,3,<:Transition::>,sp,5);
for j:=1,2 do begin
   read(in,J,k1,k2); write(res,sp,2,<<ddd>,J,k1,k2);
   if Jm<J then begin m:= Jm; Jm:= J end else m:= J;
   qtn(j):=  J shift 8 add k1 shift 8 add k2
end;
for j:=3,j+1 while t<>10 and j<=7 do begin
   read(in,F); qtn(j):= round (F*1000);
   repeatchar(in); readchar(in,t)
end;
for j:=j step 1 until 7 do qtn(j):= 0;
rep: if t<>10 then
begin readchar(in,t); goto rep end;
Q:= m=Jm;  if m<J1+1 then begin
   setposition(L,0,0); k:= 0; inrec(L,128); e:= L(1)
end;
if cpl then write(res,nl,1,<:
Couplings used,               largest deg. corr. (F,M).:>,nl,1);

begin
array displ(1:Jm,1:5);
for i:=1 step 1 until Jm do
for j:=1 step 1 until  5 do displ(i,j):= 0;
for i:=1 step 1 until  3 do Acoef(i):= Bcoef(i):= 0;
repeat:  Cmax:= 0; s0:= 0;
for j:=1,2 do begin
   t:= qtn(j);
   s:= if t = e shift (-24) extract 24 then -1 else
       if t = e extract 24 then 1 else 0;
   if s<>0 then begin
      k1:= (e shift (-32) extract 8)-(e shift (-8) extract 8);
      k2:= (e shift (-24) extract 8)-(e extract 8);
      bu:= k1 = k1//2*2;  bl:= k2 = k2//2*2;
      t:= if   bu and -,bl then 1 else
          if -,bu and -,bl then 2 else
          if -,bu and   bl then 3 else 0;
      if t=0 then goto stop;
      if my(t)>0 then begin
         J1:= e shift (-40) extract 8;
         J := e shift (-16) extract 8;
         if cpl then
         write(res,nl,1,<<ddd>,J1,e shift (-32) extract 8,
         e shift (-24) extract 8,sp,2,J,e shift (-8) extract 8,
         e extract 8,sp,3,<<-dddddd.dd>,L(k+2)) else
         if abs s0=1 then write(res,<<__ddd ddd.dd>,L(k+2))
         else s0:= s;
         if j=1 then s:= -s;
         b:= L(k+3)*0.06336397;  d:= L(k+2)*s;
         if J1=J then a:= 0 else
         begin a:= b*J*J;  b:= -b end;
         Acoef(t):= Acoef(t) + a/d;
         Bcoef(t):= Bcoef(t) + b/d;
         for i:=1 step 1 until 5 do begin
         F:= qtn(i+2)/1000; if F>0 then begin
         for k1:=1 step 1 until Jm do begin
         m:= if Q then k1 else k1-1;
         c:= (a + b*m*m)*(my(t)*F)**2;
         bu:= c*c>(d*d+c)*abs d*0.0001; dw:= c/d;
         if bu then begin
            w:= (c+c)/(d + sign(d)*sqrt(d*d+4*c));
            dw:= w-dw; if abs dw > abs Cmax then begin
               mc:= m; Fc:= F; Cmax:= dw end
         end else w:= dw;
         displ(k1,i):= displ(k1,i) + w
         end end end;
         if Cmax<>0 and cpl then write(res,sp,4,<<-ddd.ddd>,
         Cmax,<: (:>,<<dddd.d>,Fc,<:,:>,<<dd>,mc,<:):>)
end end end;
k:= (k+3) mod 126; if k=0 then inrec(L,128);
e:= L(k+1); J1:= e shift (-16) extract 8;
if J1>=0 and J1<=Jm+1 then goto repeat;

write(res,nl,2,<:Coeff. for:>,sp,5);
for t:=1,2,3 do begin
   if my(t)>0 then write(res,sp,5,<:(F*my:>,
      case t of (<:A:>,<:B:>,<:C:>),<:)**2:>)
end;
write(res,nl,1,<:    A =:>,sp,8);
for t:=1,2,3 do if my(t)>0 then
write(res,sp,4,<<-d.ddddd'-d>,Acoef(t));
write(res,nl,1,<:    B =:>,sp,8);
for t:=1,2,3 do if my(t)>0 then
write(res,sp,4,<<-d.ddddd'-d>,Bcoef(t));
write(res,nl,1,<:    M:>);
for i:=1 step 1 until Jm do begin
   m:= if Q then i else i-1;
   write(res,nl,1,<<ddddd>,m,sp,10);
   for t:=1,2,3 do if my(t)>0 then
   write(res,sp,4,<<-d.ddddd'-d>,Acoef(t)+Bcoef(t)*m*m);
end i;
write(res,nl,2,<:Stark shifts in MHz:>,nl,1,<:  M   F = :>);
for j:=1 step 1 until 5 do if qtn(j+2)>0 then
write(res,sp,4,<<dddd.d>,qtn(j+2)/1000);
for i:=1 step 1 until Jm do begin
   m:= if Q then i else i-1;
   write(res,nl,1,<<ddd>,m,sp,7);
   for j:=1 step 1 until 5 do if qtn(j+2)>0 then begin
      d:= 0; for t:=1,2,3 do
      d:= d + (Acoef(t)+Bcoef(t)*m*m)*my(t)**2;
      write(res,sp,2,<<-dddd.dd>,d*(qtn(j+2)/1000)**2)
end end;
write(res,nl,2,<:Stark shifts in MHz (corr. for near deg.):>,
      nl,1,<:  M   F = :>);
for j:=1 step 1 until 5 do if qtn(j+2)>0 then
write(res,sp,4,<<dddd.d>,qtn(j+2)/1000);
for i:=1 step 1 until Jm do begin
   m:= if Q then i else i-1;
   write(res,nl,1,<<ddd>,m,sp,7);
   for j:=1 step 1 until 5 do if qtn(j+2)>0 then
   write(res,sp,2,<<-dddd.dd>,displ(i,j))
end;
end end N;
stop:   write(res,<:<12><25>:>);   close(res,closeres)
end
▶EOF◀