⟦96cfebf30⟧

TextFile

\f


<*          rytrans calculation of offdiagonal matrixelements    *>
<*
1979-02-12
*>

procedure rydip_in_parent(bsname,parterm);
array bsname;
integer array parterm;
if chargesegdes(13)<0 and (offdiag  or lifetimes) then
begin comment local block for rydip_in_parent;
integer i,k,ngr,em,sq,n1c,trans,eqfak,icutf,tottrans,lastsegm,dl,
        Lcore,coresold;
real dele,f0,f1,f2,f3,f4,df,del,x,h,hp,w,
      fak,ov,ovl,jd,g,id,osc,A,Sl,lambda,has,sigma,F,
      s1,iint,jint,dovl,dj,di,dh,dhp,
      cutf,cut,ji,jf,gi,gf,slsmval,dpolint,polint;
boolean page1,plb;
array bsdipname(1:2);
algol list.on copy.statevar;
algol list.on copy.statevar2;
integer array field dipi;
array field dipf;
dl:=1; <*dipole allowed matrixelements*>
setrydwhere(<:rydipinp:>,0,0,0,0);
if offdiag then begin
page:=1;
writepage(page,0,parterm);
head(r); writeparam;
n1c:=0;
write(out,nl,2,<:dipole allowed transition matrixelements:>,nl,1);
lin:=lin+3;
end;

initrydfile(bsname(1) shift 24, real <:dip:>,segdes.dipsize,false);
for i:=1,2 do bsdipname(i):=segdes.dipname(i);
tottrans:=0;
keystat:=lookupentry(<:ryoffkey:>)=0;
offkey:=offkey or keystat;
page1:=true;

algol list.on copy.stateloop;
  if cores=0 then coresold:=0;
  computed:=getcomputed(states,state,cutcase,cut);
  trans:=gettransno(states,state);
  if offkey then write(out,nl,1,<:trans :>,trans);
  if computed and trans>0 then
  begin
  array ry1,ry2(1:(segm-1)*128);
  integer array dipval(1:(trans+1)*diprecsize//2);
  cleararray(dipval);
  ncur:=n; lcur:=l; jcur:=J;
  if offkey then
  begin
  write(out,nl,1);
  writestate(out,L,n,l,J);
  write(out,<:  n*  :>,nstar);
  end;
  E:=(-Ip+Ecm)/Econv;
  henta(ryf,(state+stateindex)*segm+1,ry1,segm-1);
  dipf:=-diprecsize;

algol list.on copy.stateloop2;
  if plb then henta(ryf,(state+stateindex)*segm+1,ry1,segm-1);
  cpu:=systime(1,0,time);
  cutf:=if cut>cut2 then cut else cut2;
  if offkey then
  begin
  write(out,nl,1,star,1);
  writestate(out,L,n,l,J);
  write(out,sp,1);
  writestate(out,L,n2,l2,J2);
  write(out,<: cut :>,<<  dd.d0>,cutf,cut,cut2);
  end;
  A:=osc:=Sl:=lambda:=0;
  polint:=hp:=h:=iint:=jint:=ovl:=0;
  if computed2 and n2>=n-njump and n2<=n+njump  and
    abs(l-l2)=2*dl and abs(J-J2)<=2 and abs(L-L2)<=2 then
  begin
  setrydwhere(<:rydipinp:>,n,l,n2,l2);
  operator(false);
  E2:=(-Ip+Ecm2)/Econv;
  dele:=E2-E;
  henta(ryf,(state2+stateindex2)*segm+1,ry2,segm-1);
  fak:=(1.5/(arctan(1)**2))**(1/3);
  em:=if dele>0 then l+1 else l2+1;
NE(-1):=0;
  icut:=cut/del0;
  icut2:=cut2/del0;
  icutf:=cutf/del0;
f0:=f1:=f2:=ry2(NE(q-1));
f3:=ry2(NE(q-1)-1);
for sq:=q-1 step -1 until 0 do
  begin
  del:=DE(sq);
  x:=B(sq+1);
  ngr:=NE(sq-1)+1;
  if ngr<1 then ngr:=1;
  dpolint:=dovl:=dj:=di:=dh:=dhp:=0;
  for k:=NE(sq) step -1 until ngr do
    begin
      f4:=if k>2 then ry2(k-2) else 0;
      g:=if k>0 then ry1(k) else 0;
      ov:=f2*g; dovl:=dovl+ov;
      if hastighed then
      begin
      jd:=ov/x; dj:=dj+jd;
      if k>ngr and abs(k-icut)>3 and abs (k-icut2)>3 then 
       df:=(8*(f3-f1)+f0-f4) else
      if k>icut+2 and k=ngr and k>3 then df:=(8*(f3-f1)+f0-ry2(k-3))
       else df:=0;
      id:=g*df; di:=di+id;
      end hastighed;
      w:=ov*x;
      dh:=dh+w; dhp:=dhp+abs w;
      if polarisation then
      begin
       dpolint:=dpolint+w/(x*x+cutf*cutf)**2;
      end polarisation;
      if plb then begin
        ry1(k):=w;
        if hastighed then ry2(k):=(id+em*jd)/dele
      end;
      f0:=f1; f1:=f2; f2:=f3; f3:=f4;
      x:=x-del;
    end;
    ovl:=ovl+dovl*del;
    jint:=jint+dj*del;
    iint:=iint+di/12;
    h:=h+dh*del;
    hp:=hp+dhp*del;
    polint:=polint+dpolint*del;
end;
comment laye=8,laym=10,layr=8,layr2=10,layr3=15;
if (lin>=maxlines or page1 or cores<>coresold) and offdiag then
begin
  if page1 then page1:=false else
  begin
  writepage(page,cores,parterm);
  write(out,nl,1);
  lin:=10;
  end;
  write(out,<:transition:>);
if finestruct then write(out,sp,10);
  if dip and hastighed then write(out,sp,3,<:<p>/(E2-E1):>,sp,1);
  if dip then write(out,sp,3,<:<r>:>,sp,6);
  if polarisation then write(out,sp,4,<:alfa:>,sp,4);
  if bandd or bandf then write(out,sp,8,<:F:>,sp,6) else
  if sigma2 then write(out,sp,4,<:sigma**2:>,sp,2);
  if dip then write(out,sp,1,<:A(n1,l1;n2,l2):>);
  write(out,sp,5,<:E1-E2:>,sp,2);
  if overl then write(out,sp,3,<:overlap:>,sp,1);
  if cput then write(out,sp,1,<:cpu-time:>);
  if canc then write(out,sp,5,<:<37>:>,sp,2);
coresold:=cores;
end sideoverskrift;
  jint:=jint*Z; iint:=iint*Z;
  h:=h/Z;
  hp:=hp/Z;
  has:=(iint+em*jint);
  if bandd or bandf then F:=(if nstar2<l2//2+'-5 then 0 else
     2*Z/3/nstar2/sqrt(nstar2**2-(l2//2)**2)*h);
  sigma:=h*h/(l2*l2-1);
lambda:='8/Econv/dele;
if lambda>0 then begin
  gi:=l+1; gf:=l2+1;
  ji:=2*gi/(J+1); jf:=2*gf/(J2+1);
  end else begin
  gi:=l2+1; gf:=l+1;
  ji:=2*gi/(J2+1); jf:=2*gf/(J+1);
  end;
gi:=gi*(S+1);
gf:=gf*(S+1);
eqfak:=degenerate(cores,parterm,n,l);
s1:=eqfak*h**2/(l2*l2-1);
Lcore:=parterm.pardes(8);
Sl:=s1*SLSM(Lcore,l,L,l2,L2);
osc:=2/3*dele/gi*Sl;
comment Condon and Shortley p.245;
comment formula 61.2 Bethe and Salpeter;
A:=2/cau**3*dele**2*gi/gf*osc/t0sec*'-8;
A:=abs A;
osc:=abs osc;
if finestruct then begin
  slsmval:=SLSM(S,l,J,l2,J2);
  Sl:=Sl*slsmval;
  osc:=osc*slsmval*ji;
  A:=A*slsmval*jf;
  end;
    if offdiag then begin
    write(out,nl,if n1c<>n then 2 else 1);
    writestate(out,L,n,l,J);
    write(out,sp,1);
    writestate(out,L,n2,l2,J2);
    if dip and hastighed then write(out,string layr3,has/(dele));
    if dip then write(out,string layr3,h);
    if polarisation then write(out,string layr3,polint);
    if bandd or bandf then write(out,string layr3,F) else
    if sigma2 then write(out,string layr3,sigma);
    if dip then write(out,string layr3,A);
   write(out,string laye,sp,4,E-E2);
    if overl then write(out,string laye,sp,2,ovl);
    if cput then write(out,<<-d.dd>,systime(1,time,time)-cpu);
    if canc and dip then write(out,sp,2,<<ddd.dd>,abs h/hp*100);
    if eqfak<>1 then write(out,sp,2,<:degen=:>,<<d>,eqfak);
    lin:=lin+(if n1c<>n then 2 else 1); 
    n1c:=n;
    end;

    dipi:=dipf:=dipf+diprecsize;
    dipval.dipi(1):=state+stateindex;
    dipval.dipi(2):=state2+stateindex2;
    for i:=diprecsize//4 step -1 until 2 do dipval.dipf(i):=
      case i of(0.0,h,has,polint,abs h/hp*100,osc,A,Sl,lambda,0.0);
end computed2;
end end end state2loop;
lastsegm:=putstruct(bsdipname,dipval,tottrans,tottrans+trans-1,
   diprecsize,chargesegdes(11));
tottrans:=tottrans+trans;
if offkey then
begin
  write(out,nl,2,<:dipole record for :>);
  writestate(out,L,n,l,J);
  write(out,sp,4,<:trans :>,trans,sp,2,<:total trans :>,tottrans);
  for i:=0 step 1 until trans-1 do writediprec(dipval,i);
  write(out,nl,1,<:first segment :>,chargesegdes(11),
            nl,1,<:last  segment :>,lastsegm);
  end offkey;
end computed;
end end end end stateloop;
chargesegdes(15):=-1;
end rydip_in_parent;

procedure ryquad(bsname,parterm);
array bsname;
integer array parterm;
if chargesegdes(13)<0 and quad and electrons=1 and -,finestruct then
begin comment local block for ryquad;
integer i,k,ngr,sq,n1c,trans,eqfak,icutf,tottrans,lastsegm,
        dl,coresold;
real dele,f0,f1,f2,f3,f4,df,del,x,h,hp,w,r2,
      ov,ovl,g,osc,A,Sl,lambda,
      dovl,dh,dhp,dr2,
      cutf,cut,ji,jf,gi,gf,slsmval;
boolean page1,plb;
array bsquadname(1:2);
algol list.on copy.statevar;
algol list.on copy.statevar2;
integer array field quadi;
array field quadf;

dl:=2;
setrydwhere(<:ryquadinp:>,0,0,0,0);
if offdiag then begin
page:=1;
writepage(page,0,parterm);
head(r); writeparam;
n1c:=0;
write(out,nl,2,<:quadropole transition matrixelements:>,nl,1);
lin:=lin+3;
end;

initrydfile(bsname(1) shift 24, real <:quad:>,100<*segdes.quadsize*>,false);
for i:=1,2 do bsquadname(i):=segdes.quadname(i);
tottrans:=0;
keystat:=lookupentry(<:ryoffkey:>)=0;
offkey:=offkey or keystat;
page1:=true;

algol list.on copy.stateloop;
  if cores=0 then coresold:=0;
  computed:=getcomputed(states,state,cutcase,cut);
  trans:=gettransno(states,state);
  if offkey then write(out,nl,1,<:trans :>,trans);
  if computed and trans>0 then
  begin
  array ry1,ry2(1:(segm-1)*128);
  integer array quadval(1:(trans+1)*quadrecsize//2);
  cleararray(quadval);
  ncur:=n; lcur:=l; jcur:=J;
  if offkey then
  begin
  write(out,nl,1);
  writestate(out,L,n,l,J);
  write(out,<:  n*  :>,nstar);
  end;
  E:=(-Ip+Ecm)/Econv;
  henta(ryf,(state+stateindex)*segm+1,ry1,segm-1);
  quadf:=-quadrecsize;

algol list.on copy.stateloop2;
  if plb then henta(ryf,(state+stateindex)*segm+1,ry1,segm-1);
  cpu:=systime(1,0,time);
  cutf:=if cut>cut2 then cut else cut2;
  if offkey then
  begin
  write(out,nl,1,star,1);
  writestate(out,L,n,l,J);
  write(out,sp,1);
  writestate(out,L,n2,l2,J2);
  write(out,<: cut :>,<<  dd.d0>,cutf,cut,cut2);
  end;
  A:=osc:=Sl:=lambda:=0;
  hp:=r2:=h:=ovl:=0;
  if computed2 and n2>=n-njump and n2<=n+njump  and
    ((l>0 and l=l2) or abs(l-l2)=2*dl) and abs(J-J2)<=2 and abs(L-L2)<=2 then
  begin
  setrydwhere(<:ryquadinp:>,n,l,n2,l2);
  operator(false);
  E2:=(-Ip+Ecm2)/Econv;
  dele:=E2-E;
  henta(ryf,(state2+stateindex2)*segm+1,ry2,segm-1);
  NE(-1):=0;
  icut:=cut/del0;
  icut2:=cut2/del0;
  icutf:=cutf/del0;
f0:=f1:=f2:=ry2(NE(q-1));
f3:=ry2(NE(q-1)-1);
for sq:=q-1 step -1 until 0 do
  begin
  del:=DE(sq);
  x:=B(sq+1);
  ngr:=NE(sq-1)+1;
  if ngr<1 then ngr:=1;
  dovl:=dh:=dhp:=dr2:=0;
  for k:=NE(sq) step -1 until ngr do
    begin
      f4:=if k>2 then ry2(k-2) else 0;
      g:=if k>0 then ry1(k) else 0;
      ov:=f2*g; dovl:=dovl+ov;
      w:=ov*x;
      dh:=dh+w;
      w:=w*x;
      dhp:=dhp+abs w;
      dr2:=dr2+w;
      f0:=f1; f1:=f2; f2:=f3; f3:=f4;
      x:=x-del;
    end;
    ovl:=ovl+dovl*del;
    jint:=jint+dj*del;
    iint:=iint+di/12;
    h:=h+dh*del;
    hp:=hp+dhp*del;
    r2:=r2+dr2*del;
end;
comment laye=8,laym=10,layr=8,layr2=10,layr3=15;
if (lin>=maxlines or page1 or cores<>coresold) and offdiag then
begin
  if page1 then page1:=false else
  begin
  writepage(page,cores,parterm);
  write(out,nl,1);
  lin:=10;
  end;
  write(out,<:transition:>);
if finestruct then write(out,sp,10);
  write(out,sp,3,<:<r>:>,sp,6);
  write(out,sp,1,<:A(n1,l1;n2,l2):>);
  write(out,sp,5,<:P1*P2:>,sp,5);
  write(out,sp,5,<:E1-E2:>,sp,2);
  write(out,sp,4,<:P1*r*r*P2:>,sp,3);
  if overl then write(out,sp,3,<:overlap:>,sp,1);
  if cput then write(out,sp,1,<:cpu-time:>);
  if canc then write(out,sp,5,<:<37>:>,sp,2);
coresold:=cores;
end sideoverskrift;
  h:=h/Z; r2:=r2/Z/Z;
  hp:=hp/Z/Z;
lambda:='8/Econv/dele;
if lambda>0 then begin
  gi:=l+1; gf:=l2+1;
  ji:=2*gi/(J+1); jf:=2*gf/(J2+1);
  end else begin
  gi:=l2+1; gf:=l+1;
  ji:=2*gi/(J2+1); jf:=2*gf/(J+1);
  end;
gi:=gi*(S+1);
gf:=gf*(S+1);
eqfak:=degenerate(cores,parterm,n,l);
Sl:=r2*r2/(if l=l2 then 4*((l2-1)*(l2+3))**2 else
  if l2=l+4 then 8*(l2-2)*(l2-2)*(l2+1)*(l2-3) else 0;
A:=(cau*dele)**5/gf/10/t0sec*'-8;
comment Condon and Shortley p.255;
A:=abs A;
osc:=abs osc;
if finestruct then begin
  slsmval:=SLSM(S,l,J,l2,J2)/2;
  Sl:=Sl*slsmval;
  osc:=osc*slsmval*ji;
  A:=A*slsmval*jf;
  end;
    if offdiag then begin
    write(out,nl,if n1c<>n then 2 else 1);
    writestate(out,L,n,l,J);
    write(out,sp,1);
    writestate(out,L,n2,l2,J2);
    write(out,string layr3,h);
    write(out,string layr3,A);
   write(out,string laye,sp,4,E-E2);
    write(out,string layr3,r2);
    if overl then write(out,string laye,sp,2,ovl);
    if cput then write(out,<<-d.dd>,systime(1,time,time)-cpu);
    if canc  then write(out,sp,2,<<ddd.dd>,abs h/hp*100);
    if eqfak<>1 then write(out,sp,2,<:degen=:>,<<d>,eqfak);
    lin:=lin+(if n1c<>n then 2 else 1); 
    n1c:=n;
    end;

    quadi:=quadf:=quadf+quadrecsize;
    quadval.quadi(1):=state+stateindex;
    quadval.quadi(2):=state2+stateindex2;
    for i:=quadrecsize//4 step -1 until 2 do quadval.quadf(i):=
      case i of(0.0,h,has,r2,abs h/hp*100,osc,A,Sl,lambda,0.0);
end computed2;
end end end state2loop;
lastsegm:=putstruct(bsquadname,quadval,tottrans,tottrans+trans-1,
   quadrecsize,chargesegdes(18));
tottrans:=tottrans+trans;
if offkey then
begin
  write(out,nl,2,<:quadole record for :>);
  writestate(out,L,n,l,J);
  write(out,sp,4,<:trans :>,trans,sp,2,<:total trans :>,tottrans);
  for i:=0 step 1 until trans-1 do writequadrec(quadvais counted under the first parameter.
*nl*
fpnr points to the current parameter and is intended for use by
the sequential procedures "readifpnext" and "readsfpnext".
*ps0*
*ct*
Alphabetic list of procedures
*ta 30,30,30,30*
boolean	procedure	connectinp
boolean	procedure	connect_ls_o
boolean	procedure	initfp
boolean	procedure	readbfp
boolean	procedure	readifp
boolean	procedure	readifpnext
boolean	procedure	readinfp
boolean	procedure	readlsfp
boolean	procedure	readrfp
boolean	procedure	readsfp
boolean	procedure	readsfpnext
boolean	procedure	takefpitem

*ps0*
*ct*
References
*sj*
\f

ref. 1.
 H. Rischel and T.A. Aris
 System 3 Utility Programs Part one
 RCSL 31-D364
 Regnecentralen
 Copenhagen 1975

ref. 2.
 H. Dinsen Hansen (Ed.)
 Algol 6, Users Manual
 RCSL 31-D
DataMuseum.dk

RC4000/8000/9000

⟦96cfebf30⟧ TextFile

Derivation

TextFile
