|
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: 18432 (0x4800)
Types: TextFile
Names: »alglavib«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦7e928b248⟧ »algbib«
└─⟦this⟧
;gosav time 100
lookup bmatrix
if ok.no
(i extbmatrix)
lavib=set 130
permanent lavib.15
lavib=algol index.no
\f
lavib
Large-Amplitude-Vib-program 17-9-1974. GOS.
begin
comment The input rules are:
1) Two textstrings in < >. The second specifies input area
for definitions of internal vib-coordinates.
2) The number of atoms in the molecule (N).
3) The number of free internal coordinates in constrained
model (NF). NF = 0, if no constraints.
4) The number of symmetry species BL, and for each of
these the number of internal vib-coordinates.
5) The indices of the free internal coordinates, according
to their order of definition.
6) For each atom: Up to three coordinates (last del.: nl)
7) 3N-6 internal coordinates defined by the following
types of constructions:
p dist: real i1 j1 i2 j2 . . ip jp
p angle: real i1 j1 k1 . . . ip jp kp
p outo: real i1 j1 k1 l1 . . ip jp kp lp
or p tors: real i1 j1 k1 l1 . . ip jp kp lp
indicating the desired bondlengths and angles, and
p sum: i1 j1 . . . ip jp
indicating sums (or differences, if the signs of i and
j differ) of previously specified internal coordinates.
These coordinates themselves are omitted in determining
the cartesian coordinates. Terminate by p = 0. NB: An angle
= 180 deg. counts for two internal coordinates. If no in-
ternal coordinates are specified at all, inertial moments
are calculated from the originally given cartesian coor-
dinates (see 3. above).
8) N atomic masses. mass(i) = -1 means mass(i):= mass(i-1).
9) The calculation may be repeated several times after
changing one or more internal coordinates by specifying
the number of simultaneous changes, p, and for each of
these, the number of the particular internal coordinate
as appearing in the original specification list (see 7)
and the new value. The calculations are stopped by p = 0.
If a negativ p is specified, the Eckart conditions are
applied in calculating cartesian coordinates for the dis-
torted structure. Otherwise the inertial tensor is diago-
nalized (PAS-system);
integer i,j,k,l,m,n,ns,N,N3,NF,BL,cycl,bout,m0;
boolean nl, sp, closeres, eckart;
array head(1:12), binp(1:1), IP(1:3);
zone res(128,1,stderror);
closeres:= outmedium(res); bout:= -1;
nl:= false add 10; sp:= false add 32;
readhead(in,head,1); readhead(in,binp,1);
read(in,N,NF,BL); N3:= abs N*3; eckart:= false;
i:= 1; write(res,<:<12>:>,nl,4,string head(increase(i)),nl,2);
begin
integer array S(1:BL,1:2),CF(1:NF);
array X, Xp(1:N3), mass(1:abs N);
for i:=1 step 1 until BL do read(in,S(i,1));
read(in,CF);
for i:=1 step 1 until NF do CF(i):= 3+CF(i);
begin
integer Ni,Nj,Nk,Nl,p,q;
real type,rad,r,v,s1,s2;
integer array t(1:N3+N3,1:5);
array H(1:1), g(1:N3+N3);
real procedure vector(e,Ni,Nj);
value Ni,Nj; integer Ni,Nj; array e;
begin
real l,r; integer k;
r:= 0;
for k:=1 step 1 until 3 do begin
e(k):= l:= X(Nj+k)-X(Ni+k); r:= r+ l*l end;
r:= vector:= sqrt(r); r:= 1/r;
for k:= 1 step 1 until 3 do e(k):= e(k)*r
end vector;
real procedure dot(a,b);
array a,b;
begin real d; integer k;
d:= 0; for k:=1 step 1 until 3 do d:= d+ a(k)*b(k);
dot:= d
end dot;
real procedure cross(a,b,c);
array a,b,c;
begin real r; integer k;
c(1):= a(2)*b(3) - a(3)*b(2);
c(2):= a(3)*b(1) - a(1)*b(3);
c(3):= a(1)*b(2) - a(2)*b(1);
r:= 0; for k:=1 step 1 until 3 do r:= r+ c(k)**2;
cross:= r
end cross;
rad:= pi/180; Ni:= -3; k:= 0;
for i:=1 step 1 until N do begin
Ni:= Ni+3;
for j:=1,j+1 while k<>10 and j<=3 do begin
read(in,X(Ni+j)); repeatchar(in); readchar(in,k) end;
for j:=j step 1 until 3 do X(Ni+j):= 0;
end i;
if N<0 then begin
N:= -N; if readstruct(res,X,N) then goto stop
end;
n:= 0; read(in,p);
if p=0 then begin
if atomic(mass,N) then goto stop;
goto diag
end;
newtype:
readstring(in,H,1); type:= H(1);
if type = real <:dist:> then begin
read(in,r);
for m:=1 step 1 until p do begin
read(in,i,j); n:= n+1; g(n):= r;
t(n,1):= 1; t(n,2):= i; t(n,3):= j; t(n,4):= t(n,5):= 0;
write(res,nl,1,<:distance :>,<<dd>,i);
if j>9 then write(res,<<-dd>,-j) else
write(res,<<-d>,-j,sp,1);
write(res,<: = :>,<<dd.ddddd>,r)
end; type:= 0
end;
if type = real <:angle:> then begin
read(in,v);
for m:=1 step 1 until p do begin
read(in,i,j,k); n:= n+1; g(n):= v*rad;
t(n,1):= 2; t(n,2):= i; t(n,3):= j; t(n,4):= k; t(n,5):= 0;
write(res,nl,1,<:angle :>,<<dd>,i); q:= 0;
if j>9 then write(res,<<-dd>,-j) else
begin write(res,<<-d>,-j); q:= q+1 end;
if k>9 then write(res,<<-dd>,-k) else
begin write(res,<<-d>,-k); q:= q+1 end;
write(res,sp,q,<: = :>,<<-ddd.dd>,v,<: degrees.:>)
end; type:= 0
end;
if type = real <:outo:> then begin
read(in,v);
for m:=1 step 1 until p do begin
read(in,i,j,k,l); n:= n+1; g(n):= v*rad;
t(n,1):= 3; t(n,2):= i; t(n,3):= j; t(n,4):= k; t(n,5):= l;
write(res,nl,1,<:outo :>,<<dd>,i); q:= 0;
if j>9 then write(res,<<-dd>,-j) else
begin write(res,<<-d>,-j); q:= q+1 end;
if k>9 then write(res,<<-dd>,-k) else
begin write(res,<<-d>,-k); q:= q+1 end;
if l>9 then write(res,<<-dd>,-l) else
begin write(res,<<-d>,-l); q:= q+1 end;
write(res,sp,q,<: = :>,<<-ddd.dd>,v,<: degrees.:>)
end; type:= 0
end;
if type = real <:tors:> then begin
read(in,v);
for m:=1 step 1 until p do begin
read(in,i,j,k,l); n:= n+1; g(n):= v*rad;
t(n,1):= 4; t(n,2):= i; t(n,3):= j; t(n,4):= k; t(n,5):= l;
write(res,nl,1,<:tors :>,<<dd>,i); q:= 0;
if j>9 then write(res,<<-dd>,-j) else
begin write(res,<<-d>,-j); q:= q+1 end;
if k>9 then write(res,<<-dd>,-k) else
begin write(res,<<-d>,-k); q:= q+1 end;
if l>9 then write(res,<<-dd>,-l) else
begin write(res,<<-d>,-l); q:= q+1 end;
write(res,sp,q,<: = :>,<<-ddd.dd>,v,<: degrees.:>)
end; type:= 0
end;
if type = real <:sum:> then begin
for m:=1 step 1 until p do begin
read(in,i,j); n:= n+1;
if abs i > abs j then begin k:= i; i:= j; j:= k end;
t(n,1):= 5; t(n,2):= i; t(n,3):= j;
write(res,nl,1,<:sum of : :>,<<d>,i,<: and :>,j)
end; type:= 0
end;
comment additional types can be included here;
if type<>0 then begin
write(res,nl,2,string type,<: : Type undefined.:>);
goto stop
end;
read(in,p); if p<>0 then goto newtype;
if atomic(mass,N) then goto stop;
s1:= 100; cycl:= 0;
rep:
begin
array aa(1:N3,1:N3), bb(1:N3);
cycl:= cycl+1; m:= 0; s2:= s1; s1:= 0;
for i:=1 step 1 until N3 do
for j:=1 step 1 until N3 do aa(i,j):= 0;
for p:=1 step 1 until n do begin m:= m+1;
i:= t(p,2); j:= t(p,3); k:= t(p,4); l:= t(p,5);
Ni:= (i-1)*3; Nj:= (j-1)*3; Nk:= (k-1)*3; Nl:= (l-1)*3;
if t(p,1) = 1 then begin
array e(1:3);
r:= vector(e,Ni,Nj); bb(m):= g(p)-r;
for q:=1 step 1 until 3 do begin
aa(m,Ni+q):= -e(q); aa(m,Nj+q):= e(q) end
end else
if t(p,1) = 2 then begin
real cos,ri,rk,a,b;
array ei,ek,c(1:3);
ri:= 1/vector(ei,Nj,Ni); rk:= 1/vector(ek,Nj,Nk);
cos:= dot(ei,ek);
if cos+1>'-9 then begin
v:= pi/2 - arcsin(cos);
bb(m):= g(p)-v; v:= 1/sqrt(1-cos*cos);
for q:=1 step 1 until 3 do begin
aa(m,Ni+q):= a:= (ei(q)*cos- ek(q))*ri*v;
aa(m,Nk+q):= b:= (ek(q)*cos- ei(q))*rk*v;
aa(m,Nj+q):= -a-b end;
if g(p)=180*rad then v:= cross(ei,ek,c)
end else begin
if g(p)<>180*rad then begin
write(res,<:<10>***startvalue 180 of angle :>,
<<-d>,i,-j,-k,<:not allowed.:>); goto stop end;
v:= 0; for q:=1 step 1 until 3 do begin
a:= c(q):= ei(q)+ek(q); v:= v+a*a end;
bb(m):= -v;
if v<'-4 then begin
for q:= 3,q-1 while v<'-4 and q>=1 do
begin ek(q):= ek(q)+1; v:= cross(ei,ek,c) end end;
for q:=1 step 1 until 3 do begin
aa(m,Ni+q):= a:= c(q)*ri;
aa(m,Nk+q):= b:= c(q)*rk;
aa(m,Nj+q):= -a-b;
ei(q):= ei(q)-ek(q); ek(q):= c(q) end;
v:= cross(ei,ek,c)
end;
if g(p)=180*rad then begin
m:= m+1; bb(m):= 0;
for q:=1 step 1 until 3 do begin
c(q):= c(q)/v;
aa(m,Ni+q):= a:= c(q)*ri;
aa(m,Nk+q):= b:= c(q)*rk;
aa(m,Nj+q):= -a-b end
end end else
if t(p,1) = 3 then begin
real ri,rj,rl,sin,csc,cot,a,b,c;
array ei,ej,el,cij,cjl,cli(1:3);
ri:= 1/vector(ei,Nk,Ni);
rj:= 1/vector(ej,Nk,Nj);
rl:= 1/vector(el,Nk,Nl);
csc:= 1/sqrt(cross(ei,ej,cij));
cross(ej,el,cjl); cross(el,ei,cli);
cot:= dot(ei,ej)*csc; sin:= dot(cij,el)*csc;
a:= 1/sqrt(1-sin*sin); bb(m):= g(p)-arctan(a*sin);
ri:= ri*a*csc; rj:= rj*a*csc; rl:= rl*a;
for q:=1 step 1 until 3 do begin
aa(m,Ni+q):= a:= (cjl(q)-(ei(q)*csc-ej(q)*cot)*sin)*ri;
aa(m,Nj+q):= b:= (cli(q)-(ej(q)*csc-ei(q)*cot)*sin)*rj;
aa(m,Nl+q):= c:= (cij(q)*csc-el(q)*sin)*rl;
aa(m,Nk+q):= -a-b-c end
end else
if t(p,1) = 4 then begin
real ri,rl,cscj,csck,cosj,cosk;
array ei,el,ejk,cj,ck(1:3);
ri:= 1/vector(ei,Nj,Ni);
rl:= 1/vector(el,Nk,Nl);
r:= 1/vector(ejk,Nj,Nk);
cscj:= 1/cross(ei,ejk,cj); csck:= 1/cross(ejk,el,ck);
cosj:= dot(ei,ejk)*r*cscj; cosk:= -dot(el,ejk)*r*csck;
cscj:= cscj*ri; csck:= csck*rl;
v:= g(p) -
arg(-dot(cj,ck),sqrt(cross(ck,cj,ei))*sign(dot(ei,ejk)));
if abs v > pi then v:= v+(if v>0 then -pi*2 else pi*2);
bb(m):= v;
for q:=1 step 1 until 3 do begin
aa(m,Ni+q):= r:= cj(q)*cscj;
aa(m,Nj+q):= -r+cj(q)*cosj-ck(q)*cosk;
aa(m,Nl+q):= r:= ck(q)*csck;
aa(m,Nk+q):= -r+ck(q)*cosk-cj(q)*cosj end
end else
if t(p,1) = 5 then begin integer si, sj;
si:= sign(i); sj:= sign(j); i:= abs i; j:= abs j;
for q:=1 step 1 until N3 do aa(m,q):= si*aa(i,q)+sj*aa(j,q);
bb(m):= si*bb(i)+sj*bb(j); l:= 1;
for k:=i+1 step 1 until m do begin
if k=j then begin k:= k+1; l:= 2 end;
for q:=1 step 1 until N3 do aa(k-l,q):= aa(k,q);
bb(k-l):= bb(k)
end;
for k:=m-1,m do begin
bb(k):= 0; for q:=1 step 1 until N3 do aa(k,q):= 0
end; m:= m-2
end end p;
if m<N3-6 then begin
write(res,<:<10>***insufficient number of struc. param.:>);
goto stop
end;
if eckart then begin
Nj:= -3;
for j:=1 step 1 until N do begin
r:= mass(j); Nj:= Nj+3;
for i:=1,2,3 do aa(N3-i+1,Nj+i):= r;
aa(N3-5,Nj+1):= aa(N3-4,Nj+3):= -Xp(Nj+2)*r;
aa(N3-4,Nj+2):= aa(N3-3,Nj+1):= Xp(Nj+3)*r;
aa(N3-5,Nj+2):= Xp(Nj+1)*r; aa(N3-3,Nj+3):= -Xp(Nj+1)*r
end eckart betingelser;
for m:=N3-5 step 1 until N3 do
bb(m):= -sum(aa(m,j)*X(j),j,1,N3)
end else
begin array e2, ek, c(1:3);
vector(e2,0,3);
for Nk:=6,Nk+3 while cross(e2,ek,c)<'-4 do vector(ek,3,Nk);
Nk:= Nk-3; cross(e2,c,ek);
for i:=1,2,3 do begin
aa(N3-6+i,i):= 1;
aa(N3-2,i):= -ek(i); aa(N3-2,3+i):= ek(i);
aa(N3-1,i):= aa(N3,3+i):= -c(i);
aa(N3-1,3+i):= aa(N3,Nk+i):= c(i)
end;
for i:=N3-5 step 1 until N3 do bb(i):= 0
end;
begin integer array p(1:N3);
decompose(aa,p,0); solve(aa,p,0,bb);
for i:=1 step 1 until N3 do begin
r:= bb(i); s1:= s1 + r*r;
X(i):= X(i) + r end
end p;
if s1>N3*'-20 and s1<s2 then goto rep
end aa;
write(res,nl,2,<:cycles: :>,<<ddd>,cycl);
diag: begin
real Ia,Ib,Ic;
array It, my(1:3,1:3);
Ib:= 1/sum(mass(i),i,1,N);
for j:=1 step 1 until 3 do begin
Ia:= sum(X(3*i-3+j)*mass(i),i,1,N)*Ib;
for i:=j step 3 until N3 do X(i):= X(i)-Ia
end j, center_of_mass_corr.;
Ia:= sum(mass(i)*X(3*i-2)**2,i,1,N);
Ib:= sum(mass(i)*X(3*i-1)**2,i,1,N);
Ic:= sum(mass(i)*X(3*i )**2,i,1,N);
It(1,1):= Ib+Ic; It(2,2):= Ia+Ic; It(3,3):= Ia+Ib;
It(2,1):= -sum(mass(i)*X(3*i-2)*X(3*i-1),i,1,N);
It(3,2):= -sum(mass(i)*X(3*i-1)*X(3*i ),i,1,N);
It(3,1):= -sum(mass(i)*X(3*i )*X(3*i-2),i,1,N);
if -,eckart then begin
m0:= 0;
for i:=1 step 1 until N do
if mass(i)=0 then m0:= m0+1;
for i:=2,3 do for j:=i-1 step -1 until 1 do
if abs It(i,j)<'-8 then It(i,j):= 0;
tridql(3,IP,It);
for Ni:=N3-3 step -3 until 0 do begin
for j:=1,2,3 do Xp(Ni+j):= sum(It(j,k)*X(Ni+k),k,1,3);
for j:=1,2,3 do X(Ni+j):= Xp(Ni+j) end;
for i:=1,2,3 do It(i,i):= IP(i);
end -,eckart;
Ia:= It(1,1); Ib:= It(2,2); Ic:= It(3,3);
v:= 505376;
write(res,nl,2,
<:Moments of Inertia ::>,<< ddd.ddddddd>,Ia,Ib,Ic);
if eckart then
write(res,nl,1,sp,23,<< -dd.ddddddd>,It(2,1),It(3,2),It(3,1));
write(res,nl,1,<:Inertial Defect ::>,<< -dd.ddddddd>,
Ic-Ia-Ib,nl,1,<:Rotational Constants ::>,<< dddddd.dddd>,
v/Ia,v/Ib,v/Ic,nl,2,<:Masses and Coordinates ::>,nl,1);
Ni:= -3;
for i:=1 step 1 until N do begin
write(res,nl,1,<<dd.dddddd>,mass(i),sp,4); Ni:= Ni+3;
for j:=1 step 1 until 3 do
write(res,<< -dd.dddddddd>,X(Ni+j)) end;
if m0=0 then begin
bmatrix(N,BL,S,X,bout*binp(1),res); bout:= 1;
ns:= 0; for i:=1 step 1 until BL do ns:= ns+S(i,1);
end else begin
for i:=m0-1 step -1 until 0 do begin
mass(N-m0-i):= mass(N-i);
for j:=0,1,2 do Xp(3*(N-m0-i)-j):= Xp(3*(N-i)-j)
end;
N:= N-m0; N3:= N*3; n:= n-2*m0; m0:= 0;
eckart:= true; cycl:= 0; s1:= 100; goto rep
end;
read(in,p); eckart:= p<0 or (p=0 and eckart);
begin
array G(1:ns,1:ns),Z(1:3,1:ns);
begin
integer rk,rl; real p,q;
zone B((ns*N3+127)//128*128,1,stderror);
open(B,4,<:btrack:>,0); inrec(B,ns*N3);
k:= 0;
for i:=1 step 1 until ns do begin l:= 0;
for j:=1 step 1 until i do begin
G(i,j):= G(j,i):=
sum(B(k+m)*B(l+m)/mass((m+2)//3),m,1,N3);
l:= l+N3
end j; k:= k+N3 end i;
if eckart then begin
array J(1:3,1:3), c(1:3), dX(1:N3);
for i:=1 step 1 until N3 do dX(i):= X(i)-Xp(i);
for m:=1 step 1 until 3 do begin
k:= rk:= m mod 3 + 1; l:= rl:= k mod 3 + 1;
for j:=1 step 1 until ns do begin
p:= 0; for i:=N3-3 step -3 until 0 do
p:= p + dX(k+i)*B(rl+i) - dX(l+i)*B(rk+i);
Z(m,j):= p; rk:= rk+N3; rl:= rl+N3
end j end m;
for i:=1 step 1 until 3 do
for j:=i step 1 until 3 do
J(i,j):= -sum(mass(k+1)*Xp(3*k+j)*dX(3*k+i),k,0,N-1);
Ia:= -J(1,1); Ib:= -J(2,2); Ic:= -J(3,3);
J(1,1):= IP(1)+Ib+Ic;
J(2,2):= IP(2)+Ia+Ic;
J(3,3):= IP(3)+Ia+Ib;
syminverse(J,J,3);
for k:=1 step 1 until ns do begin
for m:=1 step 1 until 3 do
c(m):= sum(J(m,i)*Z(i,k),i,1,3);
for m:=1 step 1 until 3 do Z(m,k):= -c(m)
end k;
for m:=1 step 1 until 3 do
for k:=1 step 1 until 3 do It(m,k):= J(m,k)*IP(k);
for m:=1 step 1 until 3 do
for k:=1 step 1 until m do
my(m,k):= sum(It(m,i)*J(k,i),i,1,3);
for m:=1 step 1 until 3 do
for k:=1 step 1 until m do It(m,k):= my(m,k)*v;
write(res,nl,2,<:My-TENSOR (MHz)::>);
writemat(res,<<__-dddddd.dddd>,It,3,3);
end eckart, J, dX
else begin
write(res,nl,2,<:My-TENSOR (PAS, MHz)::>,nl,2);
for m:=1 step 1 until 3 do begin
for k:=1 step 1 until m do my(m,k):= 0;
k:= m mod 3 + 1; l:= k mod 3 + 1;
q:= 1/(It(l,l)-It(k,k)); my(m,m):= It(m,m)*q*q;
write(res,<<__-dddddd.dddd>,my(m,m)*v); q:= q+q;
for j:=1 step 1 until ns do begin
p:= 0; for i:=N3-3 step -3 until 0 do
p:= p + X(k+i)*B(l+i);
Z(m,j):= p*q; l:= l+N3
end j end m; write(res,nl,2) end;
close(B,true) end B;
write(res,nl,1,<:Z-MATRIX ( Å(el. rad.)*sqrt(1/cm*MHz) )::>);
k:= 1; l:= if 6>ns then ns else 6;
repeat:
write(res,nl,1);
for m:=1 step 1 until 3 do begin
write(res,nl,1);
for i:=k step 1 until l do
write(res,<<__-ddd.dddd>,Z(m,i)*5837.5867)
end;
k:= l+1; l:= if l+6>ns then ns else l+6;
if k<=ns then goto repeat;
write(res,nl,3,<:G-MATRIX::>);
writemat(res,<<__-d.dddddd>,G,ns,6);
if NF<>0 then begin array GF(1:NF+3,1:NF+3);
begin array Ginv(1:ns+3,1:ns+3);
for i:=1 step 1 until 3 do begin
for j:=1 step 1 until i do
Ginv(j,i):= my(i,j);
for j:=ns+3 step -1 until 4 do
Ginv(i,j):= Z(i,j-3);
end;
for i:=ns+3 step -1 until 4 do
for j:=ns+3 step -1 until i do
Ginv(i,j):= G(i-3,j-3);
syminverse(Ginv,Ginv,ns+3);
for i:=1 step 1 until 3 do begin
for j:=i step 1 until 3 do
GF(i,j):= Ginv(i,j);
for j:=1 step 1 until NF do
GF(i,3+j):= Ginv(i,CF(j))
end;
for i:=1 step 1 until NF do
for j:=i step 1 until NF do
GF(3+i,3+j):= Ginv(CF(i),CF(j));
end Ginv;
syminverse(GF,GF,3+NF);
write(res,nl,1,<:CONSTRAINED MODEL:
Free coordinates::>);
for i:=1 step 1 until NF do write(res,<: S:>,<<d>,CF(i)-3);
write(res,nl,2,<:My-TENSOR::>);
for i:=1 step 1 until 3 do
for j:=1 step 1 until i do GF(i,j):= GF(i,j)*v;
writemat(res,<<__-dddddd.dddd>,GF,3,3);
write(res,nl,1,<:Z-MATRIX ( Å(el. rad.)*sqrt(1/cm*MHz) )::>,nl,1);
for m:=1 step 1 until 3 do begin write(res,nl,1);
for j:=1 step 1 until NF do
write(res,<<__-ddd.dddd>,GF(m,j+3)*5837.5867);
end;
write(res,nl,3,<:G-MATRIX::>,nl,1);
for i:=1 step 1 until NF do begin write(res,nl,1);
for j:=1 step 1 until i do
write(res,<<__-d.dddddd>,GF(i+3,j+3))
end end end G,Z;
end It;
if p=0 then goto stop; p:= abs p;
i:= 1; write(res,<:<12>:>,nl,4,string head(increase(i)));
if eckart then write(res,nl,1,<:Eckart conditions applied.:>);
write(res,nl,3);
for p:= p-1 while p>=0 do begin
read(in,q,v); m:= t(q,1); g(q):= if m=1 then v else v*pi/180;
i:= t(q,2); j:= t(q,3); k:= t(q,4); l:= t(q,5);
write(res,nl,1,case m of (<:distance :>,<:angle :>,
<:outo :>,<:tors :>,<:sum of :>));
write(res,<<-d>,i,-j); if m=2 then write(res,<<-d>,-k);
if m=3 or m=4 then write(res,<<-d>,-k,-l);
if m<5 then write(res,<: = :>,<<-ddd.ddd00>,v)
end;
cycl:= 0; s1:= 100; goto rep
end t,g end X;
stop:
write(res,nl,5,<:<25>:>); close(res,closeres)
end
▶EOF◀