|
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: 8448 (0x2100)
Types: TextFile
Names: »ryoffpr«
└─⟦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⟧
\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◀