⟦9d5afda0d⟧

TextFile


procedure param(s,q1,d);
<*             rycomp  computation of wawefunction       *>
value s,q1,d; integer s,q1,d;
begin
integer n,sq;
dne:=d*128;
q:=q1;
start:=s;
DE(0):=del0;
if cut<del0 then cut:=del0;
NE(-1):=0;
imax:=NE(0):=s*128;
psegm:=s;
for i:=1 step 1 until qmax do NE(i):=NE(i-1)+dne;
for i:=1 step 1 until qmax+1 do 
  begin
  DE(i):=DE(i-1)*2;
  B(i):=B(i-1)+(NE(i-1)-NE(i-2))*DE(i-1);
  end;
if coresize<30000 then begin
  sq:=-1;
  for sq:=sq+1 while NE(sq-1)<1600 and sq<=qmax+1 do;
  if coresize<24000 then sq:=sq-1;
  if sq<=q then q:=sq-1;
  end;
if -,bscheckonly then begin
n:=entier(sqrt(B(q+1))*4/7);
comment if n<nsmax then nsmax:=n;
end adjust nsmax;
elem:=NE(q-1);
segm:=(elem//128)+2;
end param;

procedure initry;
begin integer i,j;
real fak,firt,drecip;
array ud(1:psegm*128);
for i:=1,2,3,4,5 do begin 
drecip:=1/del0;
case i of begin
  begin comment 2*r*exp(-r) ,H 1s;
  fak:=2*del0;
  for j:=imax step -1 until 1 do
  ud(j):=fak*j*exp(-del0*j);
  end;
  begin comment sqrt(32)*r*exp(-2*r), He 1s;
  fak:=sqrt(32)*del0;
  for j:=imax step -1 until 1 do
  ud(j):=fak*j*exp(-2*del0*j);
  end;
  begin comment 1/r potential;
  for j:=imax step -1 until 1 do
  ud(j):=-drecip/j;
  end;
  begin comment 1/r-(2+1/r)*exp(-r/4);
  for j:=imax step -1 until 1 do
  ud(j):=drecip/j-(2+drecip/j)*exp(-.1*j);
  end;
  begin comment (24/pi**2)**(1/3)*exp(-4/3*r);
  fak:=(1.5/(arctan(1)**2))**(1/3);
  firt:=4/3*del0;
  for j:=imax step -1 until 1 do
  ud(j):=fak*exp(-firt*j);
  end;
end case loop;
gema(ryp,(i-1)*psegm,ud,psegm);
  end calculate potential;
end initry;

procedure writepage(page,parentno,parterm);
integer page,parentno;
integer array parterm;
begin
write(out,"ff",1,"nl",1);
pardes:=parentno*parentsize;
S:=parterm.pardes(6);
writeatsym(out,S,atno,Z);
write(out,"sp",15);
DATO;
write(out,"sp",15,<:page:>,<< dd>,page,"nl",2);
writecore(out,parentno,parterm);
write(out,"nl",1,<:Ionisation potential :>,<< dd ddd ddd.ddd>,
  get_Ip(parentno,parterm));
page:=page+1; lin:=4;
end;

 
procedure writearray(a,sq,head,S,atno,Z,L,n,l,J);
value S,atno,Z,L,n,l,J,sq; integer S,atno,Z,L,n,l,J,sq;
string head; array a;
if testtape then
begin
integer i,j,nmax,bytes,segm;
real x,del;
boolean bs;
connectcuri(<:rytape:>);
lookuptail(<:rytape:>,ttail);
bs:=ttail(1)>0;
if bs then setposition(in,0,ttail(6)) else
           setposition(in,ttail(7),0);
outrec(in,8);
in(1):=S; in(2):=atno; in(3):=Z;
in(4):=L; in(5):=n;    in(6):=l;
in(7):=J;
NE(-1):=0;
bytes:=8*4;
for j:=0 step 1 until sq-1 do
  begin
  nmax:=NE(j);
  del:=DE(j);
  x:=B(j);
  for i:=NE(j-1)+1 step 1 until nmax do begin
  outrec(in,2);
  in(1):=x; in(2):=a(i);
  bytes:=bytes+2*4;
  x:=x+del;
  end;
end;
outrec(in,2); in(1):=in(2):=-1; bytes:=bytes+2*4;
ttail(7):=ttail(7)+1;
segm:=(bytes+510)//512;
ttail(6):=ttail(6)+segm;
ttail(9):=bytes-4*(2+8);
ttail(10):=segm;
changetail(<:rytape:>,ttail);
if -,bs then setposition(in,ttail(7),0);
unstackcuri;
end procedure writearray;

procedure head(r);
integer r;
begin
page:=1;
if r>0 then write(out,<:R = :>,<<-d.d0>,r/100);
if extype<1000 then
begin
write(out,"nl",1);
  lin:=lin+1;
  end;
if extype>0 and extype<1000 then write(out,"nl",1,
case extype mod 10+1  of
(<::>,<:Hartree:>,<:HFS (Slater) A=1.5:>,
<:HFSK (Kohn and Sham) A=1:>,
<:HFSG (Berrondo and Goshinski) determined from virial theorem:>),
<:  functions:>) else if extype>=1000 then
write(out,"nl",1,<:Hartree-Fock free electron functions:>,
  "nl",1,<:A = :>,
 <<-d.dddd>,(extype-1000)/1000);
if extype>=10 and extype <=100 then
  write(out,<: as 1.step in a SCF-procedure:>,
  "nl",1,<:iteration no = :>,<< -ddd>,scfc);
comment
if -,hipr then write(out,"nl",increase(lin),<:low presicion results:>);
lin:=lin+1;
end head;

procedure writeparam;
begin integer gp;
write(out,"nl",1,<<d>,q,<: interval:>);
if q>1 then write(out,<:s:>);
for gp:=1 step 1 until q do
write(out,"nl",1,<:from:>,<<-ddddd.d00>,B(gp-1),
<:  to:>,B(gp),<: ,steplength:>,<<-dd.d00>,DE(gp-1),
<: ,points :>,<<ddddd>,
NE(gp-1)-(if gp=1 then 0 else NE(gp-2)));
write(out,"nl",1,<:independent variable rho=Z*r:>);
   write(out,"nl",1,<:total no of points  :>,elem,
    <: , segments  :>,segm);
  if nuitr=0 and -,exact  and -,autcut then 
     write(out,"nl",1,<:cut at  :>,<<dd.d00>,cut,<: a.u.:>);
  if autcut then write(out,"nl",1,<:automatic cut:>);
   if exact then begin
     write(out,"nl",1,<:exact wawefunctions:>);
     lin:=lin+1;
     end;
   if rlfit then write(out,"nl",1,<:r**(l+1) fit inside cut:>);
  write(out,"nl",1);
lin:=lin+q+9;
end write param;

\f



procedure bery(bsname,R,parterm);
value R; real R;
integer array parterm;
array bsname;
begin
real nyenergi,energi,guess,EH,nsc;
integer gp,q1,l0,maxzero,i,ii,lold;
integer array zeroes(1:nmax+12);
algol list.off copy.statevar;

procedure writeberyhead(heading);
value heading; boolean heading;
begin
if heading then  begin
  page:=1;
  writepage(page,cores,parterm);
  head(r); writeparam;
  if -,hipr then write(out,<:low precission:>,"nl",1);
  if efak<>1 then write(out,<:guessfactor  :>,efak,"nl",1);
  if nuitr<>0 then
  write(out,"nl",1,<:numugerror  :>,<<d'+ddd>,nuerror);
  end else writepage(page,cores,parterm);
  write(out,"nl",1,<:function:>,"sp",if finestruct then 4 else 2,
    <:energy:>,"sp",4);
  if nuitr<>0 then write(out,"sp",2,<:iterations:>);
  if bandd then write(out,<:       n*      :>) else
  if  nuitr>0 then write(out,<::>) else
  if bsdata then write(out,<:       n*      :>) else
  if extype=0 then write(out,<:  exsact energy:>) else
  write(out,<:  quantumdefect:>);
  if -,bsdata then write(out,<:   n*(computed)  :>);
  if autcut then write(out,"sp",4,<:cut:>,"sp",12,<:zero:>);
  if cput then write(out,<:   cpu-time:>);
  outendcur(10);
  first:=false;
  lin:=lin+4;
  end writeberyhead;

prno:=1;
lold:=-4;
q1:=q;
n:=l:=0;
if nyR and (extype<10 or extype>1000) then lavpot(r,n,l//2);
cores:=0;
writeberyhead(true);
l0:=0;
maxzero:=0;
cleararea(string inc(ryf));
survey:=true;
keystat:=false;
    algol list.off copy.stateloop;
    ncur:=n; lcur:=l; jcur:=J;
    computed:=false;
    if extype>=10 and extype<=110 then lavpot(R,n,l);
    energi:=-.5/nstar/nstar;
   if  n<nmin or n>nmax or l<lmin or l>lmax or nstar>nsmax  then goto NEXT;
  if nstar<.5 then goto NLOW;
    cpu:=systime(1,0,time);
   if n<5 and q>4 then begin
     q1:=4;
   end else q1:=q;
  if nstar<l//2 and q1>2 then q1:=2;
  if nstar>1+sqrt(B(q)) then begin
     write(out,"nl",1,"sp",2);
     writestate(out,L,n,l,J);
     write(out,<: too high:>);
    goto NEXT;
    end;
AGAIN:
    setrydwhere(<:bery:>,n,l,0,0);
    operator(false);
    if -,testoverfl then overflows:=0;
    guess:=energi*efak;
    if zerocut then NE(-2):=round (nstar+.499)-l//2-1 else
      if abs (round nstar-nstar)<'-5 then 
        NE(-2):=entier nstar-l//2 else
        NE(-2):= entier nstar-l//2+1;
 
  begin comment block for computation;
  array ryd(1:elem+(if nuitr=0 then 0 else nunr)),
        hj(1:if exact  then 1 else (segm-1)*128);
  system(3,ii,ryd);
  for i:=NE(q1-1) step 1 until ii do ryd(i):=0;
  for i:=1 step 1 until nmax do zeroes(i):=0;
  if exact  then 
      nyenergi:=exactwf(n,l//2,B,DE,NE,ryd) else
  if nuitr=0 then
  nyenergi:=nucut(q1,n,l//2,lold//2,J//2,energi,
    B,DE,NE,ryd,hj,nstar,zeroes,Z) else
  nyenergi:=numug(q1,n,l//2,lold//2,guess,n-l//2-1,B,DE,NE,ryd,hj,nuitr,Z);
  lold:=l;
  chargesegdes(13):=-1;
  writearray(ryd,q1,<:wawefunction:>,S,atno,Z,L,n,l,J);
  gema(ryf,(state+stateindex)*segm+1,ryd,segm-1);
  computed:=true;
  if NE(-2)>maxzero then maxzero:=NE(-2);
  end block for wawefunction;

    if nyenergi=0 then begin
      q1:=q1-1; 
      if q1>0 then goto AGAIN;
      computed:=false;
      end else nsc:=sqrt(-.5/nyenergi);
  if nuitr<>0 then nstar:=nsc;
    cpu:=systime(1,time,time)-cpu;
NLOW:
     zeroes(nmax+12):=NE(-2);
     putstruct(ryf,zeroes,0,0,2*(nmax+12),(state+stateindex)*segm);
ENDBER:
putcomputed(states,state,computed,NE(-3),cut);
if nstar<.5  then goto NEXT;
    if l<>l0 then begin
    if lin+series.ser(3)-series.ser(2)+1>=maxlines then writeberyhead(false);
    lin:=lin+1;
    write(out,"nl",1);
    l0:=l;
   end;
   lin:=lin+1;
    writestate(out,L,n,l,J);
    write(out,string layr3,nyenergi*Z*Z);
    if NE(-1)>0 then write(out,<<  -ddd>,NE(-1),"sp",5);
  if bandd then write(out,string layr3,nstar);
  if  nuitr=0 then begin
  write(out,string layr3,if bsdata then nstar else
  if extype=0 then EH*Z*Z else n-nsc);
  if bsdata and nuitr>0 then
    write(out,string layr3,nsc);
  end;
    if autcut then write(out,<< dd.ddd>,"sp",1,cut,
      "sp",2,case NE(-3)+1 of(<:nocut  :>,
      <:mincut :>,<:maxcut :>,<:divcut :>,<:zerocut:>,
      <:n*<l+1 :>,<:error  :>,<:rhocut :>,<:exact  :>),
      << bd>,NE(-2));
    if cput then write(out,<<  -dd.dd>,cpu);
    if -,computed then write(out,<:  ** not computed:>);
    if overflows>0 then begin
     write(out,<:  ** overflow :>,overflows);
     end;
    if guess>nuerror  and nuitr>0 then
      write(out,<: **error :>,guess);
    outendcur(10);
NEXT:
    end for state;
    putstruct(bsname,states,stateindex,stateno,statesize,chargesegdes(5));
    end end end stateloop
ncur:=0;
if wrzero then begin
  page:=1;
  writepage(page,cores,parterm);
  head(r);
  writeparam;
  write(out,"nl",2,<:zeroes of wawefunctions:>);
  algol list.off copy.stateloop;
  write(out,"nl",1);
  lin:=lin+1;
    getstruct(ryf,zeroes,0,0,2*(nmax+12),(state+stateindex)*segm);
    write(out,"nl",1);
    writestate(out,L,n,l,J);
    ii:=zeroes(nmax+12);
    for i:=1 step 1 until ii do begin
      if i mod 5=0 then write(out,"nl",1,"sp",4);
      write(out,<<-ddd.dd>,rval(zeroes(i)));
    end zeroes;
  end end end end stateloop;
end writezeroes;
if autcut then cut:=del0;
if orto then ryort(bsname,parterm);
end beregn rydberg;
algol list.off copy.ryortpr;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦9d5afda0d⟧ TextFile

Derivation

TextFile
