DataMuseum.dk

top - metrics - download

    Length: 7680 (0x1e00)
    Types: TextFile
    Names: »gozeta«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦1248b0c55⟧ »gobib« 
            └─⟦this⟧ 

TextFile

;gosav time.300 lines.3000
flzeta=set 60
permanent flzeta.17
flzeta=edit algflinda
d7,r/164/190/,g2/da/dazeta/,r/)//,r/x.no/x.yes/

l./6)/,i/
       If m = 100: Coriolis zeta constants can be included
       in the calculations, but only for degenerate vibrations
       in a molecule with a C3-axis.
/,l./13)/,i/
       h)  The number of observed zeta constants.
       i)  For each of these the sym. species no., coordinate
           no., value and uncertainty.
/,l./fugal;/,r/;/,zeta;/

l./NC,NT/,r/NT/NT,NZ/,l2,r/(NM+1)*4/NM*5+4/,l28,r/4/5/,
l1,r/100/100,122/,l2,r/4*j/5*j-1/

l./read(in/,r?;?;   zeta:= m//100 = 1;?,
l1,r?//10?//10 mod 10?,l3,i/
if zeta then begin
   k:= G; l:= BL end else k:= l:= 1;
/,l2,r/;/,Zpl(1:l,1:k);/,i/
integer zetapl;
/,l15,r/;/;  zetapl:= 1;/
g23/track(4*inm/track(5*inm-1/,r/1;/if zeta then N3 else 1;

if zeta then begin
open(z,4,string track(5*inm+4),0); tail(1):= 1;
set(z,track(5*inm+4),tail); close(z,true) end;
/,l./hb:=/,r/hb/ha:= hb/,l2,r//integer zc3;  /,l1,i/
integer array perm(1:Na);
/,l./array IP/,d,g1/hb/ha/,l5,i/
end end;
if zeta then begin
  for j:=1 step 1 until BL do Zpl(j,ig):= 0;
  read(in,n); NO:= NO+n; Obs(Ostep):= n; hb:= n<>0;
  if hb then for i:=1 step 1 until n do begin
    read(in,j); Obs(Ostep):= j; Zpl(j,ig):= 1;
    for j:=1,2,3 do read(in,Obs(Ostep))
end end;
/,l4,r/Ib/if ha or hb then begin
array IP(1:3);
Ib/,l./UX/,r/k,1,3)/k,1,3);/,l1,d,i/
if hb then begin
  comment A C3-symmetry axis is searched for and the
          permutation of atoms by a C3-operation is found,
                C3 ( X(i) )  =  X( perm(i) )             ;
  zc3:= 0; s:= IP(1)*'-6;
  for i:=1,i+1 while zc3=0 do
    if i>3 then begin write(res,<:
***symmetry axis not found, inm, ig = :>,<<dddd>,inm,ig);
      goto stop end else
    if abs(IP(i mod 3 + 1)-IP((i+1) mod 3 + 1))<s then zc3:= i;
  j:= zc3 mod 3 + 1; k:= (zc3+1) mod 3 + 1;  s:= sqrt(0.75);
  for i:=1 step 1 until Na do begin
    X(i,j):= -UX(i,j)*0.5 - UX(i,k)*s;
    X(i,k):=  UX(i,j)*s   - UX(i,k)*0.5
  end;
  for i:=1 step 1 until Na do begin
    perm(i):= l:= 0;
    for j:=1,j+1 while l=0 do
      if j>Na then begin write(res,<:
***C3 permutation not found, inm, ig = :>,<<dddd>,inm,ig);
        goto stop end else begin
        l:= j;
        for k:=1,2,3 do if abs(X(i,k)-UX(j,k))>'-6 then l:= 0;
        if l>0 then perm(i):= l
  end end;
end end ha or hb;
/,l./comment/,i/
if zeta then hb:= Zpl(ibl,ig)<>0;
/,l./open(V/,r/4*inm+3/5*inm+2/,l./if hb/,r/hb/ha or hb/,
l./end hb/,r/hb/ha or hb/

l./comment/,i"

comment If C.D. or zeta constants should be calculated
        the matrix K*B*Utr is formed in B;
if ha or hb then begin
array Bi(1:3), I(1:if red<NT then NT else red);
for i:=1 step 1 until n do
for k:=N3-3 step -3 until 0 do begin
  for j:=1,2,3 do Bi(j):= sum(B(i,k+l)*U(j,l),l,1,3);
  for j:=1,2,3 do B(i,k+j):= Bi(j)
end;
rj:= n-red; rl:= rj*(rj+1)//2;
for j:=1 step 1 until N3 do begin
  l:= rj; ri:= rl;
  for i:=1 step 1 until red do begin
    l:=l+1; I(i):= sum(K(ri+k)*B(k,j),k,1,l);
    ri:= ri+l end;
  for i:=1 step 1 until red do B(i,j):= I(i)
end j;

if ha then begin array D(1:n,1:NT);",
l./if hb/,d1,r/4*inm+4/5*inm+3/,
l3,r/n do/red do/,l1,d2,l./BU/,g7/BU(/B(i,/

l./rj:= n-red/,d6,l./end hb/,r/hb/end ha or hb/,i"
end ha;

if hb then begin
comment C3-rotated displacement vectors are formed
        and permutated,
               C3 ( B(perm(i) ) = U(C3) * B(i).
        Coriolis matrices are then calculated and stored;
array brot(1:N3);
open(z,4,string track(5*inm+4),0);
swoprec(z,zetapl+red*red); Zpl(ibl,ig):= zetapl;
rj:= zc3 mod 3 + 1; rk:= (zc3+1) mod 3 + 1; s:= sqrt(0.75);
for i:=1 step 1 until red do begin
  for l:=N3-3 step -3 until 0 do begin
    k:= perm(l//3+1); W:= M(k); k:= k*3-3;
    brot(k+rj):= (-B(i,l+rj)*0.5 - B(i,l+rk)*s)*W;
    brot(k+rk):= ( B(i,l+rj)*s   - B(i,l+rk)*0.5)*W;
    brot(k+zc3):= B(i,l+zc3)*W
  end;
  VV:= sum(brot(l)*B(i,l),l,1,N3)**2;
  for j:=1 step 1 until red do begin W:= 0;
    for l:=N3-3 step -3 until 0 do
      W:= W + brot(l+rj)*B(j,l+rk) - brot(l+rk)*B(j,l+rj);
    z(zetapl):= W/sqrt(1-VV); zetapl:= zetapl+1;
end j end i;
close(z,true);
",l./track(4*inm/,g1/4*inm+1/5*inm/,l1,i/
if zeta then NT:= NT+100;
/,l./close(z/,i/
if zeta then begin n:= 4;
for ibl:=1 step 1 until BL do
for  ig:=1 step 1 until  G do begin
   if n=4 then begin m:= m+1; n:= 0; z(m):= 0 end;
   n:= n+1; pack(Zpl(ibl,ig))
end;
z(m):= z(m) shift ((4-n)*12) end;
/,l2,r/Dpl/Dpl, Zpl/

l./Oc,/,r/Oc/Oc, Oz/,l./ha:=/,r/ ha:=/
/,d,l./track(4*/,r/4*inm+1/5*inm/,l3,i/
zeta:= NT>=100; NT:= NT mod 100;
/,l4,i/
if zeta then begin
   k:= G; j:= BL end else j:= k:= 1;
/,l2,r/;/,Zpl(1:j,1:k);/,l./close(z/,i/
   if zeta then begin n:= 4;
   for ibl:=1 step 1 until BL do
   for  ig:=1 step 1 until  G do begin
      if n=4 then begin m:=m+1; n:=0; h:= z(m) end;
      n:= n+1; Zpl(ibl,ig):= split
   end end;
/,l6,r/hb/ha/,l1,i/
if zeta then begin
   Oz:= NV*2 + NC*11 + (if centrifugal then 2 else 1) + On;
   NZ:= Obs(Oz) end else NZ:= 0; 
hb:= NZ<>0;
/,l1,r/NC/NC+NZ/,l4,r/hb/ha/,l2,r/hb/ha/,l4,i/
if hb then begin
   j:= NZ; k:= 5 end else j:= k:= 1;
/,l5,r/;/, zmat(1:j,1:k);/

l1,r/hb/ha/,l7,i/
if hb then begin
   for i:=1 step 1 until NZ do begin
      for j:=1,2,3 do zmat(i,j):= Obs(Oz+4*i-4+j);
      zmat(i,5):= Obs(Oz+4*i)
end end;
/,l./-,hb/,r/hb/ha/,l4,r/4*inm+3/5*inm+2/,
l22,r/4*inm+2/5*inm+1/,l./if hb/,r/hb/ha/,
l1,r/4*inm+4/5*inm+3/,l./end U/,d,i"
end ha;

if hb then begin k:=Zpl(ibl,ig);
if k<>0 then begin
comment The Coriolis C-matrix is transformed by U,
             Zeta =  U * C * Utr                 ;
real W;  array Cor(1:red,1:red), h(1:n,1:n);
open(z,4,string track(5*inm+4),0);
k:= k-1; inrec(z,red*red+k);
for i:=1 step 1 until red do
for j:=1 step 1 until red do Cor(i,j):= z(kstep);
close(z,true);
for i:=1 step 1 until red do
for j:=1 step 1 until red do
   h(i,j):= sum(Cor(i,l)*U(j,l),l,1,red);
for i:=1 step 1 until red do
for j:=1 step 1 until red do
   Cor(red+1-i,red+1-j):= sum(U(i,l)*h(l,j),l,1,red);
k:= 128//(NK+1); open(z,4,<:atrack:>,0);
setposition(z,0,Na//k); swoprec(z,(Na mod k)*(NK+1));
for m:=1 step 1 until NZ do if zmat(m,1)=ibl then begin
  l:= zmat(m,2); H:= zmat(m,5); zmat(m,4):= Cor(l,l);
  if H<>0 then begin
    for i:=1 step 1 until n do
    for j:=i step 1 until n do begin
      W:= 0;
      for k:=l-1 step -1 until 1,l+1 step 1 until red do
      W:= W - (L(i,k)*L(j,l)+L(i,l)*L(j,k))
             *Cor(k,l)/(f(red+1-k)-f(red+1-l));
      h(i,j):= W*(if i=j then 1 else 2);
    end;
    Na:= Na+1; k:=1; q:=0; swoprec(z,NK+1);
    W:= z(NK+1):= (zmat(m,3)-zmat(m,4))/H; s:= s + W*W;
    for l:=1 step 1 until NKT do begin
      p:=K(k) shift (-36) extract 12;
      if p>2048 then k:= (p mod 2048)*2+k else begin
        q:= q+1; p:= p+p+k-2; W:= 0;
        for k:=k step 2 until p do
          if K(k) extract 12 = inmbl then begin
          i:= K(k) shift (-12) extract 12;
          j:= K(k) shift (-24) extract 12;
          W:= W + K(k+1)*h(i,j);
        end k;
        z(q):= W/H
end end end end l,m;
close(z,true);
end end hb end U;
",l./track(4*/,r/4*inm+4/5*inm+3/,
l./if hb/,r/hb/ha/,l1,l./if hb/,r/hb/ha/
l./end NC<>0/,r/+1/+1;
if zeta then begin On:=On+NZ*4+1; NO:= NO+NZ end;
if hb then begin
  if linecount+NZ>56 then writepage else begin cr; cr end;
  write(res,<:Zeta-constants:

Species,no.     Obs.       Calc.   Obs.-calc.   delta:>);
  linecount:= linecount+2; cr;
  for i:=1 step 1 until NZ do begin
    cr; write(res,<<ddddd>,zmat(i,1),zmat(i,2),<<____-d.dddd>,
              zmat(i,3),zmat(i,4),zmat(i,3)-zmat(i,4),zmat(i,5))
end end;/
f
i flzeta
▶EOF◀