DataMuseum.dk

top - metrics - download

    Length: 8448 (0x2100)
    Types: TextFile
    Names: »ryoffpr«

└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
    └─⟦b2ec5d50f⟧ 
        └─⟦this⟧ »ryoffpr« 

TextFile

\f


<*          ryoff calculation of offdiagonal matrixelements    *>
<*
1980-11-25
*>

procedure ryoff(bsname,parterm,dl);
value dl;
integer dl;
array bsname;
integer array parterm;
if chargesegdes(13)<0 and offdiag then
begin comment local block for ryoff;
integer i,k,ngr,em,sq,n1c,trans,eqfak,icutf,tottrans,lastsegm,
        coresold,Ja,Jb;
real dele,f0,f1,f2,f3,f4,df,del,x,h,hp,w,r2,
      fak,ov,ovl,jd,g,id,osc,A,Sl,lambda,has,sigma,F,
      iint,jint,dovl,dj,di,dh,dhp,dr2,
      cutf,cut,ji,jf,gi,gf,slsv,sls,slsi,slsf,dpolint,polint,s1;
boolean page1,plb;
array bsdipname(1:2);
algol list.off copy.statevar;
algol list.off copy.statevar2;
integer array field dipi;
array field dipf;
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,<: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.off 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.off 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,"*",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:=r2:=h:=iint:=jint:=ovl:=0;
  if computed2 and n2>=n-njump and n2<=n+njump  and
    Jtest(J,J2,l,l2,S,nstar2-nstar) 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:=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;
      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;
      if quad then dr2:=dr2+ov*x*x;
      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;
    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):>);
  if quad then write(out,"sp",5,<:P1*P2:>,"sp",5);
  write(out,"sp",5,<:E1-E2:>,"sp",2);
  if quad then 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;
  jint:=jint*Z; iint:=iint*Z;
  h:=h/Z; r2:=r2/Z/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;
  end else begin
  gi:=l2+1; gf:=l+1;
  end;
eqfak:=degenerate(cores,parterm,n,l);
Sl:=eqfak*h**2*l2/2*(S+1);
osc:=eqfak*2/3*h**2*dele*l2/2/gi;
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 and (J>=0 or J2>=0) then
begin
  if J=-1 then
  begin <*sum over J*>
    sls:=slsi:=slsf:=0;
    Ja:=l-S;
    while Ja<0 do Ja:=Ja+2;
    for Ja:=Ja step 2 until l+S do
    begin
      if abs(Ja-J2)<=2 then
      begin
        if lambda>0 then
        begin ji:=2*gi/(Ja+1); jf:=2*gf/(J2+1); end else
        begin ji:=2*gi/(J2+1); jf:=2*gf/(Ja+1); end;
        slsv:=SLSM(S,l,Ja,l2,J2);
        sls:=sls+slsv;
        slsi:=slsi+slsv*ji;
        slsf:=slsf+slsv*jf;
      end allowed;
    end for Ja;
  end J=-1 else
  if J2=-1 then
  begin
    sls:=slsi:=slsf:=0;
    Jb:=l2-S;
    while Jb<0 do Jb:=Jb+2;
    for Jb:=Jb step 2 until l2+S do
    begin
      if abs(J-Jb)<=2 then
      begin
        if lambda>0 then
        begin ji:=2*gi/(J+1); jf:=2*gf/(Jb+1); end else
        begin ji:=2*gi/(Jb+1); jf:=2*gf/(J+1); end;
        slsv:=SLSM(S,l,J,l2,Jb);
        sls:=sls+slsv;
        slsi:=slsi+sls*ji;
        slsf:=slsf+slsv*jf;
     end Jb;
   end allowed;
  end J2=-1 else
  begin
    if lambda>0 then
    begin ji:=2*gi/(J+1); jf:=2*gf/(J2+1); end else
    begin ji:=2*gi/(J2+1); jf:=2*gf/(J+1); end;
    sls:=slsv:=SLSM(S,l,J,l2,J2);
    slsi:=slsv*ji;
    slsf:=slsv*jf;
  end J>0 and J2>0;
  Sl:=Sl*sls;
  osc:=osc*slsi;
  A:=A*slsf;
  end finestruct;
    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);
    if quad then write(out,string layr3,r2);
   write(out,string laye,"sp",4,E-E2);
    if quad then write(out,string layr3,h*h);
    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,abs h/hp*100,osc,A,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 ryoff;
▶EOF◀