DataMuseum.dk

top - metrics - download

    Length: 16896 (0x4200)
    Types: TextFile
    Names: »ndiagrampr«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦b050de23d⟧ »csim« 
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
    └─⟦b2ec5d50f⟧ 
        └─⟦b050de23d⟧ »csim« 
            └─⟦this⟧ 

TextFile

<*      diagrampr generate and ALGOL procedure for a specific decay curve  *>

procedure quicksort(lo,r,ns,idx,n,l,J,L,tr,tau);
value lo,r; integer lo,r;
integer array idx,n,l,J,L,tr;
array ns,tau;
begin
integer i,j,k,wi;
real x,w;
i:=lo; j:=r;
x:=ns((lo+r)//2);
while i<=j do begin
  while ns(i)<x do i:=i+1;
  while ns(j)>x do j:=j-1;
  if i<=j then begin
    w:=ns(i); ns(i):=ns(j); ns(j):=w;
    wi:=idx(i); idx(i):=idx(j); idx(j):=wi;
    wi:=n(i); n(i):=n(j); n(j):=wi;
    wi:=l(i); l(i):=l(j); l(j):=wi;
    wi:=J(i); J(i):=J(j); J(j):=wi;
    wi:=L(i); L(i):=L(j); L(j):=wi;
    wi:=tr(i); tr(i):=tr(j); tr(j):=wi;
    w:=tau(i); tau(i):=tau(j); tau(j):=w;
    i:=i+1; j:=j-1;
    end i<=j;
  end loop;
  if lo<j then quicksort(lo,j,ns,idx,n,l,J,L,tr,tau);
  if i<r then quicksort(i,r,ns,idx,n,l,J,L,tr,tau);
end quicksort;


procedure writediagramproc(out,
   bsname,dipval,states,series,dipindex,N0,curstate,delt);
value curstate,delt; integer curstate;
real delt;
comment delt is the time vindow in ns;
zone out;
integer array dipval,states,series,dipindex;
array bsname,N0;
begin
integer diag,termsbrmincrit,termswritten,diagram,lower,res,
  termstot,termsBcrit,termstaucrit,statesincalc;
real b,nstarlower,an,s0,tau,Bminmin;
boolean Bvic;
integer array field dip;
array field dipr,idf;
integer array idx,nv,lv,Jv,Lv,trv(0:(maxstates-1)),tail(1:10);
array tauv,nsv(0:maxstates-1);
long array diagname(1:2);
array field raf;
algol list.off copy.statevar;

procedure generatediagramsum(curstate,diagram,max);
value curstate,diagram,max; integer curstate,diagram,max;
begin
integer array s(1:diagram);
integer i,j,k,p,q,terms,searches,qmin,termsdropped,
  trans,tottrans;
real cut,tau;
real A,B;
boolean more,nzero,first;
algol list.off copy.statevar;
algol list.off copy.statevar2;

procedure writediagram(m,low,diagram,curstates,dropped,written);
value m,low,diagram; integer m,low,diagram,dropped,written;
integer array curstates;
begin
integer i,j,k,p,q,chars,t,t2,stateN0;
real tau,tau2,tauN0;
boolean nzero,Ball,tauall,found;
integer array Scoeff(1:diagram);
array Bcoeff(1:diagram);
nzero:=true;
if diagram>1 then begin
for q:=diagram-1,q-1 while q>0 and nzero do begin
  i:=curstates(q);
  state:=idx(i);
  n:=nv(i); l:=lv(i); J:=Jv(i); L:=Lv(i); nstar:=nsv(i);
  j:=curstates(q+1);
  state2:=idx(j);
  n2:=nv(j); l2:=lv(j); J2:=Jv(j); L2:=Lv(j); nstar2:=nsv(j);
  nzero:=nzero and abs(l-l2)=2 and abs(J-J2)<=2 and abs(L-L2)<=2
      and abs(nstar-nstar2)>'-4;
  if nzero and brmin>0 then
  begin
    b:=-1;
    if nstar<=nstar2 then
    begin t:=state; t2:=state2 end else
    begin t:=state2; t2:=state end;
    tottrans:=dipindex(t2);
    trans:=trv(if nstar<=nstar2 then j else i);
    if trans=0 then b:=0;
    for trans:=trans step -1 until 1 do
    begin
      dipr:=dip:=(tottrans-trans)*diprecsize;
      if t=dipval.dip(2) then b:=dipval.dipr(10);
      if t2<>dipval.dip(1) then
      write(out,"nl",1,<:**diprec :>,t,t2,dipval.dip(1),dipval.dip(2));
    end;
    if b<0 then write(out,"nl",1,"*",2,<:branching ratio<0 :>,t,t2,b);
  if list then
  begin
    write(out,"nl",1);
    writestate(out,L,n,l,J); write(out,"sp",3);
    writestate(out,L2,n2,l2,J2);
    write(out,<< ddd.d>,b);
  end;
  nzero:=nzero and b>brmin and b>0;
  end nzero;
  if -,nzero then begin
    termsbrmincrit:=termsbrmincrit+1;
    dropped:=dropped+1;
    end;
  end;
end diagram>1;
if nzero then begin
written:=written+1;
termswritten:=termswritten+1;
stateN0:=idx(m);
n:=nv(m); l:=lv(m);
tauN0:=tauv(m);
if proc then
begin
  chars:=0;
  if first then
  begin
chars:=chars+write(out,<:
<*:>);
timing(out,<:diagrams:>,false);
chars:=chars+write(out,"nl",1,<:written :>,termstot,
                       "nl",1,<:dropped :>,termsbrmincrit);
chars:=chars+write(out,<:
*>
<10>:>,<<d>,<:if maxdiagram>=:>,diagram,
   <: then
begin
simproc:=r:=r:>);
outendcur(0);
if lookuptail(diagname,tail)=0 then
begin
  tail(6):=systime(7,0,0.0);
  tail(10):=diagram;
  changetail(diagname,tail);
end;
end first;
  first:=false;
end else
if printdiagram then
begin
  J:=Jv(m); L:=Lv(m);
  chars:=write(out,<<d>,<:<10>+N0(:>);
  chars:=chars+writestate(out,L,n,l,J);
  chars:=chars+write(out,<:)*:>);
end;
A:=1;
for q:=1 step 1 until diagram-1 do begin
  i:=curstates(q);
  state:=idx(i);
  nstar:=nsv(i);
  j:=curstates(q+1);
  state2:=idx(j);
  nstar2:=nsv(j);
  if nstar<nstar2 then
  begin t:=state; t2:=state2; end else
  begin t2:=state; t:=state2; end;
  tottrans:=dipindex(t2);
  found:=false;
  trans:=trv(if nstar<nstar2 then j else i);
  for trans:=trans step -1 until 1 do
  begin
    dipr:=dip:=(tottrans-trans)*diprecsize;
    if t=dipval.dip(2) then 
    begin
      A:=A*dipval.dipr(7)/10;
      found:=true;
    end found;
    if t2<>dipval.dip(1) then write(out,"nl",1,<:**diprec :>);
  end for trans;
  if -,found then write(out,<:**diprec A:>,t,t2);
  if list then
  begin
    n:=nv(i); l:=lv(i); J:=Jv(i); L:=Lv(i);
    write(out,"nl",1,"*",1);
    writestate(out,L,n,l,J); write(out,"sp",1);
    n2:=nv(j); l2:=lv(j); J2:=Jv(j); L2:=Lv(j);
    writestate(out,L2,n2,l2,J2);
    write(out,A);
  end list;
  if printdiagram then begin
    n:=nv(i); l:=lv(i); J:=Jv(i); L:=Lv(i);
    chars:=chars+write(out,<<d>,<:A(:>);
    chars:=chars+writestate(out,L,n,l,J);
    chars:=chars+write(out,<:,:>);
    n2:=nv(j); l2:=lv(j); J2:=Jv(j); L2:=lv(j);
    chars:=chars+writestate(out,L2,n2,l2,J2);
    chars:=chars+write(out,<:):>);
    if chars>72-14 then chars:=write(out,"nl",1,"sp",5);
    chars:=chars+write(out,"*",1);
  end printdiagram;
  end q loop;
if printdiagram then chars:=chars+write(out,<<d>,<:(:>);
<*
for j:=low step 1 until m do begin
for q:=1 step 1 until diagram do begin
correction 81-02-06*>
Bvic:=false;
j:=low-1;
for j:=j+1 while -,Bvic and j<=m do begin
q:=0;
for q:=q+1 while -,Bvic and q<=diagram do begin
  if curstates(q)=j then begin
  state:=idx(j);
  n:=nv(j); l:=lv(j); J:=Jv(j); L:=Lv(j); nstar:=nsv(j);
  tau:=tauv(j);
  if j=curstate then tau:=tau*tauf;
  if printdiagram then begin
    if chars>72-15 then chars:=write(out,"nl",1);
    chars:=chars+write(out,<<d>,<:+:>,if delt>0 then <:S*:> else <::>,<:exp(-a(:>);
    chars:=chars+writestate(out,L,n,l,J);
    chars:=chars+write(out,<:)*t):>);
  end printdiagram;
  B:=A;
<*
  for k:=low step 1 until m do begin
  for p:=1 step 1 until diagram do begin
  correction 81-02-06*>
  k:=low-1;
  Bvic:=abs B<Bminmin;
  for k:=k+1 while -,Bvic and k<=m do begin
  p:=0;
  for p:=p+1 while -,Bvic and p<=diagram do begin
    if curstates(p)=k and k<>j then begin
      state2:=idx(k);
      tau2:=tauv(k);
      if k=curstate then tau2:=tau2*tauf;
      B:=B/(1/tau2-1/tau);
      if printdiagram then begin
        n2:=nv(k); l2:=lv(k); J2:=Jv(k); L2:=Lv(k);
        n:=nv(m);  l :=lv(m); J :=Jv(m); L :=Lv(m);
        if chars>72-15 then chars:=write(out,"nl",1,"sp",5);
        chars:=chars+write(out,<<d>,<:/(a(:>);
        chars:=chars+writestate(out,L2,n2,l2,J2);
        chars:=chars+write(out,<:)-a(:>);
        chars:=chars+writestate(out,L,n,l,J);
        chars:=chars+write(out,<:)):>);
      end printdiagram;
      end curstate=k;
      Bvic:=abs B<Bminmin;
      end p;
      end k;
      Bcoeff(q):=B;
      Scoeff(q):=j;
      Bvic:=abs B<Bminmin;
      if Bvic and list then write(out,"nl",1,<:*victim :>,j,q,state,B,Bminmin);
    end curstate=k;
    end q;
    end j;
if proc then
begin
  Ball:=false;
  tauall:=true;
  if Bvic then else
  for i:=1 step 1 until diagram do
  begin
    Ball:=Ball or Bcoeff(i)>Bmin;
    tauall:=tauall and tauv(Scoeff(i))<2*tmax*tauN0;
  end diagram;
  if -,Ball then termsBcrit:=termsBcrit+1 else
  if -,tauall then termstaucrit:=termstaucrit+1 else
    termstot:=termstot+1;
  if Ball and tauall then
  begin
    chars:=write(out,"nl",1,<:+N:>,<<d>,stateN0,<:*(:>);
    for i:=1 step 1 until diagram do
    begin
      B:=Bcoeff(i); j:=Scoeff(i);
      state:=idx(j);
      if chars>72-14 then chars:=write(out,"nl",1,"sp",3);
      chars:=chars+write(out,if B<0 then <:-:> else
        if i=1 then <::> else <:+:>,
        <:E:>,<<d>,state);
      if delt>0 and false then
      begin
      <*old version now this correction is multiplied directly on the exp*>
      an:=delt/tauv(j); <*tau in ns and delt in ns*>;
      B:=B*sinh(an)/an;
      end;
      if B<>1.0 then chars:=chars+write(out,<:*:>,<<d.dddddddd'd>,abs B);
    end diagram;
  chars:=chars+write(out,<:):>);
  end Ball and tauall;
end proc;
if printdiagram then
  chars:=chars+write(out,<:):>);
end nzero;
end writediagram;

for i:=1 step 1 until diagram do s(i):=curstate+i-1;
termsbrmincrit:=termsdropped:=termswritten:=searches:=terms:=0;
j:=max; nzero:=more:=true;
first:=true;

for j:=j while s(1)=curstate and more do begin
qmin:=1;
nzero:=true;
for q:=q while more and nzero and diagram>1 do begin
for q:=qmin,q+1 while q<diagram and nzero do begin
  i:=s(q);
  state:=idx(i);
  l:=lv(i); J:=Jv(i); L:=Lv(i); nstar:=nsv(i);
  j:=s(q+1);
  state2:=idx(j);
  l2:=lv(j); J2:=Jv(j); L2:=Lv(j); nstar2:=nsv(j);
  nzero:=if abs(l-l2)<>2 then false else
         if abs(nstar-nstar2)<='-4 then false else
         if abs(J-J2)>2 then false else
            abs(L-L2)<=2;
  if nzero then 
  begin
  if nstar>nstar2 then write(out,<:<'nl'>**nstar>nstar2 :>,state,state2);
  tottrans:=dipindex(state2);
  trans:=trv(j);
  if trans=0 then write(out,<:<'nl'>**trans=0 :>,state,state2);
  repeat
    dipr:=dip:=(tottrans-trans)*diprecsize;
    trans:=trans-1;
  until trans=0 or state=dipval.dip(2);
  if state=dipval.dip(2) then
  begin
    if dipval.dip(1)<>state2 then write(out,
        <:<'nl'>**diprec :>,state,state2,dipval.dip(1));
    nzero:=nzero and dipval.dipr(10)>brmin;
  end else write(out,<:<'nl'>**state not found:>,state,state2,tottrans);
  if nzero then qmin:=q;
  end;
  if test and nzero then
  begin
    write(out,"nl",1,q);
    n:=nv(i);
    n2:=nv(j);
    writestate(out,L,n,l,J); write(out,"sp",1);
    writestate(out,L2,n2,l2,J2);
  end test;
  end for q:=qmin;
q:=q-1;
if -,nzero and q<=diagram then begin
  s(q+1):=s(q+1)+1;
  qmin:=if q>=1 then q else 1;
  for i:=q+2 step 1 until diagram do s(i):=s(i-1)+1;
  more:=s(q+1)<=max-diagram+q+1;
  nzero:=more;
  if test then begin
    write(out,"nl",1,<:qmin q :>,qmin,q+1,"sp",5);
    for i:=q+1 step 1 until diagram do write(out,"sp",1,s(i));
    end test;
  end else begin more:=false; end;
  if test then begin
    write(out,"nl",1);
    for i:=1 step 1 until diagram do
    begin
    k:=s(i);
    state:=idx(k);
    n:=nv(k); l:=lv(k); J:=Jv(k); L:=Lv(k);
    writestate(out,L,n,l,J);
    end;
    end;
  searches:=searches+1;
  end -,nzero and q<=daigram;
if test then write(out,"nl",1,<:search last index:>);
<*will this work*>
if nzero and s(diagram)<=max then begin
k:=s(diagram)-1;
for k:=k+1 while k<=max do begin
  s(diagram):=k;
  if s(1)=curstate then begin
    if test then begin
    write(out,<:<10>term :>);
    for p:=1 step 1 until diagram do begin
      i:=s(p);
      state:=idx(i);
      n:=nv(i); l:=lv(i); J:=Jv(i); L:=Lv(i);
      write(out,s(p)); writestate(out,L,n,l,J);
      end;
    end test;
    terms:=terms+1;
    writediagram(s(diagram),curstate,diagram,s,termsdropped,termswritten);
    end;
  end;
end write nonzero term;
more:=false;
j:=diagram;
for j:=j-1 while j>0 and -,more do begin
  if s(j)<max-diagram+j then begin more:=true; q:=j; end;
  end;
if more then begin
  qmin:=if q<=1 then 1 else if qmin>=q then q-1 else qmin;
  s(q):=s(q)+1;
  for q:=q+1 step 1 until diagram do s(q):=s(q-1)+1;
  end;
end main loop;
if proc and terms>0 then write(out,<:;:>);
if dsurvey or test then
write(out,"nl",1,if proc then <:comment :> else <::>,
  <:terms = :>,terms,<: dropped = :>,termsdropped,
 <: terms written = :>,termswritten,<:   searches = :>,searches,
  if proc then <:;:> else <::>);
end generate sum;


termstot:=termsBcrit:=termstaucrit:=0;
idf:=0;

Bminmin:=Bmin/100;

raf:=0;
diagname(1):=long <:diagr:> add 'a';
diagname(2):=long <:m:>;
if lookuptail(diagname,tail)=0 then
begin
  tail(10):=0;
  changetail(diagname,tail);
end;
statesincalc:=-1;
timing(out,<:diagram generation start:>,true);
for i:=0 step 1 until maxstates-1 do
begin
  getstate(states,i,n,J,seriesindex,nstar,Ecm,L,0);
  computed:=getcomputed(states,i,0,0.0);
  if computed and nstar<=nsmax then
  begin
   statesincalc:=statesincalc+1;
   idx(statesincalc):=i;
   ser:=seriesindex*seriessize;
   l:=series.ser(1);
   nv(statesincalc):=n; lv(statesincalc):=l;
   Jv(statesincalc):=J; Lv(statesincalc):=L;
   nsv(statesincalc):=nstar; trv(statesincalc):=gettransno(states,i);
   tauv(statesincalc):=gettau(states,i);
  end;
end;
quicksort(1,statesincalc,nsv,idx,nv,lv,Jv,Lv,trv,tauv);

if dsurvey then
begin
write(out,"nl",3);
for i:=0 step 1 until statesincalc do
  write(out,"nl",1,
    <<dd>,<:state :>,idx(i),<<dd.ddd>,<: n* :>,nsv(i));
end;

lower:=i:=-1;
idf:=0;
for i:=i+1 while lower<0 and i<=statesincalc do
begin
  if idx(i)=curstate then lower:=i;
end;
if lower<0 then alarm(<:curstate not found:>);
if dsurvey or test then write(out,"nl",1,<:lower :>,lower);

if proc then
begin
  res:=connectcuro(<:simproctxt:>);
  if res<>0 then unstackcuro;
  write(out,<:
;ali time 5 0
mode list.yes
lookup simproctxt
clear user simproc
simproc=set 25 disc3
scope user simproc
lookup rydlist
if ok.yes
mode 15.yes
simproc=algol details.8.8
:>);
writedate(out,0.0);
write(out,"nl",1);
writeatsym(out,S,atno,Z); write(out,"sp",4);
n:=nv(lower); l:=lv(lower); J:=Jv(lower); L:=Lv(lower);
writestate(out,L,n,l,J);
write(out,<:
external real procedure simproc(t,maxdiagram,N);
value t,maxdiagram; real t; integer maxdiagram;
array N;
if t<-.5 then simproc:=:>,curstate,<: else
begin
real :>);
for i:=lower step 1 until statesincalc do
begin
  write(out,"nl",if i mod 10 =7 then 1 else 0,
   <:E:>,<<d>,idx(i),if idx(i)<10 then "sp" else false,1,
  <:,N:>,<<d>,idx(i),if idx(i)<10 then "sp" else false,1,<:,:>);
end for i;
write(out,<:r;
r:=0;
comment maxdiagram= :>,maxdiagram,"nl",1);
writeatsym(out,S,atno,Z); write(out,"sp",4);
writestate(out,L,n,l,J);
if delt>0 then write(out,
   "nl",1,<:delta t(slit)           :>,delt,<: ns:>,
   "nl",1,<:n* max                  :>,nsmax,
   "nl",1,<:minimum branching ratio :>,brmin,
   "nl",1,<:minimum coefficient     :>,Bmin);
for i:=0 step 1 until statesincalc do
  begin
  write(out,"nl",if i mod 4=0 then 1 else 0,
            "sp",if i mod 4<>0 then 2 else 0);
  n:=nv(i); l:=lv(i); J:=Jv(i); L:=Lv(i); nstar:=nsv(i);
  writestate(out,L,n,l,J);
  write(out,"sp",1,<<dd.ddd>,nstar,"sp",1,
    <:=:>,<<ddd>,idx(i),if i<statesincalc then <:,:> else <::>);
  end comment;
write(out,<:;:>);
for i:=lower step 1 until statesincalc do
begin
  tau:=tauv(i);
  if i=lower then tau:=tau*tauf;
  write(out,"nl",if i mod 1=0 then 1 else 0,
    "sp",if i mod 1<>0 then 1 else 0,
    <:E:>,<<d>,idx(i),if idx(i)<10 then "sp" else false,1,
      <::=exp(-t/:>,<<ddd.dddddddd>,tau,
    <:):>);
    if delt>0 then write(out,<:*:>,<<d.ddddddd>,sinh(delt/tau)/delt*tau);
    write(out,<:; N:>,<<d>,idx(i),if idx(i)<10 then "sp" else false,1,
    <::=N(:>,<<dd>,idx(i),<:);:>);
end higher;
end proc;

for diag:=statesincalc-lower step -1 until lower do begin
diagram:=statesincalc-lower-diag+1;
if diagram<=maxdiagram then begin
  if dsurvey or test then write(out,<<d>,<:<10><10>diagram :>,diagram);
  generatediagramsum(lower,diagram,statesincalc);
  if -,proc then outendcur(10);
  end;
end;
if proc then
begin
for i:=1,1 step 1 until maxdiagram do write(out,"nl",1,<:end:>);
timing(out,<:diagram:>,false);
write(out,<<  ddddd>,
  "nl",1,<:terms total        :>,termstot,
  "nl",1,<:terms written      :>,termswritten,
  "nl",1,<:terms dropped B    :>,termsBcrit,  <: B min   :>,<<d.d'-dd>,Bmin,
  "nl",1,<:terms dropped brmin:>,<< ddddd>,termsbrmincrit,
     <<d.dd'-dd>,<: brmin :>,brmin,
  "nl",1,<:terms dropped tau  :>,<< ddddd>,termstaucrit,
    <: tau max :>,<<  ddddd>,2*tmax,<: tau0:>,
  "nl",1,<:blocksread       :>,blocksread,
"nl",1,<:simproc;
end;
:>);
end;
if res=0 and proc then closeout;
if dsurvey or test then
write(out,"nl",2,<:termswritten        :>,termswritten,
          "nl",1,<:terms dropped brmin :>,termsbrmincrit,
          "nl",1,<:blocksread          :>,blocksread);
timing(out,<:diagram end:>,false);
if proc then
write(out,"nl",2,<:maxdiagram           :>,maxdiagram,
          "nl",1,<:terms total          :>,termstot,
          "nl",1,<:terms dropped B      :>,termsBcrit,
          "nl",1,<:terms dropped tau    :>,termstaucrit,
          "nl",1,<:blocksread           :>,blocksread);
outendcur(10);
end writediagramproc;
▶EOF◀