DataMuseum.dk

top - metrics - download

    Length: 23040 (0x5a00)
    Types: TextFile
    Names: »rymain«

└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
    └─⟦4334b4c0b⟧ 
        └─⟦this⟧ »rymain« 

TextFile

mode list.yes
aldx=lookup ryproc alutproc ryglobal statevar statevar2 stateloop stateloop2,
       ionloop rydstruct rydseg coreproc rycomp rydiffint rydiagpr,
       ryoffpr ryortpr
if ok.no
(
contract from.crypr ryproc alutproc ryglobal statevar statevar2,
       stateloop stateloop2 ionloop rydstruct rydseg coreproc
contract from.cryprog ryortpr,
       rycomp rydiffint rydiagpr ryoffpr
)
lookup rymain
(
lookup rydlist
if ok.yes
mode 15.yes
rydberg1=set 460 disc3
scope day rydberg1
(rydberg1=algol blocks.yes
if warning.yes
end)
mode list.no
finisb
)
rydberg1
1980-09-07

begin
comment  copyright Anders Lindgård, 1968,1969,1970,1971,1972,1973,
        1974,1975,1976,1977,1978,1979.
program for calculating rydberg functions and matrixelements,
;
integer i,k,res,q,qmax,
  r,testmode,extype,scfc,scfitr,
  start,prno,noex,str,ncur,lcur,
  fp,segm,bstrans,segtrans,elem,maxlines,page,lin,
  nfitmax,dne,imax,char,psegm,attbuf,
  ownd,nunr,nuitr,njump,
  coresize,areas,buffers,outcopies,tasknr,
  Zfitmax,extendl,
  jcur;
long totcpu,totreal;
real del,rew,R,plymin,etam,del0,stxb,stxe,stxs,
  cpu,time,
  laye,laym,layr,layr2,layr3,efak,nuerror,
  cut,rC,psqdf,
  rhomin,deltanl,dn,n0bd,dcut,maxcut;
boolean nyR,rlfit,first,ud,hipr,func,
        zerocut,cput,dip,quad,diag,orto,offdiag,int1,
        nuipol,nukey,diagkey,offkey,overl,hastighed,bsdata,
        testtape,wrzero,fptrue,fpto,ostack,
        nextfile,bandd,autcut,next,
        bsdc,osc,sigma2,canc,
        ritz,bscheckonly,bandf,task,linestrength,
        diagexact,exact,randr1mcrit,r1mc,
        testoverfl,spinorbit,polarisation;
array consol,term,bsarea,outfile,name,
   ryf,ryp,peff,ryexp,FP(1:3),
  B,DE(0:12+1);
integer array tail,ttail(1:10),NE(-3:12);

procedure inparam;
begin
integer chc,n,l,i,ii;
boolean found,first;
own boolean f;

procedure fpparam(no);
value no; integer no;
begin
integer syner;
if fptrue then fp:=readparam(FP) else
  begin
  syner:=0;
  if f then repeatchar(in) else f:=true;
  nextchar:
  readchar(in,i);
  if i=32 then goto nextchar;
  fp:=0;
  nFP:
  if i=10 or i=25 then fp:=0 else
  if i>47   and i<58 then fp:=fp+1 else
  if i>96 and i<126 then fp:=fp+2 else
  if i=46 or i=47 then begin
    readchar(in,i); 
    fp:=2;
    goto nFP;
    end else fp:=5;
  if fp=5 then
  begin
    syner:=syner+1;
    write(out,"nl",1,<:syntax:>);
    if syner>5 then goto ENDI;
  end else
    begin
    repeatchar(in);
    if fp=1 or fp=3 then 
      begin
      read(in,i); FP(1):=i;
      end;
    if fp=2 or fp=4 then readstring(in,FP,1);
    end;
  end;
if fp>0 then begin
  i:=1;
  if chc>50 then chc:=write(out,<: ,:>,"nl",1);
  case fp of begin
    chc:=chc+write(out,"sp",1,<<d>,round FP(1));
    begin
    chc:=chc+write(out,"sp",if fpto then 0 else 1,string FP(increase(i)));
    fpto:=false;
    end;
    chc:=chc+write(out,<:.:>,<<d>,round FP(1));
    chc:=chc+write(out,<:.:>,string FP(increase(i)));
    end;
  end;
found:=fp<=0;
if no>0 and fp<>no and fp<5 then begin
  goto lFP;
  end;
end;

integer procedure readi;
begin fpparam(3); found:=true; readi:=FP(1); end;

procedure readr(val);
real val;
begin
real fak;
fak:=.1;
fpparam(3);
val:=FP(1);
rep:
fpparam(-1);
if fp<>3 then goto lFP;
found:=true;
if FP(1)=0 then begin
  fak:=fak/10;
  goto rep;
  end;
val:=val+fak*FP(1)*10**(-entier(ln(FP(1))/ln(10)));
end;

boolean procedure ct(txt);
string txt;
begin
boolean b;
array text(1:10);
movestring(text,1,txt);
b:=ct:=if text(1) shift (-8)<>FP(1) shift (-8) then
  false else true;
found:=found or b;
end;

boolean procedure readb;
begin
fpparam(4);
if FP(1)=real <:yes:> or FP(1)= real <:no:> then
  readb:=FP(1)=real <:yes:> else goto lFP;
found:=true;
end;

first:=true;
chc:=1;
lrFP:
fpparam(-1);
lFP:
if fp<>0 then begin
  if fp=-1 or (fp=2 and ct(<:out:>)) then begin
  if ct(<:out:>) then fpparam(4);
  found:=true;
  for i:=1,2 do outfile(i):=FP(i);
  fp:=lookuptail(outfile,tail);
  if fp<>0 then begin
  reservesegm(outfile,500);
  end;
  fp:=connectcuro(outfile);
  unstackcuro;
  if fp<>0 then begin
    outerror(<:connect out:>,fp);
    end else ostack:=true;
  outendcur(10);
  i:=1;
  if tail(1) extract 12 =18 then
  write(out,"nl",1,<:filecount = :>,tail(7));
  write(out,"nl",1,string outfile(increase(i)),<: = :>);
  end;
if fp=2 then begin
  if ct(<:efactor:>) then readr(efak);
  if ct(<:r:>) then begin
  readr(R);
    r:=100*R;
    nyR:=true;
    end;
  if ct(<:testoverflow:>) then testoverfl:=readb;
  if ct(<:nukey:>) then nukey:=readb;
  if ct(<:diagkey:>) then diagkey:=readb;
  if ct(<:offkey:>) then offkey:=readb;
  if ct(<:int1:>) then int1:=readb;
  if ct(<:elem0:>) then start:=readi;
  if ct(<:elem:>) then dne:=128*readi;
  if ct(<:intervals:>) then q:=readi;
  if ct(<:presicion:>) then
    begin
    fpparam(4);
    hipr:=-,ct(<:low:>);
    system(1,if hipr then 0 else 1,tail);
    end;
  if ct(<:autcut:>) then autcut:=readb;
  if ct(<:zerocut:>) then zerocut:=readb;
  if ct(<:rhomin:>) then readr(rhomin);
  if ct(<:cut:>) then 
    begin
    readr(cut);
    autcut:=false;
    end;
  if ct(<:dcut:>) then readr(dcut);
  if ct(<:maxcut:>) then readr(maxcut);
  if ct(<:function:>) then
    begin
    func:=readb;
    if -,func then nyR:=false;
    end;
  if ct(<:diag:>) then diag:=readb;
  if ct(<:orto:>) then orto:=readb;
  if ct(<:offdiag:>) then offdiag:=readb;
  if ct(<:nuerror:>) then
    begin
    fpparam(3);
    nuerror:=10**(-FP(1));
    end;
  if ct(<:overlap:>) then overl:=readb;
  if ct(<:dipole:>) then dip:=readb;
  if ct(<:quadropole:>) then quad:=readb;
  if ct(<:velocity:>) then hastighed:=readb;
  if ct(<:sigma:>) then sigma2:=readb;
  if ct(<:linestrength:>) then linestrength:=readb;
  if ct(<:oscillatorstrength:>) then osc:=readb;
  if ct(<:bandf:>) then bandf:=readb;
  if ct(<:cancellation:>) then canc:=readb;
  if ct(<:diagexact:>) then diagexact:=readb;
  if ct(<:exact:>) then begin
   exact:=readb;
   end;
  if ct(<:data:>) then
    begin
    fpparam(4);
    bsdata:=true;
    for i:=1,2 do bsarea(i):=FP(i);
    found:=lookupentry(bsarea)=0;
    if -,found then write(out,<:***not present:>);
    nuitr:=0;
    fpparam(4);
    bsdc:=ct(<:check:>);
    end;
  if ct(<:ritz:>) then ritz:=readb;
  if ct(<:zfitmax:>) then Zfitmax:=readi;
  if ct(<:del:>) then readr(del0);
  if ct(<:terminal:>) then begin
    fpparam(4);
    for i:=1,2 do term(i):=FP(i);
    found:=lookupentry(term)=0;
    end;
  if ct(<:intp:>) then nuipol:=readb;
  if ct(<:randr1mcrit:>) then randr1mcrit:=readb;
  if ct(<:r1mcriterion:>) then r1mc:=readb;
  if ct(<:scfiterations:>) then scfitr:=readi;
  if ct(<:expotentials:>) then noex:=readi;
  if ct(<:exchange:>) then extype:=readi;
  if ct(<:hartree:>) then extype:=1;
  if ct(<:hfs:>) then extype:=2;
  if ct(<:hfsk:>) then extype:=3;
  if ct(<:hfsg:>) then extype:=4;
  if ct(<:exfirst:>) then readr(stxb);
  if ct(<:exlast:>) then readr(stxe);
  if ct(<:exstep:>) then readr(stxs);
  if ct(<:singlet:>) then S:=0;
  if ct(<:doublet:>) then S:=1;
  if ct(<:triplet:>) then S:=2;
  if ct(<:quartet:>) then S:=3;
  if ct(<:pentet:>) then S:=4;
  if ct(<:tasks:>) then task:=readb;
  if ct(<:end:>) then begin
    unstackcuro; unstackcuri;
    goto ENDP;
    end;
  if ct(<:lines:>) then maxlines:=readi;
  if ct(<:nunr:>) then nunr:=readi;
  if ct(<:charge:>) then Z:=readi;
  if ct(<:nuiterations:>) then nuitr:=readi;
  if ct(<:rlfit:>) then rlfit:=readb;
  if -,fptrue and ct(<:start:>) then
    goto START;
  if ct(<:writezero:>) then wrzero:=readb;
  if ct(<:branch:>) then readb;
  if ct(<:nextfile:>) then nextfile:=readb;
  if ct(<:bandd:>) then bandd:=readb;
  if ct(<:dnl:>) then begin
    readr(deltanl);
    fpparam(4);
    if ct(<:m:>) then deltanl:=-deltanl;
    end;
    if ct(<:dn:>) then readr(dn);
    if ct(<:n0bd:>) then readr(n0bd);
  if ct(<:njump:>) then njump:=readi;
  if ct(<:testmode:>) then
   begin
   for i:=1 step 1 until 24 do
    testmode:=setbit(testmode,readi,1);
   end;
  if ct(<:where:>) then begin
    write(out,"nl",1,<:task :>,tasknr);
    if bsdata then begin
      writeatsym(out,S,atno,Z);
     if ncur>0 then writestate(out,0,ncur,lcur,jcur);
    end;
    write(out,"nl",1);
    DATO;
    write(out,"nl",1,<:called from :>,case prno+1 of (
      <:init:>,<:bery:>,<:numug:>,<:nucut:>,
      <:exactwf:>,<:ryort:>,<:rydiag:>,<:ryoff:>,
      <::>,<:HFexchange:>));
    write(out,"nl",1);
    goto ENDI;
    end;
end fp<>2;
  if ct(<:nsmax:>) then readi;
  if ct(<:nmax:>) then readi;
  if ct(<:nmin:>) then readi;
  if ct(<:lmin:>) then readi;
  if ct(<:zmin:>) then readi; if ct(<:zmax:>) then readi;
  if ct(<:zbrmax:>) then readi; if ct(<:extendl:>) then readi;
  ct(<:bscheck:>);
  ct(<:maxpl:>); ct(<:spinorbit:>);
  ct(<:polarisat:>);
  ct(<:survey:>);
  ct(<:yes:>); ct(<:no:>);
  if -,ct(<:next:>) then begin
    if -,found then begin
    if first and fp=2 then first:=false else
    if fp<5 then
      write(out,<:***param:>);
    end not found;
    goto lrFP end else next:=true;
end;
if -,next then f:=false;
if diagexact then bscheckonly:=true;
if bscheckonly or (diagexact ) then param(1,1,1) else
param(start,q,dne//128);
if nuitr<>0 then cut:=0;
if nextfile then begin
  lookuptail(outfile,tail);
  tail(7):=tail(7)+1;
  changetail(outfile,tail);
  end;
if extype>0 then osc:=hastighed:=true;
if -,bscheckonly then begin
ryåbn(peff,segm-1);
comment ryåbn(ryexp,psegm*maxstates);
ryåbn(ryp,psegm*7);
end;
if exact or autcut or cut>del0 then nuitr:=0;
if exact then autcut:=false;
ENDI:
if fptrue and ostack then
  begin 
  fplist:=true;
  connectcuro(outfile);
  initfp;
  end;
end inparam;

procedure connectprim;
begin
if doubleload(parent+4)=long <:b:> and
  term(1)=real <:t30:> then begin
connectcuro(<:t30:>); connectcuri(<:t30:>);
end else begin
connectcuro(term); connectcuri(term);
end;
end;

procedure endprim;
begin
outendcur(12);
outendcur(25);
unstackcuro;
unstackcuri;
end;

procedure writestat;
begin
long tc,tr;
write(out,"ff",1,"nl",5,"sp",40);
DATO;
tc:=doubleload(owndescr+56);
tr:=doubleload(owndescr+64);
totcpu:=tc-totcpu;
totreal:=tr-totreal;
write(out,"nl",5,<:cputime used:>,"sp",10,
    << dd dd dd>,totcpu/10000,"nl",1,
    <:real time used :>,"sp",7,totreal/10000,
    "nl",1,<:cpu  <37> :>,"sp",18,<< dd.dd>,totcpu/totreal*100,"nl",1,
    <:segments transferred  :>,<<  ddd ddd>,segtrans,"nl",1,
    <:backing store accessed:>,bstrans,"nl",1,
    <:blocksread            :>,blocksread,"nl",1,
    <:end:>,if false then <:task:> else <:run:>,"nl",1);
outendcur(10);
totcpu:=tc;
totreal:=tr;
segtrans:=bstrans:=blocksread:=0;
writetasknr;
end writestat;

procedure outerror(txt,val);
value val; integer val;
string txt;
begin
connectprim;
write(out,"nl",1,<:**:>,txt);
if val>0 then write(out,val);
endprim;
end;

procedure setrydwhere(proc,n1,l1,n2,l2);
value n1,n2,l1,l2; integer n1,l1,n2,l2;
string proc;
begin
integer res;
array field nf;
nf:=2;
res:=lookuptail(<:rydwhere:>,tail);
if res<>0 then begin
  cleararray(tail);
  tail(1):=-1;
  tail(6):=systime(7,0,0.0);
  createentry(<:rydwhere:>,tail);
  permentry(<:rydwhere:>,3);
  setenbase(<:rydwhere:>,120,129);
  end;
movestring(tail.nf,1,proc);
tail(7):=S+1;
tail(8):=atno shift 12+Z;
tail(9):=n1 shift 12+l1//2;
tail(10):=if n2>0 then n2 shift 12+l2//2 else 0;
res:=changetail(<:rydwhere:>,tail);
end setrydwhere;

procedure operator(wait);
value wait; boolean wait;
begin
<*
if wordload(attbuf+4)<6 or wait then begin
  array consol(1:3);
  integer field c;
  waitanswer(attbuf,tail);
  attbuf:=0;
  if -,wait then begin
  i:=tail(2);
  generaten(consol);
  cleararray(tail);
  tail(1):=1 shift 23+8;
  for c:=4,6,8,10 do tail.c:=wordload(i-2+c);
  createentry(consol,tail);
  connectcuro(consol);
  connectcuri(consol);
  fpto:=true;
  fptrue:=false;
  setposition(in,0,0);
  inparam;
  unstackcuri;
  outendcur(25);
  unstackcuro;
  end nowait;
*>
end;

integer procedure henta(name,fsgm,a,sgm);
value fsgm; 
integer fsgm,sgm;
array a,name;
begin integer i,rep,maxs;
integer array M,A(1:8);
rep:=0;
  if description(name)=0 then ryåbn(name,fsgm+sgm);
  maxs:=wordload(description(name)+18);
  M(1):=3 shift 12;
  M(2):=firstaddr(a);
  M(3):=M(2)+sgm*512;
  M(4):=fsgm;
  more:
  i:=waitanswer(sendmessage(name,M),A);
  rep:=rep+1;
  if (i<>1 or A(2)<>sgm*512) and rep<100 then goto more;
if i=1 and A(2)<>sgm*512 then alarm(A(2),"nl",1,<:bytes from bs :>,
  string inc(name),
 "nl",1,<:segment no     = :>,fsgm,<:
 no of segments = :>,sgm,<:
 maxsegm        = :>,maxs);
if i<>1 then alarm("nl",1,<:res from bs :>,
  string inc(name),<:  :>,i);
henta:=i;
bstrans:=bstrans+1;
segtrans:=segtrans+sgm;
end henta;

integer procedure gema(name,fsgm,a,sgm);
value fsgm;
integer fsgm,sgm;
array a,name;
begin
integer i,k,rep,maxs;
integer array M,A(1:8);
rep:=0;
  REP:
  i:=reserveproc(name,0);
  if i=3 then begin
  i:=careaproc(name);
  if i=0 then goto REP;
  end;
  if i<>0 then outerror(<:device status:>,i);
  maxs:=wordload(description(name)+18);
  M(1):=5 shift 12;
  M(2):=firstaddr(a);
  M(3):=M(2)+512*sgm;
  M(4):=fsgm;
  more:
  i:=waitanswer(sendmessage(name,M),A);
  rep:=rep+1;
  if (i<>1 or A(2)<>sgm*512) and rep<100 then goto more;
if i=1 and A(2)<>sgm*512 then alarm(A(2),<:<10>bytes to bs :>,
string inc(name),
<:<10>segment no     = :>,fsgm,<:
no of segments = :>,sgm,<:
maxsegm        = :>,maxs);
if i<>1 then alarm(<:<10>res to bs :>,string inc(name),
<:  :>,i);
gema:=i;
bstrans:=bstrans+1;
segtrans:=segtrans+sgm;
releaseproc(name);
end gema;

boolean procedure ryåbn(name,segm);
value segm; integer segm;
array name;
begin
integer i,j;
if segm<=0 then alarm(<:segm :>,segm,
  <:  :>,string inc(name));
if description(name)<>0 then removeproc(name);
ryåbn:=false;
i:=lookuptail(name,tail);
if i=0 and tail(1)<segm then
begin
  j:=tail(1);
  tail(1):=segm;
  i:=changetail(name,tail);
  if i<>0 then alarm(<:***to few segments :>,string inc(name),
     <:, requested :>,segm,<: original :>,j);
end
else
if i<>0 then
  begin
  removeentry(name);
  i:=reservesegm(name,segm);
  if i<>0 then
  begin
    if ostack  then closeout;
    alarm("nl",1,<:******free area less than :>,segm,
    <: ,result = :>,i,<: :>,string inc(name));
  end;
  comment scopeday(name);
  ryåbn:=true;
  end;
i:=careaproc(name);
if i<>0 then alarm(<:***area claim :>,i,
  <:  :>,string inc(name));
end;


real procedure pnames(i);
value i; integer i;
pnames:=real (case i of(<:ryhyf:>,<:rygrf:>,<:rynuc:>,<:rygrc:>,
                        <:rysex:>,<:rycou:>,<:ryex:>,<:rypot:>));

procedure getandcalc(name);
array name;
begin
integer i,ii,iii,l0;
boolean ct;
long time;
algol list.off copy.statevar;
tasknr:=0;
ct:=bsdc;
if task then begin
  i:=lookuptail(<:rytask:>,tail);
  if i<>0 or (i<>0 and Zmin>1) then begin
    removeentry(<:rytask:>);
    cleararray(tail); tail(6):=Zmin;
    i:=create_entry(<:rytask:>,tail);
    i:=i+scopeuser(<:rytask:>);
    if i<>0 then outerror(<:createtask:>,i);
    end;
  tasknr:=tail(6)-1;
  end;
if survey then write(out,"nl",1,<:from Z= :>,Zmin,<: to :>,Zmax);
algol list.off copy.ionloop;
if Z>=Zmin and Z<=Zmax then 
begin
page:=1;
  if bsdc then
  begin
  writepage(page,0,parterm);
  write(out,"nl",1,<:data read from :>,string inc(bsarea));
  end;
time:=getclock//10000;
setrydwhere(<:readdata:>,0,0,0,0);
outcopies:=1;
if bscheckonly then else
if ryåbn(ryf,segm*maxstates) then
  write(out,"nl",1,<:called from bsdata :>);
if bsdc then
begin
  write(out,"nl",2,<:state:>,"sp",if finestruct then 8 else 3,
    <:n*:>,"sp",8,<:defect:>,"sp",2);
  if Ip>0 then write(out,"sp",9,<:cm-1:>);
  outendcur(10);
  lin:=lin+(if Ip>0 then 5 else 4)+3;
end;
   if bsdc then begin
    l:=l0:=0;
    algol list.off copy.stateloop;
    if l<>l0 then begin
     if lin+3+series.ser(3)-series.ser(2)>=maxlines then begin
      writepage(page,cores,parterm);
      write(out,"nl",2,<:state:>,"sp",3,<:n*:>,"sp",8,<:defect:>,"sp",2);
      if Ip>0 then write(out,"sp",9,<:cm-1:>);
      lin:=lin+5;
      end;
     write(out,"nl",1);
     l0:=l;
     lin:=lin+1;
     end;
     lin:=lin+1;
    writestate(out,L,n,l,J);
    write(out,<<  -dd.dddddd>,nstar,
    <<  -d.dddd>,n-nstar);
    if Ip>0 then write(out,<< -dd ddd ddd.ddd>,Ecm);
    if n>=nmin and n<=nmax and l>=lmin and l<=lmax and nstar<=nsmax then
      write(out,"sp",2,"*",1);
   write(out,"nl",1);
    end end end end stateloop;
    end bsdc;
<*
if spinorbit then
begin
real val;
for l:=if lmin=0 then 1 else lmin step 1 until lmax do
for n:=if nmin<l+1 then l+1 else nmin step 1 until nmax do
  begin
  jindex:=l+s-abs(l-s)+1;
  val:=-.5*Z*Z(1/nstable(lexi(n,l),jindex)**2-1/nstable(lexi(n,l),jindex-1;
  spinorbitint:=val;
  end;
end;
*>
if diagexact then begin
  imax:=1;
 rydiag(bsname,parterm);
  end;
if -,bscheckonly  then
begin
if dcut=0 or autcut then begin
bery(bsname,0,parterm);
chargestate(13):=time shift (-24) extract 24;
chargestate(14):=time extract 24;
chargestate(15):=if nuitr=0 then -1 else 0;
chargestate(16):=1; <*dl*>
chargestate(17):=njump;
rydiag(bsname,parterm);
ryoff(bsname,parterm,1);
putstruct(bsname,chargestate,2*chargestates-2,2*chargestates-2,chargesize,1);
putstruct(bsname,chargesegdes,2*chargestates-1,2*chargestates-1,chargerecsize,1);
end else
for cut:=if cut>del0 then cut else del0,
  dcut step dcut until maxcut do
begin
bery(bsname,0,parterm);
rydiag(bsname,parterm);
ryoff(bsname,parterm,1);
end;
end;
  if task then begin
    cleararray(tail);
    tail(6):=tasknr;
    changetail(<:rytask:>,tail);
    end;
end end end ionloop;
if task then removeentry(<:rytask:>);
goto ENDP;
end Z inside limits;
end getandcalculate;
algol list.off copy.rydstruct;
algol list.off copy.rydseg;
algol copy.rycomp;
algol copy.rydiffint;
algol copy.rydiagpr;
algol copy.ryoffpr;
algol list.off copy.alutproc;
algol list.off copy.coreproc;
algol list.off copy.ryproc;

procedure writetasknr;
begin
connectprim;
write(out,"nl",1,<:task  :>,tasknr,"sp",4);
if tasknr>0 and bsdata then begin
  if atno<1 or atno>96 then write(out,"sp",1,"*",2,<: atomic symbol:>,atno) else
  writeatsym(out,S,atno,Z);
  end;
  write(out,"sp",1);
  DATO;
outendcur(25);
endprim;
tasknr:=tasknr+1;
end;


procedure DATO;
writedate(out,0.0);

\f


procedure HFex(n,l,state);
value n,l,state; integer n,l,state;
begin
integer ngr,øgr,p,k,i,lf,l1,d;
real del,fak,x,y,iy,a,b,c;
array func,ex,off,gr,IN(1:imax);
prno:=9;
henta(ryf,state*segm+1,func,psegm);
lf:=-1/(2*l+1);
  l1:=l+1;
    y:=0; øgr:=0;
    b:=c:=0;
    if l=0 then begin
    for p:=1 step 1 until imax do
      off(p):=-gr(p)/func(p);
    end l=0;
    for p:=1 step 1 until imax do 
      ex(p):=lf*gr(p)/func(p);
    for k:=1 step 1 until q do begin
      del:=DE(k-1);
      ngr:=øgr+1;
      øgr:=NE(k-1);
      for i:=ngr step 1 until øgr do begin
      y:=y+del;
      if i<=imax then begin 
        func(i):=iy:=func(i)*gr(i)*del;
        if l=0 then c:=c+iy;
        end else
        b:=b+iy/(y**l1);
      end end;
    a:=0;
    y:=B(1);
    IN(imax):=b;
    for d:=imax-1 step -1 until 1 do begin
    y:=y-del0; iy:=IN(d+1);
      IN(d):=iy+func(d)/(y**l1);
      IN(d+1):=(y+del0)**l*iy
    end;
    IN(1):=del0**l*iy;
    for p:= 1 step 1 until imax do begin
      x:=del0*p;
      if l=0 then off(p):=off(p)*c;
      iy:=func(i)*(x**l);
      a:=a+iy;
      ex(p):=ex(p)*(a*(x**(-l1))+IN(p));
    end;
gema(ryp,5*psegm,off,psegm);
gema(ryexp,state*psegm,ex,psegm);
end of Hartree-Fock exchange postential;

algol list.off copy.ryglobal;

comment initialisation;
setrydwhere(<:initrydberg:>,0,0,0,0);
i:=wordload(owndescr+26);
areas:=i extract 12; buffers:=i shift (-12) extract 12;
coresize:=wordload(owndescr+24)-wordload(owndescr+22)-2;
write(out,"nl",1,<:areas :>,areas,"nl",1,<:buffers :>,buffers,
  "nl",1,<:coresize :>,coresize,"nl",2);
outendcur(0);
r1mc:=randr1mcrit:=testoverfl:=rlfit:=false;
rhomin:=0;
maxlines:=66;
jcur:=0;
ncur:=lcur:=0;
readbfp(<:bscheck:>,bscheckonly,false);
readbfp(<:tasks:>,task,false);
qmax:=12;
q:=4;
start:=4;
dne:=256;
readbfp(<:polarisat:>,polarisation,false);
readbfp(<:spinorbit:>,spinorbit,false);
nfitmax:=25;
readifp(<:extendl:>,extendl,0);
if extendl<lmin then extendl:=lmin;
if extendl>lmax then extendl:=lmax;
rew:=0.0 shift (-12);
cleararray(term);
packtext(term,<:rydterm:>);
laye:=real <<-d.ddddd>;
laym:=real <<-dddd.dddd>;
layr:=real <<-ddd.ddd>;
layr2:=real <<-dddddd.dd>;
layr3:=real <<   -d.ddddd'+dd>;
nuerror:='-5;
stxb:=stxe:=stxs:=
dcut:=maxcut:=R:=B(0):=0;
cut:=del0:=.025;
njump:=10000;
ownd:=owndescr;
testmode:=extype:=
prno:=noex:=scfitr:=r:=0;
efak:=1;
testtape:=lookupentry(<:rytape:>)=0;
exact:=diagexact:=
next:=bandd:=overl:=
ritz:=overl:=autcut:=nextfile:=
bsdata:=hastighed:=nukey:=int1:=quad:=cput:=ostack:=
osc:=sigma2:=offkey:=diagkey:=
wrzero:=bandf:=zerocut:=false;
linestrength:=nyR:=hipr:=fpto:=fptrue:=
canc:=nuipol:=
dip:=func:=true;
n0bd:=1.25;
deltanl:=-0.5;
dn:=.25;
nunr:=8;
Zfitmax:=nuitr:=100;
tasknr:=outcopies:=noex:=1;
cleararray(ryf); cleararray(ryp);
cleararray(ryexp);
movestring(ryf,1,<:ryfunc:>);
movestring(ryp,1,<:rypotential:>);
movestring(peff,1,<:rypoteff:>);
movestring(ryexp,1,<:ryexchange:>);
cleararray(outfile);
for i:=1,2 do outfile(i):=real doubleload(console+2+4*i);
offdiag:=offdiag or polarisation;
totcpu:=doubleload(owndescr+56);
totreal:=doubleload(owndescr+64);
bstrans:=segtrans:=blocksread:=0;
write(out,"nl",1,<:min :>); writenl(out,nmin,lmin);
write(out,"sp",2,<:max :>); writenl(out,nmax,lmax);
write(out,"nl",2);
inparam;
write(out,"nl",1); writenl(out,nmin,lmin);
write(out,"sp",2); writenl(out,nmax,lmax);
write(out,"nl",2);
if -,bscheckonly then initry;

comment start of program;
NEXTJOB:
setrydwhere(<:initnextjob:>,0,0,0,0);
<*
if bandd then BatesandDamgård;
*>
readsfp(<:data:>,FP,<::>);
if bsdata then getandcalc(FP);
START:
lin:=0;
if stxs>0 then begin
  stxb:=1000*stxb;
  stxe:=1000*stxe+1000;
  stxs:=1000*stxs;
  for extype:=stxb+1000 step stxs until stxe do begin
  nyR:=first:=true; <* bery(R,n1,n2,l1,l2); rydiag(n1,n2,l1,l2); *> end;
  goto ENDP
  end;
  r:=100*R;
  for extype:=extype step 1 until noex do begin
  for scfc:=1 step 1 until scfitr do begin
  connectprim;
  write(out,"nl",1,<:iteration  :>,scfc,<:  extype  :>,extype);
  DATO;
  endprim;
  nyR:=first:=true;
<*
  bery(R,n1,n2,l1,l2);
  rydiag(n1,n2,l1,l2);
*>
  extype:=extype+10;
  end iteration;
  extype:=extype mod 10;
end exchange loop;
ENDP:
writestat;
func:=true;
if next then begin
  next:=false;
  inparam;
  goto NEXTJOB;
  end;
write(out,<:end main program
:>);
removeentry(<:rydwhere:>);
if ostack  then closeout;
end;
▶EOF◀