File r36/src/lie.red artifact d346cb88d8 part of check-in b5833487d7


module lie; % Header module for classification of Lie algebras.

% Author: Carsten and Franziska Schoebel.
% Copyright (c) 1993 The Leipzig University, Computer Science Dept.
% All Rights Reserved.

create!-package('(lie liendmc1 lie1234),'(contrib lie));

switch tr_lie;

load!-package 'matrix;

endmodule;


module liendmc1; % N-dimensional Lie algebras with 1-dimensional derived
                 % algebra.
% Author: Carsten Schoebel.
% e-mail: cschoeb@aix550.informatik.uni-leipzig.de .
% Copyright (c) 1993 The Leipzig University, Computer Science Dept.
% All Rights Reserved.

algebraic;
operator heisenberg,commutative,lie_algebra;

algebraic procedure liendimcom1(n);
begin
 if (not(symbolic fixp(n)) or n<2) then
 symbolic rederr "dimension out of range";
 symbolic (if gettype 'lienstrucin neq 'array then
          rederr "lienstrucin not ARRAY");
 if length lienstrucin neq {n+1,n+1,n+1} then
          symbolic rederr "dimension of lienstrucin out of range";
 matrix lientrans(n,n);
   array lie_cc(n,n,n);
 lieninstruc(n);
 lienjactest(n);if lie_jtest neq 0 then
  <<clear lie_cc,lie_jtest;symbolic rederr "not a Lie algebra">>;
 <<liendimcom(n);
 if lie_dim=0 then
       <<if symbolic !*tr_lie then
        write "The given Lie algebra is commutative";
       lientrans:=lientrans**0;lie_list:={commutative(n)}>> else
  if lie_dim=1 then <<if lie_help=0 then
                           liencentincom(n,lie_tt,lie_p,lie_q)
                     else liencentoutcom(n,lie_tt,lie_s);
     if symbolic !*tr_lie then
      lienoutform(lientrans,n,lie_help,2*lie_kk!*+1);
   if lie_help=1 then lie_list:={lie_algebra(2),commutative(n-2)} else
       lie_list:={heisenberg(2*lie_kk!*+1),commutative(n-2*lie_kk!*-1)}
            >>else
    <<clear lie_dim,lie_help,lie_p,lie_q,lie_tt,lie_s,lie_kk!*,
    lie_jtest,lie_cc;
    symbolic rederr "dimension of derived algebra out of range">>;
 clear lie_dim,lie_help,lie_p,lie_q,lie_tt,lie_s,lie_kk!*,lie_control>>;
 clear lie_jtest,lie_cc;return lie_list
end;

algebraic procedure lieninstruc(n);
begin
 for i:=1:n-1 do for j:=i+1:n do for k:=1:n do
 <<lie_cc(i,j,k):=lienstrucin(i,j,k);
 lie_cc(j,i,k):=-lienstrucin(i,j,k)>>
end;

algebraic procedure lienjactest(n);
begin
 lie_jtest:=0;
 for i:=1:n-2 do
  for j:=i+1:n-1 do
   for k:=j+1:n do
    for l:=1:n do
    if (for r:=1:n sum
           lie_cc(j,k,r)*lie_cc(i,r,l)+lie_cc(i,j,r)*lie_cc(k,r,l)+
           lie_cc(k,i,r)*lie_cc(j,r,l)) neq 0 then <<lie_jtest:=1;
                      i:=n-1;j:=n;k:=n+1;l:=n+1>>
end;

algebraic procedure liendimcom(n);
begin integer r;
      scalar he;
 lie_dim:=0;
 for i:=1:n-1 do
  for j:=i:n do
   for k:=1:n do
   if lie_cc(i,j,k) neq 0 then
    <<lie_dim:=1;lie_p:=i;lie_q:=j;r:=k;i:=n;j:=k:=n+1>>;
 if lie_dim neq 0 then
 <<for i:=1:n-1 do
    for j:=1:n do
    <<he:=lie_cc(i,j,r)/lie_cc(lie_p,lie_q,r);
      for k:=1:n do
       if lie_cc(i,j,k) neq (he*lie_cc(lie_p,lie_q,k)) then
       <<lie_dim:=2;i:=n;j:=n+1;k:=n+1>>>>;
 if lie_dim=1 then
 <<lie_help:=0;
   for i:=1:n do
    for j:=1:n do
    if (for k:=1:n sum (lie_cc(lie_p,lie_q,k)*lie_cc(k,i,j))) neq 0
     then
    <<lie_help:=1;lie_s:=i;r:=j;i:=j:=n+1>>;
   for i:=1:n do lientrans(1,i):=lie_cc(lie_p,lie_q,i);
   if lie_help=0 then
   <<lientrans(2,lie_p):=lientrans(3,lie_q):=1;lie_kk!*:=1;
     for i:=1:n do <<if
         (lie_cc(lie_p,lie_q,i) neq 0 and i neq lie_p and i neq lie_q)
          then
                   <<lie_tt:=i;i:=n+1>>>>>> else
   <<lientrans(2,lie_s):=
     lie_cc(lie_p,lie_q,r)/(for k:=1:n sum
           (lie_cc(lie_p,lie_q,k)*lie_cc(k,lie_s,r)));
     for i:=1:n do <<if (lie_cc(lie_p,lie_q,i) neq 0 and i neq lie_s)
      then
                   <<lie_tt:=i;i:=n+1>>>>>>>>>>;
end;

algebraic procedure liencentincom(n,tt,p,q);
begin integer con1,con2;
      matrix lie_lamb(n,n);
 lie_control:=0;
 con1:=con2:=0;
 for i:=4:n do
  if (i neq tt and i neq p and i neq q) then
  lientrans(i,i):=1 else
   if (tt neq 1 and p neq 1 and q neq 1 and con1 neq 1) then
   <<lientrans(i,1):=1;con1:=1>> else
    if (tt neq 2 and p neq 2 and q neq 2 and con2 neq 1) then
    <<lientrans(i,2):=1;con2:=1>> else lientrans(i,3):=1;
if n>3 then <<liennewstruc(n,2,tt);
 if n>4 then
  for i:=4 step 2 until n do if (i+1)=n then <<lienfindpair(n,i);
                 if lie_control=1 then lie_kk!*:=lie_kk!*+1>> else
       if i+1<n then <<lienfindpair(n,i);if lie_control=1 then
               <<liennewstruc(n,i,tt),lie_kk!*:=lie_kk!*+1>>else
                       i:=n+1>>>>
end;

algebraic procedure lienfindpair(n,m);
begin scalar he;
      matrix lie_a(n,n);
 lie_control:=0;
 for i:=m:n-1 do
  for j:=i+1:n do
  <<if lie_lamb(i,j) neq 0 then
   <<lie_control:=1;
     lie_a(i,m):=lie_a(m+1,j):=lie_a(j,m+1):=1;
     lie_a(m,i):=1/lie_lamb(i,j);
     for k:=1:n do
      if (k neq i and k neq j and k neq m and k neq (m+1)) then
       lie_a(k,k):=1;
     lientrans:=lie_a*lientrans;i:=n;j:=n+1>>>>;clear lie_a
end;

algebraic procedure liennewstruc(n,m,tt);
begin matrix lie_a(n,n);
 lie_a:=lie_a**0;
 for i:=m:n-1 do
  for j:=i+1:n do
  lie_lamb(i,j):=(for k:=1:n sum for l:=1:n sum
         lientrans(i,k)*lientrans(j,l)*lie_cc(k,l,tt))/lientrans(1,tt);
 for i:=m+2:n do
 <<lie_a(i,m+1):=-lie_lamb(m,i);lie_a(i,m):=lie_lamb(m+1,i)>>;
 lientrans:=lie_a*lientrans;
 for i:=m+2:n-1 do
  for j:=i+1:n do
  lie_lamb(i,j):=(for k:=1:n sum for l:=1:n sum
    lientrans(i,k)*lientrans(j,l)*lie_cc(k,l,tt))/lientrans(1,tt);
    clear lie_a
end;

algebraic procedure liencentoutcom(n,tt,s);
begin integer pp,qq;
      matrix lie_lamb(2,n),lie_a(n,n);
 for i:=3:n do
 <<lientrans(i,i):=1;lie_lamb(1,i):=(for j:=1:n sum
    lientrans(1,j)*lie_cc(j,i,tt))/lientrans(1,tt);
        lie_lamb(2,i):=lie_cc(s,i,tt)*lientrans(2,s)/lientrans(1,tt)>>;
 if (tt>2 and s>2) then
   <<lientrans(tt,tt):=lientrans(s,s):=0;
   lientrans(tt,1):=lientrans(s,2):=1;
     lie_lamb(1,tt):=(for j:=1:n sum
        lientrans(1,j)*lie_cc(j,1,tt)/lientrans(1,tt));
     lie_lamb(1,s):=(for j:=1:n sum
        lientrans(1,j)*lie_cc(j,2,tt)/lientrans(1,tt));
     lie_lamb(2,tt):=lie_cc(s,1,tt)*lientrans(2,s)/lientrans(1,tt);
     lie_lamb(2,s):=lie_cc(s,2,tt)*lientrans(2,s)/lientrans(1,tt)
   >> else if (tt>2 or s>2) then
 <<if tt>2 then <<pp:=3-s;qq:=tt>> else <<pp:=3-tt;qq:=s>>;
 lientrans(qq,qq):=0;lientrans(qq,pp):=1;
 lie_lamb(1,qq):=(for j:=1:n sum
    lientrans(1,j)*lie_cc(j,pp,tt))/lientrans(1,tt);
 lie_lamb(2,qq):=lie_cc(s,pp,tt)*lientrans(2,s)/lientrans(1,tt)>>;
 lie_a:=lie_a**0;
 for i:=3:n do
 <<lie_a(i,2):=-lie_lamb(1,i);lie_a(i,1):=lie_lamb(2,i)>>;
 lientrans:=lie_a*lientrans;clear lie_lamb,lie_a
end;

algebraic procedure lienoutform(at,n,lhelp,kk);
begin operator y;
lie_a:=at;
 if lhelp=1 then
 <<write
     "Your Lie algebra is the direct sum of the Lie algebra L(2) and";
 write "the ",n-2,"-dimensional commutative Lie algebra, where L(2) is";
 write
    "2-dimensional and there exists a basis {X(1),X(2)} in L(2) with";
 write "[X(1),X(2)]=X(1).">>else
 <<write
      "Your Lie algebra is the direct sum of the Lie algebra H(",kk,")";
  write "and the ",n-kk,"-dimensional commutative Lie algebra, where";
  write "H(",kk,") is ",kk,"-dimensional and there exists a basis";
  write "{X(1),...,X(",kk,")} in H(",kk,") with:";
  write "[X(2),X(3)]=[X(2*i),X(2*i+1)]=...=[X(",kk-1,"),X(",kk,")]=X(1)"
     >>;
  write "The transformation into this form is:";
 for i:=1:n do write "X(",i,"):=",for j:=1:n sum
      lie_a(i,j)*y(j);clear y,lie_a
end;

endmodule;


module lie1234;
% n-dimensional Lie algebras up to n=4.
% Author: Carsten and Franziska Schoebel.
% e-mail: cschoeb@aix550.informatik.uni-leipzig.de .
% Copyright (c) 1993 The Leipzig University, Computer Science Dept.
% All Rights Reserved.

algebraic;
operator liealg,comtab;

algebraic procedure lieclass(dim);
begin
 if not(dim=1 or dim=2 or dim=3 or dim=4) then
  symbolic rederr "dimension out of range";
 symbolic(if gettype 'liestrin neq 'array then
          rederr "liestrin not ARRAY");
 if length liestrin neq {dim+1,dim+1,dim+1} then
  symbolic rederr "dimension of liestrin out of range";
 if dim=1 then <<if symbolic !*tr_lie then
                 write "one-dimensional Lie algebra";
                 lie_class:={liealg(1),comtab(0)}>> else
     if dim=2 then lie2(liestrin(1,2,1),liestrin(1,2,2)) else
      if dim=3 then <<matrix lie3_ff(3,3);
                      for i:=1:3 do <<lie3_ff(1,i):=liestrin(1,2,i);
                                      lie3_ff(2,i):=liestrin(1,3,i);
                                      lie3_ff(3,i):=liestrin(2,3,i)>>;
                      lie3(lie3_ff);clear lie3_ff>> else
      <<array cc(4,4,4);
        for i:=1:4 do for j:=1:4 do for k:=1:4 do
         cc(i,j,k):=liestrin(i,j,k);
        lie4();clear cc>>;return lie_class
end;

algebraic procedure lie2(f,g);
begin
  if g=0 then
   if f=0 then liemat:=mat((1,0),(0,1))
   else liemat:=mat((0,-1/f),(f,0))
  else liemat:=mat((1/g,0),(f,g));
  if (f=0 and g=0) then <<if symbolic !*tr_lie then
   write "The given Lie algebra is commutative";
   lie_class:={liealg(2),comtab(0)}>>
  else <<if symbolic !*tr_lie then
         write "[X,Y]=Y";lie_class:={liealg(2),comtab(1)}>>
end;

algebraic procedure lie3(ff);
begin
      matrix liemat(3,3),l_f(3,3);
      array l_jj(3);
  l_f:=ff;
  for n:=1:3 do
      l_jj(n):=l_f(1,n)*(-l_f(2,1)-l_f(3,2))+
            l_f(2,n)*(l_f(1,1)-l_f(3,3))+
            l_f(3,n)*(l_f(1,2)+l_f(2,3));
  if not(l_jj(1)=0 and l_jj(2)=0 and l_jj(3)=0) then
     <<clear lie3_ff,liemat,l_f,l_jj;
       symbolic rederr "not a Lie algebra">>;
    if l_f=mat((0,0,0),(0,0,0),(0,0,0)) then
    <<if symbolic !*tr_lie then write "Your Lie algebra is commutative";
         lie_class:={liealg(3),comtab(0)};liemat:=liemat**0>> else
      if det(l_f) neq 0 then com3(ff) else
        if independ(1,2,ff)=1 then com2(ff,1,2) else
         if independ(1,3,ff)=1 then com2(ff,1,3) else
          if independ(2,3,ff)=1 then com2(ff,2,3) else
           com1(ff);
clear l_jj,l_f
end;


algebraic procedure independ(i,j,f0);
begin matrix f1(3,3);
  f1:=f0;
  if (f1(i,1)*f1(j,2)-f1(i,2)*f1(j,1)=0 and
      f1(i,2)*f1(j,3)-f1(i,3)*f1(j,2)=0 and
      f1(i,1)*f1(j,3)-f1(i,3)*f1(j,1)=0) then return 0
  else return 1
end;

algebraic procedure com1(f2);
begin
      scalar alpha,aa,bb;
      integer r,i,j,m,n,z1;
      matrix f3(3,3);
      array l_c(3,3,3);
  f3:=f2;
  for m:=3 step -1 until 1 do
   for n:=3 step -1 until 1 do
   if f3(m,n) neq 0 then i:=m;
  if i=1 then <<i:=1;j:=2>> else
   if i=2 then <<i:=1;j:=3>> else <<i:=2;j:=3>>;
  for k:=1:3 do
   <<l_c(1,2,k):=f3(1,k);l_c(2,1,k):=-f3(1,k);
     l_c(1,3,k):=f3(2,k);l_c(3,1,k):=-f3(2,k);
     l_c(2,3,k):=f3(3,k);l_c(3,2,k):=-f3(3,k)>>;
  z1:=0;
  for u:=3 step -1 until 1 do
   for v:=3 step -1 until 1 do
   if l_c(i,j,1)*l_c(v,1,u)+l_c(i,j,2)*l_c(v,2,u)+
   l_c(i,j,3)*l_c(v,3,u) neq 0
  then <<m:=u;n:=v;z1:=1>>;
  if z1=0 then
    <<a1:=mat((1,0,0),(0,1,0),(l_c(1,2,1),l_c(1,2,2),l_c(1,2,3)));
      a2:=mat((1,0,0),(0,0,1),(l_c(1,3,1),l_c(1,3,2),l_c(1,3,3)));
      a3:=mat((0,1,0),(0,0,1),(l_c(2,3,1),l_c(2,3,2),l_c(2,3,3)));
      if det(a1) neq 0 then liemat:=a1 else
       if det(a2) neq 0 then liemat:=a2 else liemat:=a3;
      if symbolic !*tr_lie then
      write "[X,Y]=Z";lie_class:={liealg(3),comtab(1)}>> else
    <<alpha:=(l_c(i,j,1)*l_c(n,1,m)+l_c(i,j,2)*l_c(n,2,m)+
              l_c(i,j,3)*l_c(n,3,m))/l_c(i,j,m);
      a1:=mat((0,0,0),(0,0,0),(l_c(i,j,1),l_c(i,j,2),l_c(i,j,3)));
      a1(1,n):=1/alpha;a1(2,1):=1;
      if det(a1) neq 0 then r:=1 else
      <<a1(2,1):=0;a1(2,2):=1;
        if det(a1) neq 0 then r:=2 else
        <<a1(2,2):=0;a1(2,3):=1;r:=3>>>>;
      aa:=l_c(n,r,m)/(alpha*l_c(i,j,m));
      bb:=(l_c(i,j,1)*l_c(r,1,m)+l_c(i,j,2)*l_c(r,2,m)+
           l_c(i,j,3)*l_c(r,3,m))/l_c(i,j,m);
      if aa=0 then liemat:=mat((1,0,0),(-bb,1,0),(0,0,1))*a1 else
        liemat:=mat((1,0,0),(bb/aa,-1/aa,1),(0,0,1))*a1;
      if symbolic !*tr_lie then
      write "[X,Z]=Z";lie_class:={liealg(3),comtab(2)}>>;
  clear a1,a2,a3,l_c,f3
end;

algebraic procedure com2(f2,m,n);
begin scalar z1,alpha,alpha1,alpha2,beta,beta1,beta2;
      matrix f3(3,3);
  f3:=f2;
  a1:=mat((f3(m,1),f3(m,2),f3(m,3)),
          (f3(n,1),f3(n,2),f3(n,3)),(0,0,0));
  a1(3,1):=1;z1:=det(a1);
  if z1 neq 0 then
   <<alpha1:=(-f3(n,3)*(f3(m,2)*f3(1,2)+f3(m,3)*f3(2,2))+
               f3(n,2)*(f3(m,2)*f3(1,3)+f3(m,3)*f3(2,3)))/z1;
     alpha2:=(-f3(n,3)*(f3(n,2)*f3(1,2)+f3(n,3)*f3(2,2))+
               f3(n,2)*(f3(n,2)*f3(1,3)+f3(n,3)*f3(2,3)))/z1;
     beta1:=(f3(m,3)*(f3(m,2)*f3(1,2)+f3(m,3)*f3(2,2))-
             f3(m,2)*(f3(m,2)*f3(1,3)+f3(m,3)*f3(2,3)))/z1;
     beta2:=(f3(m,3)*(f3(n,2)*f3(1,2)+f3(n,3)*f3(2,2))-
             f3(m,2)*(f3(n,2)*f3(1,3)+f3(n,3)*f3(2,3)))/z1>>
   else
   <<a1(3,1):=0;a1(3,2):=1;z1:=det(a1);
   if z1 neq 0 then
    <<alpha1:=(-f3(n,3)*(f3(m,1)*f3(1,1)-f3(m,3)*f3(3,1))+
                f3(n,1)*(f3(m,1)*f3(1,3)-f3(m,3)*f3(3,3)))/z1;
      alpha2:=(-f3(n,3)*(f3(n,1)*f3(1,1)-f3(n,3)*f3(3,1))+
                f3(n,1)*(f3(n,1)*f3(1,3)-f3(n,3)*f3(3,3)))/z1;
      beta1:=(f3(m,3)*(f3(m,1)*f3(1,1)-f3(m,3)*f3(3,1))-
              f3(m,1)*(f3(m,1)*f3(1,3)-f3(m,3)*f3(3,3)))/z1;
      beta2:=(f3(m,3)*(f3(n,1)*f3(1,1)-f3(n,3)*f3(3,1))-
              f3(m,1)*(f3(n,1)*f3(1,3)-f3(n,3)*f3(3,3)))/z1>>
   else
   <<a1(3,2):=0;a1(3,3):=1;z1:=det(a1);
      alpha1:=(f3(n,2)*(f3(m,1)*f3(2,1)+f3(m,2)*f3(3,1))-
               f3(n,1)*(f3(m,1)*f3(2,2)+f3(m,2)*f3(3,2)))/z1;
      alpha2:=(f3(n,2)*(f3(n,1)*f3(2,1)+f3(n,2)*f3(3,1))-
               f3(n,1)*(f3(n,1)*f3(2,2)+f3(n,2)*f3(3,2)))/z1;
      beta1:=(-f3(m,2)*(f3(m,1)*f3(2,1)+f3(m,2)*f3(3,1))+
               f3(m,1)*(f3(m,1)*f3(2,2)+f3(m,2)*f3(3,2)))/z1;
      beta2:=(-f3(m,2)*(f3(n,1)*f3(2,1)+f3(n,2)*f3(3,1))+
               f3(m,1)*(f3(n,1)*f3(2,2)+f3(n,2)*f3(3,2)))/z1>>>>;
  if (alpha2=0 and beta1=0 and alpha1=beta2) then
   <<liemat:=mat((1,0,0),(0,1,0),(0,0,1/alpha1))*a1;
     if symbolic !*tr_lie then
     write "[X,Z]=X, [Y,Z]=Y";lie_class:={liealg(3),comtab(3)}>> else
   <<if alpha2 neq 0 then
     <<alpha:=alpha1+beta2;beta:=alpha2*beta1-alpha1*beta2;
       a2:=mat((0,beta1-alpha1*beta2/alpha2,0),
               (1,-alpha1/alpha2,0),(0,0,1))>> else
      if beta1 neq 0 then
       <<alpha:=1+alpha1/beta2;beta:=-alpha1/beta2;
         a2:=mat((-alpha1*beta2/beta1,0,0),
                 (-(beta2**2)/beta1,beta2,0),(0,0,1/beta2))>> else
        <<alpha:=alpha1+beta2;beta:=-alpha1*beta2;
          a2:=mat((1,1,0),(1/alpha1,1/beta2,0),(0,0,1))>>;
     if alpha=0 then
      <<liemat:=mat((1,0,0),(0,sqrt(abs(beta)),0),
               (0,0,1/sqrt(abs(beta))))*a2*a1;
        if symbolic !*tr_lie then
        write "[X,Z]=",beta/abs(beta),"Y, [Y,Z]=X";
        if beta>0 then lie_class:={liealg(3),comtab(4)} else
                       lie_class:={liealg(3),comtab(5)}>>
                 else
      <<liemat:=mat((1,0,0),(0,-alpha,0),(0,0,-1/alpha))*a2*a1;
        if symbolic !*tr_lie then
        write "[X,Z]=-X+",beta/(alpha**2),"Y, [Y,Z]=X";
        lie_class:={liealg(3),comtab(6),beta/(alpha**2)}>>>>;
  clear a1,a2,f3
end;

algebraic procedure com3(f2);
begin matrix l_k(3,3),f3(3,3);
  f3:=f2;
  l_k(1,1):=f3(1,2)**2+2*f3(1,3)*f3(2,2)+f3(2,3)**2;
  l_k(1,2):=-f3(1,1)*f3(1,2)+f3(1,3)*f3(3,2)-
           f3(2,1)*f3(1,3)+f3(2,3)*f3(3,3);
  l_k(1,3):=-f3(1,1)*f3(2,2)-f3(1,2)*f3(3,2)-
           f3(2,1)*f3(2,3)-f3(2,2)*f3(3,3);
  l_k(2,1):=l_k(1,2);
  l_k(2,2):=f3(1,1)**2-2*f3(1,3)*f3(3,1)+f3(3,3)**2;
  l_k(2,3):=f3(1,1)*f3(2,1)+f3(1,2)*f3(3,1)-
          f3(3,1)*f3(2,3)-f3(3,2)*f3(3,3);
  l_k(3,1):=l_k(1,3);
  l_k(3,2):=l_k(2,3);
  l_k(3,3):=f3(2,1)**2+2*f3(2,2)*f3(3,1)+f3(3,2)**2;
  if not(numberp(l_k(1,1)) and
   numberp(l_k(1,1)*l_k(2,2)-l_k(1,2)*l_k(2,1)) and
         numberp(det(l_k))) then
  <<write "Is ",-l_k(1,1),">0 and ",
     l_k(1,1)*l_k(2,2)-l_k(1,2)*l_k(2,1),">0 and ",
      -det(l_k),">0 ? (y/n) and press <RETURN>";
    he:=symbolic read();
    if he=y then so3(f2) else so21(f2)>> else
  if (-l_k(1,1)>0 and l_k(1,1)*l_k(2,2)-l_k(1,2)*l_k(2,1)>0 and
      -det(l_k)>0) then so3(f2) else so21(f2);
  clear l_k,f3
end;

algebraic procedure so3(f4);
begin scalar s,tt,q,r,alpha;
      matrix f5(3,3);
  f5:=f4;
  s:=f5(2,2)/abs(f5(2,2));
  tt:=abs(f5(1,2)**2+f5(1,3)*f5(2,2));
  r:=f5(1,1)-f5(1,2)*f5(2,1)/f5(2,2);
  alpha:=tt*(-r*r-((f5(2,1)/f5(2,2))**2+f5(3,1)/f5(2,2))*tt);
  q:=1/sqrt(alpha);
  liemat(1,1):=1/(s*sqrt(tt));
  liemat(1,2):=0;
  liemat(1,3):=0;
  liemat(2,1):=q*r;
  liemat(2,2):=0;
  liemat(2,3):=-q*tt/f5(2,2);
  liemat(3,1):=-q*s*sqrt(tt)*f5(2,1)/f5(2,2);
  liemat(3,2):=-q*s*sqrt(tt);
  liemat(3,3):=q*s*sqrt(tt)*f5(1,2)/f5(2,2);
  if symbolic !*tr_lie then
  write "[X,Y]=Z, [X,Z]=-Y, [Y,Z]=X";lie_class:={liealg(3),comtab(7)};
  clear f5;
end;

algebraic procedure so21(f4);
begin scalar gam,eps,s,tt,q,r,alpha;
      matrix l_g(3,3),f5(3,3);
  f5:=f4;
  liemat:=mat((1,0,0),(0,1,0),(0,0,1));
  if f5(2,2)=0 then
   if f5(1,3) neq 0 then <<liemat:=mat((1,0,0),(0,0,1),(0,1,0));
    l_g(1,1):=f5(2,1);l_g(1,2):=f5(2,3);l_g(1,3):=f5(2,2);
    l_g(2,1):=f5(1,1);l_g(2,2):=f5(1,3);l_g(2,3):=f5(1,2);
    l_g(3,1):=-f5(3,1);l_g(3,2):=-f5(3,3);l_g(3,3):=-f5(3,2);
    f5:=l_g>> else
    if f5(3,1) neq 0 then <<liemat:=mat((0,1,0),(1,0,0),(0,0,1));
     l_g(1,1):=-f5(1,2);l_g(1,2):=-f5(1,1);l_g(1,3):=-f5(1,3);
     l_g(2,1):=f5(3,2);l_g(2,2):=f5(3,1);l_g(2,3):=f5(3,3);
     l_g(3,1):=f5(2,2);l_g(3,2):=f5(2,1);l_g(3,3):=f5(2,3);
     f5:=l_g>> else
      <<liemat:=mat((1,0,1),(1,0,0),(0,1,0));
        l_g(1,1):=-f5(2,3);l_g(1,2):=f5(2,3)-f5(2,1);l_g(1,3):=0;
        l_g(2,1):=-f5(3,3);l_g(2,2):=2*f5(1,1);
        l_g(2,3):=f5(1,2)-f5(3,2);
        l_g(3,1):=0;l_g(3,2):=f5(1,1);l_g(3,3):=f5(1,2);
        f5:=l_g>>;
  if f5(1,2)**2+f5(1,3)*f5(2,2)=0 then
   <<gam:=-f5(1,2)/f5(2,2);eps:=f5(1,1)-f5(1,2)*f5(2,1)/f5(2,2);
     if 1/4*(f5(3,2)**2+f5(3,1)*f5(2,2))-eps*f5(2,2)/2=0 then
      <<liemat:=mat((0,0,1),(0,2/eps,2*gam/eps),(1,0,0))*liemat;
        l_g(1,1):=2*gam*f5(3,2)/eps-f5(3,3);
        l_g(1,2):=-f5(3,2);l_g(1,3):=-2*f5(3,1)/eps;
        l_g(2,1):=0;l_g(2,2):=-eps*f5(2,2)/2;l_g(2,3):=-f5(2,1);
        l_g(3,1):=0;l_g(3,2):=0;l_g(3,3):=-2;f5:=l_g>> else
      <<liemat:=mat((1/2,0,1/2),(0,1/eps,gam/eps),(-1/2,0,1/2))*liemat;
        l_g(1,1):=-f5(3,1)/(2*eps);l_g(1,2):=-f5(3,2)/2;
        l_g(1,3):=f5(3,1)/(2*eps)-1;
        l_g(2,1):=f5(2,1)/2;l_g(2,2):=f5(2,2)*eps/2;
        l_g(2,3):=-f5(2,1)/2;l_g(3,1):=f5(3,1)/(2*eps)+1;
        l_g(3,2):=f5(3,2)/2;l_g(3,3):=-f5(3,1)/(2*eps);f5:=l_g>>>>;
  if not(numberp(f5(1,2)**2+f5(1,3)*f5(2,2))) then
 <<write "Is ",f5(1,2)**2+f5(1,3)*f5(2,2),
         "<0 ? (y/n) and press <RETURN>";
    he:=symbolic read();
    if he=y then
    <<s:=f5(2,2)/abs(f5(2,2));
     tt:=abs(f5(1,2)**2+f5(1,3)*f5(2,2));
     r:=f5(1,1)-f5(1,2)*f5(2,1)/f5(2,2);
     alpha:=tt*(-r*r-((f5(2,1)/f5(2,2))**2+f5(3,1)/f5(2,2))*tt);
     q:=1/sqrt(abs(alpha));
     l_g(1,1):=-q*s*sqrt(tt)*f5(2,1)/f5(2,2);
     l_g(1,2):=-q*s*sqrt(tt);
     l_g(1,3):=q*s*sqrt(tt)*f5(1,2)/f5(2,2);
     l_g(2,1):=1/(s*sqrt(tt));
     l_g(2,2):=0;
     l_g(2,3):=0;
     l_g(3,1):=q*r;
     l_g(3,2):=0;
     l_g(3,3):=-q*tt/f5(2,2);
     liemat:=l_g*liemat>> else
   <<s:=f5(2,2)/abs(f5(2,2));
     tt:=f5(1,2)**2+f5(1,3)*f5(2,2);
     r:=f5(1,1)-f5(1,2)*f5(2,1)/f5(2,2);
     alpha:=tt*(r*r-((f5(2,1)/f5(2,2))**2+f5(3,1)/f5(2,2))*tt);
     q:=1/sqrt(abs(alpha));
     if not(numberp(alpha)) then
     <<write "Is ",alpha,">0 ? (y/n) and press <RETURN>";
       he:=symbolic read();
       if he=y then
       <<l_g(1,1):=1/(s*sqrt(tt));
         l_g(1,2):=0;
         l_g(1,3):=0;
         l_g(2,1):=q*r;
         l_g(2,2):=0;
         l_g(2,3):=q*tt/f5(2,2);
         l_g(3,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
         l_g(3,2):=q*s*sqrt(tt);
         l_g(3,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
         liemat:=l_g*liemat>> else
       <<l_g(1,1):=1/(s*sqrt(tt));
         l_g(1,2):=0;
         l_g(1,3):=0;
         l_g(2,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
         l_g(2,2):=q*s*sqrt(tt);
         l_g(2,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
         l_g(3,1):=q*r;
         l_g(3,2):=0;
         l_g(3,3):=q*tt/f5(2,2);
         liemat:=l_g*liemat>>>> else
     if alpha>0 then
      <<l_g(1,1):=1/(s*sqrt(tt));
        l_g(1,2):=0;
        l_g(1,3):=0;
        l_g(2,1):=q*r;
        l_g(2,2):=0;
        l_g(2,3):=q*tt/f5(2,2);
        l_g(3,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
        l_g(3,2):=q*s*sqrt(tt);
        l_g(3,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
        liemat:=l_g*liemat>> else
      <<l_g(1,1):=1/(s*sqrt(tt));
        l_g(1,2):=0;
        l_g(1,3):=0;
        l_g(2,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
        l_g(2,2):=q*s*sqrt(tt);
        l_g(2,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
        l_g(3,1):=q*r;
        l_g(3,2):=0;
        l_g(3,3):=q*tt/f5(2,2);
        liemat:=l_g*liemat>>>>>> else
  if f5(1,2)**2+f5(1,3)*f5(2,2)<0 then
   <<s:=f5(2,2)/abs(f5(2,2));
     tt:=abs(f5(1,2)**2+f5(1,3)*f5(2,2));
     r:=f5(1,1)-f5(1,2)*f5(2,1)/f5(2,2);
     alpha:=tt*(-r*r-((f5(2,1)/f5(2,2))**2+f5(3,1)/f5(2,2))*tt);
     q:=1/sqrt(abs(alpha));
     l_g(1,1):=-q*s*sqrt(tt)*f5(2,1)/f5(2,2);
     l_g(1,2):=-q*s*sqrt(tt);
     l_g(1,3):=q*s*sqrt(tt)*f5(1,2)/f5(2,2);
     l_g(2,1):=1/(s*sqrt(tt));
     l_g(2,2):=0;
     l_g(2,3):=0;
     l_g(3,1):=q*r;
     l_g(3,2):=0;
     l_g(3,3):=-q*tt/f5(2,2);
     liemat:=l_g*liemat>> else
   <<s:=f5(2,2)/abs(f5(2,2));
     tt:=f5(1,2)**2+f5(1,3)*f5(2,2);
     r:=f5(1,1)-f5(1,2)*f5(2,1)/f5(2,2);
     alpha:=tt*(r*r-((f5(2,1)/f5(2,2))**2+f5(3,1)/f5(2,2))*tt);
     q:=1/sqrt(abs(alpha));
     if not(numberp(alpha)) then
     <<write "Is ",alpha,">0 ? (y/n) and press <RETURN>";
       he:=symbolic read();
       if he=y then
       <<l_g(1,1):=1/(s*sqrt(tt));
         l_g(1,2):=0;
         l_g(1,3):=0;
         l_g(2,1):=q*r;
         l_g(2,2):=0;
         l_g(2,3):=q*tt/f5(2,2);
         l_g(3,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
         l_g(3,2):=q*s*sqrt(tt);
         l_g(3,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
         liemat:=l_g*liemat>> else
       <<l_g(1,1):=1/(s*sqrt(tt));
         l_g(1,2):=0;
         l_g(1,3):=0;
         l_g(2,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
         l_g(2,2):=q*s*sqrt(tt);
         l_g(2,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
         l_g(3,1):=q*r;
         l_g(3,2):=0;
         l_g(3,3):=q*tt/f5(2,2);
         liemat:=l_g*liemat>>>> else
     if alpha>0 then
      <<l_g(1,1):=1/(s*sqrt(tt));
        l_g(1,2):=0;
        l_g(1,3):=0;
        l_g(2,1):=q*r;
        l_g(2,2):=0;
        l_g(2,3):=q*tt/f5(2,2);
        l_g(3,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
        l_g(3,2):=q*s*sqrt(tt);
        l_g(3,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
        liemat:=l_g*liemat>> else
      <<l_g(1,1):=1/(s*sqrt(tt));
        l_g(1,2):=0;
        l_g(1,3):=0;
        l_g(2,1):=q*s*sqrt(tt)*f5(2,1)/f5(2,2);
        l_g(2,2):=q*s*sqrt(tt);
        l_g(2,3):=-q*s*sqrt(tt)*f5(1,2)/f5(2,2);
        l_g(3,1):=q*r;
        l_g(3,2):=0;
        l_g(3,3):=q*tt/f5(2,2);
        liemat:=l_g*liemat>>>>;
  if symbolic !*tr_lie then
  write "[X,Y]=Z, [X,Z]=Y, [Y,Z]=X";lie_class:={liealg(3),comtab(8)};
  clear l_g,f5
end;

algebraic procedure lie4();
begin
     scalar lam,jac1,jac2,jac3,jac4;
     integer p1,m1,m2,m3,diml1;
     matrix l_f(6,4);
     array ordv(12);
 ordv(1):=ordv(3):=ordv(7):=1;ordv(2):=ordv(5):=ordv(9):=2;
 ordv(4):=ordv(6):=ordv(11):=3;ordv(8):=ordv(10):=ordv(12):=4;
 for i:=1:4 do
  <<l_f(1,i):=cc(1,2,i);l_f(2,i):=cc(1,3,i);l_f(3,i):=cc(2,3,i);
    l_f(4,i):=cc(1,4,i);l_f(5,i):=cc(2,4,i);l_f(6,i):=cc(3,4,i);
    cc(1,1,i):=cc(2,2,i):=cc(3,3,i):=cc(4,4,i):=0;
    cc(2,1,i):=-l_f(1,i);cc(3,1,i):=-l_f(2,i);cc(3,2,i):=-l_f(3,i);
    cc(4,1,i):=-l_f(4,i);cc(4,2,i):=-l_f(5,i);cc(4,3,i):=-l_f(6,i)>>;
 for s:=1:4 do
 <<jac1:=for r:=1:4 sum
    cc(1,2,r)*cc(r,3,s)+cc(2,3,r)*cc(r,1,s)+cc(3,1,r)*cc(r,2,s);
   jac2:=for r:=1:4 sum
    cc(1,2,r)*cc(r,4,s)+cc(2,4,r)*cc(r,1,s)+cc(4,1,r)*cc(r,2,s);
   jac3:=for r:=1:4 sum
    cc(1,3,r)*cc(r,4,s)+cc(3,4,r)*cc(r,1,s)+cc(4,1,r)*cc(r,3,s);
   jac4:=for r:=1:4 sum
    cc(2,3,r)*cc(r,4,s)+cc(3,4,r)*cc(r,2,s)+cc(4,2,r)*cc(r,3,s);
   if (jac1 neq 0 or jac2 neq 0 or jac3 neq 0 or jac4 neq 0 ) then
    s:=4>>;
 if (jac1 neq 0 or jac2 neq 0 or jac3 neq 0 or jac4 neq 0 )then
  <<clear l_f,ordv,cc;symbolic rederr "not a Lie algebra">>;
 m1:=0;
 for s:=1:6 do
  for tt:=1:4 do
   if l_f(s,tt) neq 0 then <<m1:=s;p1:=tt;s:=6;tt:=4>>;
 if m1=0 then diml1:=0 else
  if m1=6 then diml1:=1 else
  <<m2:=0;
    for s:=m1+1:6 do
     <<lam:=l_f(s,p1)/l_f(m1,p1);
       for tt:=1:4 do
       if l_f(s,tt) neq lam*l_f(m1,tt) then <<m2:=s;s:=6;tt:=4>>>>;
       if m2=0 then diml1:=1 else
     if m2=6 then diml1:=2 else
     <<m3:=0;
       for s:=m2+1:6 do
       if not(det(mat((l_f(m1,2),l_f(m1,3),l_f(m1,4)),
                      (l_f(m2,2),l_f(m2,3),l_f(m2,4)),
                      (l_f(s,2),l_f(s,3),l_f(s,4))))=0 and
              det(mat((l_f(m1,1),l_f(m1,3),l_f(m1,4)),
                      (l_f(m2,1),l_f(m2,3),l_f(m2,4)),
                      (l_f(s,1),l_f(s,3),l_f(s,4))))=0 and
              det(mat((l_f(m1,1),l_f(m1,2),l_f(m1,4)),
                      (l_f(m2,1),l_f(m2,2),l_f(m2,4)),
                      (l_f(s,1),l_f(s,2),l_f(s,4))))=0 and
              det(mat((l_f(m1,1),l_f(m1,2),l_f(m1,3)),
                      (l_f(m2,1),l_f(m2,2),l_f(m2,3)),
                      (l_f(s,1),l_f(s,2),l_f(s,3))))=0)
        then <<m3:=s;s:=6>>;
       if m3=0 then diml1:=2 else diml1:=3>>>>;
   if diml1=0 then
    <<if symbolic !*tr_lie then write "Your Lie algebra is commutative";
      lie_class:={liealg(4),comtab(0)};
      liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1))>> else
    if diml1=3 then
    com43(ordv(2*m1-1),ordv(2*m1),ordv(2*m2-1),ordv(2*m2),
            ordv(2*m3-1),ordv(2*m3)) else
      if diml1=1 then
       com41(ordv(2*m1-1),ordv(2*m1),p1) else
        com42(ordv(2*m1-1),ordv(2*m1),ordv(2*m2-1),ordv(2*m2));
 clear ordv,l_f
end;

algebraic procedure com41(i1,j1,p1);
begin scalar y1,y2,y3,beta1,beta2,beta3,beta4,beta5,beta6;
      matrix liemat(4,4);
 for i:=1:4 do liemat(1,i):=cc(i1,j1,i);
 if p1=1 then <<y1:=2;y2:=3;y3:=4>> else
  if p1=2 then <<y1:=1;y2:=3;y3:=4>> else
   if p1=3 then <<y1:=1;y2:=2;y3:=4>> else
    <<y1:=1;y2:=2;y3:=3>>;
 liemat(2,y1):=liemat(3,y2):=liemat(4,y3):=1;
 beta1:=(for l:=1:4 sum cc(i1,j1,l)*cc(l,y1,p1))/cc(i1,j1,p1);
 beta2:=(for l:=1:4 sum cc(i1,j1,l)*cc(l,y2,p1))/cc(i1,j1,p1);
 beta3:=cc(y1,y2,p1)/cc(i1,j1,p1);
 beta4:=(for l:=1:4 sum cc(i1,j1,l)*cc(l,y3,p1))/cc(i1,j1,p1);
 beta5:=cc(y1,y3,p1)/cc(i1,j1,p1);
 beta6:=cc(y2,y3,p1)/cc(i1,j1,p1);
 if (beta1=0 and beta2=0 and beta3=0 and beta4=0 and beta5=0) then
  <<liemat:=mat((1,0,0,0),(0,0,0,1),(0,0,1,0),(0,1,0,0))*liemat;
    beta3:=-beta6;beta6:=0>> else
  if (beta1=0 and beta2=0 and beta3=0) then
   <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,0,1),(0,0,1,0))*liemat;
     beta2:=beta4;beta3:=beta5;beta4:=beta5:=0;beta6:=-beta6>>;
 if (beta1=0 and beta2=0) then
  <<liemat:=mat((beta3,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
    y1:=beta4;y2:=beta5/beta3;y3:=beta6/beta3>> else
  if beta1=0 then
   <<liemat:=mat((1,0,0,0),(-beta3/beta2,1,0,0),(0,0,1/beta2,0),
             (0,0,0,1))*liemat;y1:=beta4;
     y2:=beta5-beta3*beta4/beta2;y3:=beta6/beta2>> else
    <<liemat:=mat((1,0,0,0),(beta3/beta1,-beta2/beta1,1,0),
              (0,1/beta1,0,0),(0,0,0,1))*liemat;
      y1:=beta4;y2:=(beta3*beta4-beta2*beta5)/beta1;
      y3:=beta5/beta1>>;
 if (beta1=0 and beta2=0) then
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,y3,-y2,1),(0,0,1,0))*liemat;
    if symbolic !*tr_lie then
    write "[X,Z]=W";lie_class:={liealg(4),comtab(2)}>> else
  <<if y1=0 then
    liemat:=mat((1,0,0,0),(0,1,0,0),(-y3,0,0,-1),(0,0,1,1))*liemat else
    liemat:=mat((1,0,0,0),(0,1,0,0),(-y3/y1,0,1,-1/y1),(0,0,0,1/y1))*
    liemat;
    if symbolic !*tr_lie then
    write "[W,Z]=W";lie_class:={liealg(4),comtab(1)}>>
end;


algebraic procedure com42(i1,j1,i2,j2);
begin scalar d,d1,d2,d3,d4,a1,a2,a3,a4,a5,b1,b2,b3,b4,b5;
      matrix liemat(4,4);
      array sol(1,4);
 for i:=1:4 do <<liemat(1,i):=cc(i1,j1,i);liemat(2,i):=cc(i2,j2,i)>>;
 liemat(3,1):=liemat(4,2):=1;if (d:=det(liemat)) neq 0 then
  <<d1:=1;d2:=2;d3:=3;d4:=4>> else
  <<liemat(4,2):=0;liemat(4,3):=1;if (d:=det(liemat)) neq 0 then
   <<d1:=1;d2:=3;d3:=2;d4:=4;d:=-d>> else
   <<liemat(3,1):=0;liemat(3,2):=1;if (d:=det(liemat)) neq 0 then
    <<d1:=2;d2:=3;d3:=1;d4:=4>> else
    <<liemat(3,2):=liemat(4,3):=0;liemat(3,1):=liemat(4,4):=1;
      if (d:=det(liemat)) neq 0 then
     <<d1:=1;d2:=4;d3:=2;d4:=3>> else
     <<liemat(3,1):=0;liemat(3,2):=1;if (d:=det(liemat)) neq 0 then
      <<d1:=2;d2:=4;d3:=1;d4:=3;d:=-d>> else
      <<liemat(3,2):=0;liemat(3,3):=1;d:=det(liemat);
        d1:=3;d2:=4;d3:=1;d4:=2>>
  >>>>>>>>;
 a1:=for r:=1:4 sum ( cc(i1,j1,r)*cc(r,d1,d3)*cc(i2,j2,d4)-
                      cc(i1,j1,r)*cc(r,d1,d4)*cc(i2,j2,d3))/d;
 b1:=for r:=1:4 sum (-cc(i1,j1,r)*cc(r,d1,d3)*cc(i1,j1,d4)+
                      cc(i1,j1,r)*cc(r,d1,d4)*cc(i1,j1,d3))/d;
 a2:=for r:=1:4 sum ( cc(i2,j2,r)*cc(r,d1,d3)*cc(i2,j2,d4)-
                      cc(i2,j2,r)*cc(r,d1,d4)*cc(i2,j2,d3))/d;
 b2:=for r:=1:4 sum (-cc(i2,j2,r)*cc(r,d1,d3)*cc(i1,j1,d4)+
                      cc(i2,j2,r)*cc(r,d1,d4)*cc(i1,j1,d3))/d;
 a3:=for r:=1:4 sum ( cc(i1,j1,r)*cc(r,d2,d3)*cc(i2,j2,d4)-
                      cc(i1,j1,r)*cc(r,d2,d4)*cc(i2,j2,d3))/d;
 b3:=for r:=1:4 sum (-cc(i1,j1,r)*cc(r,d2,d3)*cc(i1,j1,d4)+
                      cc(i1,j1,r)*cc(r,d2,d4)*cc(i1,j1,d3))/d;
 a4:=for r:=1:4 sum ( cc(i2,j2,r)*cc(r,d2,d3)*cc(i2,j2,d4)-
                      cc(i2,j2,r)*cc(r,d2,d4)*cc(i2,j2,d3))/d;
 b4:=for r:=1:4 sum (-cc(i2,j2,r)*cc(r,d2,d3)*cc(i1,j1,d4)+
                      cc(i2,j2,r)*cc(r,d2,d4)*cc(i1,j1,d3))/d;
 a5:=( cc(d1,d2,d3)*cc(i2,j2,d4)-cc(d1,d2,d4)*cc(i2,j2,d3))/d;
 b5:=(-cc(d1,d2,d3)*cc(i1,j1,d4)+cc(d1,d2,d4)*cc(i1,j1,d3))/d;
 findcentre(a1,a2,a3,a4,a5,b1,b2,b3,b4,b5);
   if nottriv=0 then trivcent(a1,a2,a3,a4,a5,b1,b2,b3,b4,b5)
  else
  if (sol(1,3)=0 and sol(1,4)=0) then
   if sol(1,1)=0 then
   <<liemat:=mat((0,1,0,0),(1,0,0,0),(0,0,1,0),(0,0,0,1))*liemat;
   centincom(b1,b3,b5,a1,a3,a5)>> else
   <<liemat:=mat((1,sol(1,2)/sol(1,1),0,0),(0,1,0,0),(0,0,1,0),
            (0,0,0,1))*liemat;centincom(a2,a4,a5,
     b2-sol(1,2)/sol(1,1)*a2,b4-sol(1,2)/sol(1,1)*a4,
     b5-sol(1,2)/sol(1,1)*a5)>> else
  if det(mat((1,0,0,0),(0,1,0,0),
        (sol(1,1),sol(1,2),sol(1,3),sol(1,4)),(0,0,0,1)))=0 then
  <<liemat:=mat((1,0,0,0),(0,1,0,0),
        (sol(1,1),sol(1,2),sol(1,3),sol(1,4)),(0,0,1,0))*liemat;
  centoutcom(a1,a2,b1,b2)>> else
  <<liemat:=mat((1,0,0,0),(0,1,0,0),
        (sol(1,1),sol(1,2),sol(1,3),sol(1,4)),(0,0,0,1))*liemat;
  centoutcom(a3,a4,b3,b4)>>;
 clear sol,nottriv
end;

algebraic procedure findcentre(a1,a2,a3,a4,a5,b1,b2,b3,b4,b5);
begin integer flag;
      scalar help;
 nottriv:=0;flag:=0;
 cent:=mat((a1,a2,0,-a5),(a3,a4,a5,0),(b1,b2,0,-b5),
           (b3,b4,b5,0),(0,0,a1,a3),(0,0,a2,a4),
           (0,0,b1,b3),(0,0,b2,b4));
 for i:=1:4 do
  if (cent(i,1) neq 0 and flag=0) then
  <<flag:=1;for j:=1:4 do
   <<help:=cent(1,j);cent(1,j):=cent(i,j);cent(i,j):=help>>>>;
 if flag=0 then <<nottriv:=1;sol(1,1):=1>> else
 <<for i:=2:4 do <<help:=cent(i,1)/cent(1,1);
   for j:=1:4 do cent(i,j):=cent(i,j)-help*cent(1,j)>>;
   flag:=0;
   for i:=2:4 do
    if (cent(i,2) neq 0 and flag=0) then
    <<flag:=1;for j:=2:4 do
     <<help:=cent(2,j);cent(2,j):=cent(i,j);cent(i,j):=help>>>>;
   if flag=0 then <<nottriv:=1;sol(1,1):=-cent(1,2);
                    sol(1,2):=cent(1,1)>> else
   <<for i:=3:4 do <<help:=cent(i,2)/cent(2,2);
     for j:=2:4 do cent(i,j):=cent(i,j)-help*cent(2,j)>>;
     flag:=0;
     for i:=3:8 do
      if (cent(i,3) neq 0 and flag=0) then
      <<flag:=1;for j:=3:4 do
       <<help:=cent(3,j);cent(3,j):=cent(i,j);cent(i,j):=help>>>>;
     if flag=0 then <<nottriv:=1;
      sol(1,1):=(cent(1,2)*cent(2,3)/cent(2,2)-cent(1,3))/cent(1,1);
      sol(1,2):=-cent(2,3)/cent(2,2);sol(1,3):=1>> else
     <<for i:=4:8 do <<help:=cent(i,3)/cent(3,3);
       for j:=3:4 do cent(i,j):=cent(i,j)-help*cent(3,j)>>;
       flag:=0;
       for i:=4:8 do
        if (cent(i,4) neq 0 and flag=0) then
        <<flag:=1;cent(4,4):=cent(i,4)>>;
       if flag=0 then <<nottriv:=1;
        sol(1,1):=(-(cent(2,3)*cent(3,4)/cent(3,3)-cent(2,4))*
                  cent(1,2)/cent(2,2)+cent(3,4)*cent(1,3)/
                  cent(3,3)-cent(1,4))/cent(1,1);
        sol(1,2):=(cent(2,3)*cent(3,4)/cent(3,3)-cent(2,4))/
                  cent(2,2);
        sol(1,3):=-cent(3,4)/cent(3,3);sol(1,4):=1>>
  >>>>>>;
 clear cent
end;

algebraic procedure centincom(a,c,e,b,d,f);
begin scalar v1,w1,v2,w2;
 if c=0 then if d=0 then
   <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,0,1),(0,0,1,0))*liemat;
     v1:=a;v2:=-e;w1:=b;w2:=-f>> else
     <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,-b/d),(0,0,0,1))*liemat;
       v1:=c;v2:=e;w1:=d;w2:=f>> else
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,-a/c),(0,0,0,1))*liemat;
    v1:=c;v2:=e;w1:=d;w2:=f>>;
 if w1=0 then
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,-v2/w2,v1/w2,0),(0,0,0,1/v1))*
  liemat;
    if symbolic !*tr_lie then
    write "[X,Z]=W, [Y,Z]=X";lie_class:={liealg(4),comtab(6)}>> else
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,-w2/(w1*v2-w2*v1),
             w1*w1/(w1*v2-w2*v1),0),(0,0,0,1/w1))*
        mat((1,0,0,0),(v1,w1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
    if symbolic !*tr_lie then
    write "[X,Z]=X, [Y,Z]=W";lie_class:={liealg(4),comtab(7)}>>
end;

algebraic procedure centoutcom(a,c,b,d);
begin integer flag;
      scalar alpha,beta;
 flag:=0;
 if c neq 0 then
 <<liemat:=mat((0,b-a*d/c,0,0),(1,-a/c,0,0),(0,0,1,0),(0,0,0,1))*liemat;
    alpha:=a+d;beta:=b*c-a*d>> else
  if b neq 0 then
   <<liemat:=mat((-a*d/b,0,0,0),(-d*d/b,d,0,0),(0,0,1,0),(0,0,0,1/d))*
   liemat;
     alpha:=1+a/d;beta:=-a/d>> else
   if a neq d then
    <<liemat:=mat((1,1,0,0),(1/a,1/d,0,0),(0,0,1,0),(0,0,0,1))*liemat;
      alpha:=a+d;beta:=-a*d>> else
      <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1/a))*liemat;
        flag:=1>>;
 if flag=1 then
  <<if symbolic !*tr_lie then
    write "[W,Z]=W, [X,Z]=X";lie_class:={liealg(4),comtab(10)}>> else
  if alpha=0 then
   <<liemat:=mat((1,0,0,0),(0,sqrt(abs(beta)),0,0),(0,0,1,0),
             (0,0,0,1/sqrt(abs(beta))))*liemat;
     if symbolic !*tr_lie then
     write "[W,Z]=",beta/abs(beta),"X, [X,Z]=W";
     if beta>0 then lie_class:={liealg(4),comtab(11)} else
                    lie_class:={liealg(4),comtab(8)}>> else
    <<liemat:=mat((1,0,0,0),(0,-alpha,0,0),(0,0,1,0),
              (0,0,0,-1/alpha))*liemat;
      if symbolic !*tr_lie then
      write "[W,Z]=-W+",beta/(alpha**2),"X, [X,Z]=W";
      lie_class:={liealg(4),comtab(9),beta/(alpha**2)}>>
end;

algebraic procedure trivcent(a1,a2,a3,a4,a5,b1,b2,b3,b4,b5);
begin integer flag;
      scalar he,help,alpha,beta,c1,c2,c3,c4,c5,
             d1,d2,d3,d4,d5,p,e1,e2,e3,e4,e5,e6;
 if (a1*b2-a2*b1)=0 then
  if (a3*b4-a4*b3)=0 then
   <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,1),(0,0,0,1))*liemat;
     a1:=a1+a3;b1:=b1+b3;a2:=a2+a4;b2:=b2+b4>> else
   <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,0,1),(0,0,1,0))*liemat;
     help:=a1;a1:=a3;a3:=help;help:=a2;a2:=a4;a4:=help;
     help:=b1;b1:=b3;b3:=help;help:=b2;b2:=b4;b4:=help;
     a5:=-a5;b5:=-b5>>;
 if a2 neq 0 then <<alpha:=a1+b2;beta:=a2*b1-a1*b2;
  if alpha=0 then
   <<c1:=0;c2:=b1-a1*b2/a2;c3:=sqrt(abs(beta));c4:=-c3*a1/a2;
     c5:=1/c3;d1:=a1/(a2*c2);d2:=c5;d3:=1/c2;d4:=0;d5:=c3;
     if not(numberp(beta)) then
     <<write "Is ",beta,">0 ? (y/n) and press <RETURN>";
       he:=symbolic read();
       if he=y then flag:=2 else flag:=3>> else
     if beta>0 then flag:=2 else flag:=3>> else
   <<c1:=0;c2:=b1-a1*b2/a2;c3:=-alpha;c4:=alpha*a1/a2;
     c5:=1/c3;d1:=a1/(a2*c2);d2:=c5;d3:=1/c2;d4:=0;d5:=c3;
     flag:=4;p:=beta/(alpha*alpha)>>>> else
  if b1 neq 0 then <<alpha:=1+a1/b2;beta:=-a1/b2;
   if alpha=0 then
    <<c1:=-a1*b2/b1;c2:=0;c3:=-sqrt(abs(beta))*b2/b1;c4:=-c3*b1;
      c5:=1/c4;d1:=1/c1;d2:=0;d3:=-1/(a1*b2);d4:=c5;d5:=c4;
      if not(numberp(beta)) then
     <<write "Is ",beta,">0 ? (y/n) and press <RETURN>";
       he:=symbolic read();
       if he=y then flag:=2 else flag:=3>> else
      if beta>0 then flag:=2 else flag:=3>> else
    <<c1:=-a1*b2/b1;c2:=0;c3:=alpha*b2/b1;c4:=-alpha*b2;
      c5:=1/c4;d1:=1/c1;d2:=0;d3:=-1/(a1*b2);d4:=c5;d5:=c4;
      flag:=4;p:=beta/(alpha*alpha)>>>> else
   if a1 neq b2 then <<alpha:=a1+b2;beta:=-a1*b2;
    if alpha=0 then
     <<c1:=1;c2:=1;c3:=sqrt(abs(beta))/a1;c4:=sqrt(abs(beta))/b2;
       c5:=1/sqrt(abs(beta));help:=1/b2-1/a1;d1:=1/(b2*help);
       d2:=-c5/help;d3:=-1/(a1*help);d4:=-d2;d5:=1/c5;
       if not(numberp(beta)) then
     <<write "Is ",beta,">0 ? (y/n) and press <RETURN>";
       he:=symbolic read();
       if he=y then flag:=2 else flag:=3>> else
       if beta>0 then flag:=2 else flag:=3>> else
     <<c1:=1;c2:=1;c3:=-alpha/a1;c4:=-alpha/b2;c5:=-1/alpha;
       help:=1/b2-1/a1;d1:=1/(b2*help);d2:=1/(alpha*help);
       d3:=-1/(a1*help);d4:=-d2;d5:=-alpha;
       flag:=4;p:=beta/(alpha*alpha)>>>> else
     <<c1:=1;c2:=0;c3:=0;c4:=1;c5:=1/a1;
       d1:=1;d2:=0;d3:=0;d4:=1;d5:=a1;flag:=1>>;
 liemat:=mat((c1,c2,0,0),(c3,c4,0,0),(0,0,c5,0),(0,0,0,1))*liemat;
 e1:=d1*(c1*a3+c2*a4)+d3*(c1*b3+c2*b4);
 e2:=d2*(c1*a3+c2*a4)+d4*(c1*b3+c2*b4);
 e3:=d1*(c3*a3+c4*a4)+d3*(c3*b3+c4*b4);
 e4:=d2*(c3*a3+c4*a4)+d4*(c3*b3+c4*b4);
 e5:=c5*a5*d1+c5*b5*d3;
 e6:=c5*a5*d2+c5*b5*d4;
 if flag=4 then
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,e1+e4,1),(0,0,1,0))*liemat;
    a1:=-e4;a2:=e1+e3+e4;a3:=-1;a4:=1;a5:=-e5;
    b1:=p*(e1+e4)+e2;b2:=e4;b3:=p;b4:=0;b5:=-e6>> else
  if flag=1 then
   if (e1+e4=0) then
    <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,0,1),(0,0,1,0))*liemat;
      a1:=e1;a2:=e3;a3:=1;a4:=0;a5:=-e5;
      b1:=e2;b2:=e4;b3:=0;b4:=1;b5:=-e6>> else
    <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,e1+e4,-2),(0,0,0,1))*liemat;
      a1:=e4-e1;a2:=-2*e3;a3:=e1;a4:=e3;a5:=e5*(e1+e4);
      b1:=-2*e2;b2:=e1-e4;b3:=e2;b4:=e4;b5:=e6*(e1+e4)>>;
 if (flag=1 or flag=4) then
  if a1*b2-a2*b1=0 then
   if b1=0 then
    <<liemat:=mat((a2,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
      flag:=5;e1:=a3;e2:=b3*a2;e3:=a4/a2;e4:=b4;e5:=a5/a2;
      e6:=b5>> else
    <<liemat:=mat((a1,b1,0,0),(1,0,0,0),(0,0,1,0),(0,0,0,1))*liemat;
      flag:=5;e1:=(a1*b3+b1*b4)/b1;
      e2:=a1*a3+b1*a4-a1*(a1*b3+b1*b4)/b1;e3:=b3/b1;
      e4:=a3-a1*b3/b1;e5:=b5/b1;e6:=a5-b5*a1/b1>> else
   <<if a2 neq 0 then
      <<beta:=a2*b1-a1*b2;c1:=0;c2:=b1-a1*b2/a2;
        c3:=sqrt(abs(beta));c4:=-c3*a1/a2;c5:=1/c3;
        d1:=a1/(a2*c2);d2:=c5;d3:=1/c2;d4:=0;d5:=c3>> else
       if b1 neq 0 then
        <<beta:=-a1/b2;c1:=-a1*b2/b1;c2:=0;
          c3:=-sqrt(abs(beta))*b2/b1;c4:=-c3*b1;c5:=1/c4;
          d1:=1/c1;d2:=0;d3:=-1/(a1*b2);d4:=c5;d5:=c4>> else
        <<beta:=-a1*b2;c1:=1;c2:=1;c3:=sqrt(abs(beta))/a1;
          c4:=sqrt(abs(beta))/b2;c5:=1/sqrt(abs(beta));
          help:=1/b2-1/a1;d1:=1/(b2*help);d2:=-c5/help;
          d3:=-1/(a1*help);d4:=-d2;d5:=1/c5>>;
     if not(numberp(beta)) then
     <<write "Is ",beta,">0 ? (y/n) and press <RETURN>";
       he:=symbolic read();
       if he=y then flag:=2 else flag:=3>> else
     if beta>0 then flag:=2 else flag:=3;
     liemat:=mat((c1,c2,0,0),(c3,c4,0,0),(0,0,c5,0),(0,0,0,1))*liemat;
     e1:=d1*(c1*a3+c2*a4)+d3*(c1*b3+c2*b4);
     e2:=d2*(c1*a3+c2*a4)+d4*(c1*b3+c2*b4);
     e3:=d1*(c3*a3+c4*a4)+d3*(c3*b3+c4*b4);
     e4:=d2*(c3*a3+c4*a4)+d4*(c3*b3+c4*b4);
     e5:=c5*a5*d1+c5*b5*d3;
     e6:=c5*a5*d2+c5*b5*d4>>;
 if flag=2 then
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(-e5/e1,-e6/e1,1,0),
            (0,0,-e2/e1,1/e1))*liemat;
    liemat:=mat((1/2,1/2,0,0),(1/2,-1/2,0,0),(0,0,1/2,1/2),
            (0,0,-1/2,1/2))*liemat;
    if symbolic !*tr_lie then
    write "[W,Y]=W, [X,Z]=X";lie_class:={liealg(4),comtab(3)}>> else
  if flag=3 then
   <<liemat:=mat((1,0,0,0),(0,1,0,0),(-e5/e1,-e6/e1,1,0),
             (0,0,e2/e1,1/e1))*liemat;
     if symbolic !*tr_lie then
     write "-[W,Y]=[X,Z]=X, [X,Y]=[W,Z]=W";
     lie_class:={liealg(4),comtab(4)}>> else
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(-e5/e1,-e6/e1,1,0),
            (0,0,-e3/e1,1/e1))*liemat;
    if symbolic !*tr_lie then
    write "[X,Y]=[W,Z]=W, [X,Z]=X";lie_class:={liealg(4),comtab(5)}>>;
end;

algebraic procedure com43(i1,j1,i2,j2,i3,j3);
begin integer ll;
      matrix liemat(4,4),bb(4,4),ff(3,3);
      array l_z(4,4,3);
 for i:=1:4 do
  <<cc(2,1,i):=-cc(1,2,i);cc(3,1,i):=-cc(1,3,i);
    cc(3,2,i):=-cc(2,3,i);cc(4,1,i):=-cc(1,4,i);
    cc(4,2,i):=-cc(2,4,i);cc(4,3,i):=-cc(3,4,i);
    cc(1,1,i):=cc(2,2,i):=cc(3,3,i):=cc(4,4,i):=0;
    liemat(1,i):=cc(i1,j1,i);liemat(2,i):=cc(i2,j2,i);
    liemat(3,i):=cc(i3,j3,i)>>;
 liemat(4,1):=1;if det(liemat) neq 0 then ll:=1 else
  for j:=2:4 do <<liemat(4,j-1):=0;liemat(4,j):=1;
  if det(liemat) neq 0 then <<ll:=j;j:=4>>>>;
 bb:=1/liemat;
 for i:=1:3 do
  <<l_z(1,2,i):=for r:=1:4 sum for s:=1:4 sum for tt:=1:4 sum
              liemat(1,r)*liemat(2,s)*cc(r,s,tt)*bb(tt,i);
    l_z(1,3,i):=for r:=1:4 sum for s:=1:4 sum for tt:=1:4 sum
              liemat(1,r)*liemat(3,s)*cc(r,s,tt)*bb(tt,i);
    l_z(2,3,i):=for r:=1:4 sum for s:=1:4 sum for tt:=1:4 sum
              liemat(2,r)*liemat(3,s)*cc(r,s,tt)*bb(tt,i);
    l_z(1,4,i):=for r:=1:4 sum for tt:=1:4 sum
              liemat(1,r)*cc(r,ll,tt)*bb(tt,i);
    l_z(2,4,i):=for r:=1:4 sum for tt:=1:4 sum
              liemat(2,r)*cc(r,ll,tt)*bb(tt,i);
    l_z(3,4,i):=for r:=1:4 sum for tt:=1:4 sum
              liemat(3,r)*cc(r,ll,tt)*bb(tt,i)>>;
 for i:=1:3 do
  <<ff(1,i):=l_z(1,2,i);ff(2,i):=l_z(1,3,i);ff(3,i):=l_z(2,3,i)>>;
 ll:=0;
 for i:=1:3 do for j:=1:3 do
  if ff(i,j) neq 0 then <<ll:=1;i:=3;j:=3>>;
 if ll=0 then comcom0() else
  if det(ff)=0 then comcom1() else comcom3();
 clear bb,ff,l_z
end;

algebraic procedure comcom0();
begin scalar he,a1,b1,c1,a2,b2,c2,a3,b3,c3,aa1,bb1,cc1,
             aa2,bb2,cc2,al1,be1,ga1,al2,be2,ga2,r,s,p,q;
 a1:=l_z(1,4,1);b1:=l_z(1,4,2);c1:=l_z(1,4,3);
 a2:=l_z(2,4,1);b2:=l_z(2,4,2);c2:=l_z(2,4,3);
 a3:=l_z(3,4,1);b3:=l_z(3,4,2);c3:=l_z(3,4,3);
 if (a3=0 and b3=0) then
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1/c3))*liemat;
    al1:=a1/c3;be1:=b1/c3;ga1:=c1/c3;
    al2:=a2/c3;be2:=b2/c3;ga2:=c2/c3>> else
  <<if (a3=0 and b3 neq 0) then
   <<liemat:=mat((0,b3,c3,0),(1,0,0,0),(0,0,1,0),(0,0,0,1))*liemat;
     aa1:=b2+c3;bb1:=b3*a2;cc1:=b3*c2-b2*c3;
     aa2:=b1/b3;bb2:=a1;cc2:=c1-b1*c3/b3>> else
   <<liemat:=mat((a3,b3,c3,0),(0,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
     aa1:=a1+b3*a2/a3+c3;bb1:=a3*b1-a1*b3-b3*b3*a2/a3+b3*b2;
     cc1:=a3*c1-a1*c3-b3*a2*c3/a3+b3*c2;
     aa2:=a2/a3;bb2:=b2-a2*b3/a3;cc2:=c2-a2*c3/a3>>;
  <<liemat:=mat((1,0,0,0),(0,1,-aa2,0),(0,0,1,0),(0,0,0,1))*liemat;
    cc1:=cc1+bb1*aa2;cc2:=cc2+bb2*aa2;aa2:=0>>;
  if (bb1=0 and aa1=bb2 and cc2 neq 0) then
   <<liemat:=mat((0,0,1,0),(0,1,0,0),(1,-cc1/cc2,0,0),(0,0,0,1/aa1))*
   liemat;
     al1:=0;be1:=cc1/(aa1*cc2);ga1:=1/aa1;
     al2:=cc2/aa1;be2:=1;ga2:=0>> else
    if (bb1=0 and aa1 neq bb2 and cc2 neq 0) then
     <<a1:=1/(bb2-aa1);b1:=(bb2*aa1-bb2*bb2+cc1)/(cc2*(aa1-bb2));
     liemat:=mat((1,0,0,0),(0,1,0,0),(a1,b1,1,0),(0,0,0,1/bb2))*liemat;
       al1:=(aa1-cc1*a1)/bb2;be1:=-b1*cc1/bb2;ga1:=cc1/bb2;
       al2:=-cc2*a1/bb2;be2:=1-b1*cc2/bb2;ga2:=cc2/bb2>>else
     if(bb1=0 and cc2=0) then
      <<liemat:=mat((1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1/bb2))*liemat;
        al1:=aa1/bb2;be1:=cc1/bb2;al2:=1/bb2;ga1:=be2:=ga2:=0>>
     else
      <<r:=-aa1-bb2;s:=aa1*bb2-cc1;p:=s-r*r/3;
        q:=2*r*r*r/27-s*r/3+bb2*cc1-bb1*cc2;
        c1:=(-q/2+sqrt(q*q/4+p*p*p/27))**(1/3)+
            (-q/2-sqrt(q*q/4+p*p*p/27))**(1/3)-r/3;
        a1:=(c1-bb2)/bb1;b1:=(c1-bb2)*(c1-aa1)/bb1;
      liemat:=mat((1,0,0,0),(0,0,1,0),(a1,1,b1,0),(0,0,0,1/c1))*liemat;
        al1:=(aa1-a1*bb1)/c1;be1:=(cc1-b1*bb1)/c1;
        ga1:=bb1/c1;al2:=1/c1;be2:=ga2:=0>>>>;
 if ga2 neq 0 then
 <<liemat:=mat((1,-ga1/ga2,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
   aa1:=al1-ga1*al2/ga2;bb1:=be1+al1*ga1/ga2-al2*ga1*ga1/
   (ga2*ga2)-ga1*be2/ga2;aa2:=al2;bb2:=be2+al2*ga1/ga2;cc2:=ga2>>
  else <<liemat:=mat((0,1,0,0),(1,0,0,0),(0,0,1,0),(0,0,0,1))*liemat;
         aa1:=be2;bb1:=al2;aa2:=be1;bb2:=al1;cc2:=ga1>>;
 if (aa2=0 and aa1-bb1-bb2=0 and -aa1-bb1+bb2=0 and cc2=0)
  then c0111(aa1,aa1) else
  <<if aa2=0 then
     if (aa1-bb1-bb2) neq 0 then
     <<liemat:=mat((1,0,0,0),(1,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
       aa2:=aa1-bb1-bb2;bb2:=bb1+bb2;aa1:=aa1-bb1>> else
      if (-aa1-bb1+bb2) neq 0 then
       <<liemat:=mat((1,0,0,0),(-1,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
         aa2:=-aa1-bb1+bb2;bb2:=bb2-bb1;aa1:=aa1+bb1>> else
      <<liemat:=mat((0,0,1,0),(0,1,0,0),(1,0,0,0),(0,0,0,1/aa1))*liemat;
          aa2:=cc2/aa1;bb2:=1;cc2:=0;aa1:=1/aa1>>;
    liemat:=mat((1,-aa1/aa2,aa1*cc2/aa2,0),(0,1,0,0),(0,0,1,0),
            (0,0,0,1))*liemat;
    be1:=bb1-aa1*bb2/aa2;
    al2:=aa2;be2:=aa1+bb2;ga2:=cc2-aa1*cc2;
    liemat:=mat((1,0,0,0),(-be2,be1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
    aa1:=be2; aa2:=al2*be1;cc2:=ga2*be1;
    if (cc2 neq 0 and aa2=(1-aa1)) then
     <<liemat:=mat((1,0,0,0),(1,1,0,0),(0,0,cc2,0),(0,0,0,1))*liemat;
       al1:=aa1-1;
       if al1=1 then
        <<if symbolic !*tr_lie then
          write "[W,Z]=W+X, [X,Z]=X+Y, [Y,Z]=Y";
          lie_class:={liealg(4),comtab(12)}>>
        else <<liemat:=mat((0,0,1,0),(0,1,0,0),(1,1/(al1-1),
               1/((al1-1)*(al1-1)),0),(0,0,0,1/al1))*liemat;
        liemat:=mat((0,1,0,0),(1/al1,0,0,0),(0,0,1,0),(0,0,0,1))*liemat;
        if symbolic !*tr_lie then
        write "[W,Z]=",1/al1,"W+X, [X,Z]=",1/al1,"X, [Y,Z]=Y";
        lie_class:={liealg(4),comtab(15),1/al1}>>>> else
     <<if cc2 neq 0 then
       liemat:=mat((1,0,-cc2/(1-aa2-aa1),0),(0,1,(-1+aa1)*
               cc2/(1-aa2-aa1),0),(0,0,cc2/(1-aa2-aa1),0),
               (0,0,0,1))*liemat;
       liemat:=mat((1,0,0,0),(aa1/2,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
       r:=(aa1*aa1/4+aa2);
       if r=0 then
       <<if symbolic !*tr_lie then
         write "[W,Z]=",aa1/2,"W+X, [X,Z]=",aa1/2,"X, [Y,Z]=Y";
         lie_class:={liealg(4),comtab(15),aa1/2}>> else
        <<liemat:=mat((sqrt(abs(r)),0,0,0),(0,1,0,0),(0,0,1,0),
                  (0,0,0,1))*liemat;
          if not(numberp(r)) then
          <<write "Is ",r,"<0 ? (y/n) and press <RETURN>";
            he:=symbolic read();
            if he=y then
            <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),
                     (0,0,0,sqrt(abs(1/r))))*liemat;
             s:=aa1/(2*sqrt(abs(r)));
             if symbolic !*tr_lie then
             write "[W,Z]=",s,"W+X, [X,Z]=-W+",s,"X, [Y,Z]=",
                   sqrt(abs(1/r)),"Y";
                   lie_class:={liealg(4),comtab(14),s,sqrt(abs(1/r))}>>
            else
          <<liemat:=mat((1,0,0,0),(1,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
              liemat:=mat((-2*sqrt(abs(r)),sqrt(abs(r)),0,0),
                      (0,sqrt(abs(r)),0,0),(0,0,1,0),(0,0,0,1))*liemat;
              <<c0111(aa1/2-sqrt(abs(r)),aa1/2+sqrt(abs(r)))>>>>>> else
          if r<0 then
           <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),
                     (0,0,0,sqrt(abs(1/r))))*liemat;
             s:=aa1/(2*sqrt(abs(r)));
             if symbolic !*tr_lie then
             write "[W,Z]=",s,"W+X, [X,Z]=-W+",s,"X, [Y,Z]=",
                   sqrt(abs(1/r)),"Y";
                   lie_class:={liealg(4),comtab(14),s,sqrt(abs(1/r))}>>
            else
          <<liemat:=mat((1,0,0,0),(1,1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
              liemat:=mat((-2*sqrt(abs(r)),sqrt(abs(r)),0,0),
                      (0,sqrt(abs(r)),0,0),(0,0,1,0),(0,0,0,1))*liemat;
              c0111(aa1/2-sqrt(abs(r)),aa1/2+sqrt(abs(r)))>>>>
     >>>>
 end;

algebraic procedure c0111(my,ny);
begin
 liemat:=mat((0,0,1,0),(1,0,0,0),(0,1,0,0),(0,0,0,1))*liemat;
 if symbolic !*tr_lie then
 write "[W,Z]=W, [X,Z]=",my,"X, [Y,Z]=",ny,"Y";
 lie_class:={liealg(4),comtab(13),my,ny}
end;

algebraic procedure comcom1();
begin integer ii;
      scalar he,a1,a2,a3,b2,b3,c2,c3,help;
      matrix a11(4,4),a22(4,4),a33(4,4),ccc(3,3);
 help:=0;
 for m:=1:3 do for n:=1:3 do
  if ff(m,n) neq 0 then <<ii:=m;m:=3;n:=3>>;
  a11:=mat((1,0,0,0),(0,1,0,0),(ff(ii,1),ff(ii,2),ff(ii,3),0),
           (0,0,0,1));
  a22:=mat((1,0,0,0),(0,0,1,0),(ff(ii,1),ff(ii,2),ff(ii,3),0),
           (0,0,0,1));
  a33:=mat((0,1,0,0),(0,0,1,0),(ff(ii,1),ff(ii,2),ff(ii,3),0),
           (0,0,0,1));
 if det(a11) neq 0 then liemat:=a11*liemat else
  if det(a22) neq 0 then liemat:=a22*liemat else liemat:=a33*liemat;
 liemat:=mat((0,0,1,0),(1,0,0,0),(0,1,0,0),(0,0,0,1))*liemat;
 a11:=1/liemat;
 for m:=1:3 do for n:=1:3 do
 ccc(m,n):=for i:=1:4 sum for j:=1:4 sum for k:=1:4 sum
  liemat(m,i)*liemat(4,j)*cc(i,j,k)*a11(k,n);
 a1:=ccc(1,1);a2:=ccc(2,1);a3:=ccc(3,1);b2:=ccc(2,2);
 b3:=ccc(3,2);c2:=ccc(2,3);c3:=ccc(3,3);
 if a1=0 then
  <<if c2=0 then
     if b3=0 then
      <<liemat:=mat((1,0,0,0),(0,1,1,0),(0,0,1,0),(0,0,0,1))*liemat;
        a2:=a2+a3;c2:=-2*b2>> else
      <<liemat:=mat((1,0,0,0),(0,1,b2/b3,0),(0,0,1,0),(0,0,0,1))*liemat;
        a2:=a2+a3*b2/b3;c2:=-3*b2*b2/b3;b2:=2*b2>>;
    help:=b2*b2+c2*b3;c3:=sqrt(abs(help));
    liemat:=mat((c2/c3,0,0,0),(0,1,0,0),(0,b2/c3,c2/c3,0),
            (0,a3*c3/help,-a2*c3/help,c3/help))*liemat;
    if symbolic !*tr_lie then
    write "[X,Y]=W, [X,Z]=",help/abs(help),"Y, [Y,Z]=X";
    if help>0 then lie_class:={liealg(4),comtab(19)} else
                   lie_class:={liealg(4),comtab(20)}>> else
  <<liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),
            (0,2*a3/a1,-2*a2/a1,2/a1))*liemat;
    b2:=2*b2/a1;c2:=2*c2/a1;b3:=2*b3/a1;c3:=2*c3/a1;
    if b3 neq 0 then
  <<liemat:=mat((1,0,0,0),(0,1,(1-b2)/b3,0),(0,0,1,0),(0,0,0,1))*liemat;
      c2:=c2+(1-b2)*(c3-1)/b3;b2:=c3:=1;
      if c2=0 then
       <<liemat:=mat((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))*liemat;
         c2:=b3>> else
       <<a1:=b3/abs(b3);a2:=c2/abs(c2);a3:=sqrt(abs(b3*c2));
         liemat:=mat((1,0,0,0),(0,(abs(b3/c2))**(1/4),0,0),
                 (0,0,(abs(c2/b3))**(1/4),0),(0,0,0,1))*liemat;
         if a1=a2 then
          <<if not(numberp(a1)) then
            <<write "Is ",a1,"<0 ? (y/n) and press <RETURN>";
              he:=symbolic read();
              if he=y then a3:=-a3>> else
            if a1<0 then a3:=-a3;
            liemat:=mat((1,0,0,0),(0,1,0,0),(0,1,1,0),(0,0,0,1))*liemat;
            b2:=1-a3;c2:=a3;c3:=a3+1>> else
          <<help:=1;
            if not(numberp(a1)) then
            <<write "Is ",a1,"<0 ? (y/n) and press <RETURN>";
              he:=symbolic read();
              if he=y then
              liemat:=mat((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))*
              liemat>> else
            if a1<0 then
            liemat:=mat((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))
                       *liemat;
            if symbolic !*tr_lie then
            write "[W,Z]=2W, [X,Y]=W, [X,Z]=X-",a3,"Y, ",
           "[Y,Z]=",a3,"X+Y";lie_class:={liealg(4),comtab(17),a3}>>>>>>;
    if (help neq 1) then
     if (c2=0 or b2 neq c3) then
     <<if (b2 neq c3) then
      liemat:=mat((1,0,0,0),(0,1,c2/(b2-c3),0),(0,0,1,0),(0,0,0,1))*
      liemat;
      if not(numberp(b2)) then
            <<write "Is ",b2,"<1 ? (y/n) and press <RETURN>";
              he:=symbolic read();
              if he=y then
          liemat:=mat((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))*liemat;
              help:=b2;b2:=c3;c3:=help>> else
      if b2<1 then
        <<liemat:=mat((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))*liemat;
          help:=b2;b2:=c3;c3:=help>>;
        if symbolic !*tr_lie then
        write "[W,Z]=2W, [X,Y]=W, [X,Z]=",b2,"X, [Y,Z]=",c3,"Y";
        lie_class:={liealg(4),comtab(16),b2-1}>> else
      <<liemat:=mat((1,0,0,0),(0,1/sqrt(abs(c2)),0,0),
                (0,0,sqrt(abs(c2)),0),(0,0,0,1))*liemat;
        if not(numberp(c2)) then
            <<write "Is ",c2,"<0 ? (y/n) and press <RETURN>";
              he:=symbolic read();
              if he=y then
              liemat:=mat((-1,0,0,0),(0,1,0,0),(0,0,-1,0),(0,0,0,1))*
              liemat>> else
        if c2<0 then
         liemat:=mat((-1,0,0,0),(0,1,0,0),(0,0,-1,0),(0,0,0,1))*liemat;
        if symbolic !*tr_lie then
        write "[W,Z]=2W, [X,Y]=W, [X,Z]=X+Y, [Y,Z]=Y";
        lie_class:={liealg(4),comtab(18)}>>>>;
 clear a11,a22,a33,ccc
end;

algebraic procedure comcom3();
begin integer help;
      scalar he,al,be,ga;
      matrix l_k(3,3),l_a(3,3);
 help:=0;
 l_k(1,1):=ff(1,2)**2+2*ff(1,3)*ff(2,2)+ff(2,3)**2;
 l_k(1,2):=-ff(1,1)*ff(1,2)+ff(1,3)*ff(3,2)-
          ff(2,1)*ff(1,3)+ff(2,3)*ff(3,3);
 l_k(1,3):=-ff(1,1)*ff(2,2)-ff(1,2)*ff(3,2)-
          ff(2,1)*ff(2,3)-ff(2,2)*ff(3,3);
 l_k(2,1):=l_k(1,2);
 l_k(2,2):=ff(1,1)**2-2*ff(1,3)*ff(3,1)+ff(3,3)**2;
 l_k(2,3):=ff(1,1)*ff(2,1)+ff(1,2)*ff(3,1)-
         ff(3,1)*ff(2,3)-ff(3,2)*ff(3,3);
 l_k(3,1):=l_k(1,3);l_k(3,2):=l_k(2,3);
 l_k(3,3):=ff(2,1)**2+2*ff(2,2)*ff(3,1)+ff(3,2)**2;
 if not(numberp(l_k(1,1)) and
  numberp(l_k(1,1)*l_k(2,2)-l_k(1,2)*l_k(2,1)) and
        numberp(det(l_k))) then
 <<write "Is ",-l_k(1,1),">0 and ",
      l_k(1,1)*l_k(2,2)-l_k(1,2)*l_k(2,1),">0 and ",
     -det(l_k),">0 ? (y/n) and press <RETURN>";
   he:=symbolic read();
   if he=y then <<help:=1;lie4so3()>> else lie4so21()>> else
 if (-l_k(1,1)>0 and l_k(1,1)*l_k(2,2)-l_k(1,2)*l_k(2,1)>0 and
     -det(l_k)>0) then
  <<help:=1;lie4so3()>> else lie4so21();
 liemat:=mat((l_a(1,1),l_a(1,2),l_a(1,3),0),(l_a(2,1),l_a(2,2),
          l_a(2,3),0), (l_a(3,1),l_a(3,2),l_a(3,3),0),(0,0,0,1))*liemat;
 bb:=1/liemat;
 al:=for j:=1:4 sum for k:=1:4 sum for l:=1:4 sum
         liemat(1,j)*liemat(4,k)*cc(j,k,l)*bb(l,2);
 be:=for j:=1:4 sum for k:=1:4 sum for l:=1:4 sum
         liemat(1,j)*liemat(4,k)*cc(j,k,l)*bb(l,3);
 ga:=for j:=1:4 sum for k:=1:4 sum for l:=1:4 sum
         liemat(2,j)*liemat(4,k)*cc(j,k,l)*bb(l,3);
 if help=1 then
  liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),(ga,-be,al,1))*liemat else
  liemat:=mat((1,0,0,0),(0,1,0,0),(0,0,1,0),(ga,-be,-al,1))*liemat;
 if help=1 then
  <<if symbolic !*tr_lie then
    write "[W,X]=Y, [W,Y]=-X, [X,Y]=W";
    lie_class:={liealg(4),comtab(21)}>> else
  <<if symbolic !*tr_lie then
    write "[W,X]=Y, [W,Y]=X, [X,Y]=W";
    lie_class:={liealg(4),comtab(22)}>>;
 clear l_k,l_a
end;

algebraic procedure lie4so3();
begin scalar s,tt,q,r,alpha;
 s:=ff(2,2)/abs(ff(2,2));
 tt:=abs(ff(1,2)**2+ff(1,3)*ff(2,2));
 r:=ff(1,1)-ff(1,2)*ff(2,1)/ff(2,2);
 alpha:=tt*(-r*r-((ff(2,1)/ff(2,2))**2+ff(3,1)/ff(2,2))*tt);
 q:=1/sqrt(alpha);
 l_a(1,1):=1/(s*sqrt(tt));l_a(1,2):=l_a(1,3):=l_a(2,2):=0;l_a(2,1):=q*r;
 l_a(2,3):=-q*tt/ff(2,2);l_a(3,1):=-q*s*sqrt(tt)*ff(2,1)/ff(2,2);
 l_a(3,2):=-q*s*sqrt(tt);l_a(3,3):=q*s*sqrt(tt)*ff(1,2)/ff(2,2)
end;

algebraic procedure lie4so21();
begin scalar gam,eps,s,tt,q,r,alpha;
      matrix l_g(3,3);
 l_a:=mat((1,0,0),(0,1,0),(0,0,1));
 if ff(2,2)=0 then
  if ff(1,3) neq 0 then <<l_a:=mat((1,0,0),(0,0,1),(0,1,0));
   l_g(1,1):=ff(2,1);l_g(1,2):=ff(2,3);l_g(1,3):=ff(2,2);
   l_g(2,1):=ff(1,1);l_g(2,2):=ff(1,3);l_g(2,3):=ff(1,2);
   l_g(3,1):=-ff(3,1);l_g(3,2):=-ff(3,3);l_g(3,3):=-ff(3,2);ff:=l_g>>
    else
   if ff(3,1) neq 0 then <<l_a:=mat((0,1,0),(1,0,0),(0,0,1));
    l_g(1,1):=-ff(1,2);l_g(1,2):=-ff(1,1);l_g(1,3):=-ff(1,3);
    l_g(2,1):=ff(3,2);l_g(2,2):=ff(3,1);l_g(2,3):=ff(3,3);
    l_g(3,1):=ff(2,2);l_g(3,2):=ff(2,1);l_g(3,3):=ff(2,3);ff:=l_g>> else
                         <<l_a:=mat((1,0,1),(1,0,0),(0,1,0));
    l_g(1,1):=-ff(2,3);l_g(1,2):=ff(2,3)-ff(2,1);l_g(1,3):=0;
    l_g(2,1):=-ff(3,3);l_g(2,2):=2*ff(1,1);l_g(2,3):=ff(1,2)-ff(3,2);
    l_g(3,1):=0;l_g(3,2):=ff(1,1);l_g(3,3):=ff(1,2);ff:=l_g>>;
 if ff(1,2)**2+ff(1,3)*ff(2,2)=0 then
  <<gam:=-ff(1,2)/ff(2,2);eps:=ff(1,1)-ff(1,2)*ff(2,1)/ff(2,2);
  if 1/4*(ff(3,2)**2+ff(3,1)*ff(2,2))-eps*ff(2,2)/2=0 then
   <<l_a:=mat((0,0,1),(0,2/eps,2*gam/eps),(1,0,0))*l_a;
   l_g(1,1):=2*gam*ff(3,2)/eps-ff(3,3);
   l_g(1,2):=-ff(3,2);l_g(1,3):=-2*ff(3,1)/eps;
   l_g(2,1):=0;l_g(2,2):=-eps*ff(2,2)/2;l_g(2,3):=-ff(2,1);
   l_g(3,1):=l_g(3,2):=0;l_g(3,3):=-2;ff:=l_g>> else
   <<l_a:=mat((1/2,0,1/2),(0,1/eps,gam/eps),(-1/2,0,1/2))*l_a;
   l_g(1,1):=-ff(3,1)/(2*eps);l_g(1,2):=-ff(3,2)/2;
   l_g(1,3):=ff(3,1)/(2*eps)-1;
   l_g(2,1):=ff(2,1)/2;l_g(2,2):=ff(2,2)*eps/2;
   l_g(2,3):=-ff(2,1)/2;l_g(3,1):=ff(3,1)/(2*eps)+1;
   l_g(3,2):=ff(3,2)/2;l_g(3,3):=-ff(3,1)/(2*eps);ff:=l_g>>>>;
 if not(numberp(ff(1,2)**2+ff(1,3)*ff(2,2))) then
 <<write "Is ",ff(1,2)**2+ff(1,3)*ff(2,2),
         "<0 ? (y/n) and press <RETURN>";
   he:=symbolic read();
   if he=y then
   <<s:=ff(2,2)/abs(ff(2,2));
  tt:=abs(ff(1,2)**2+ff(1,3)*ff(2,2));
  r:=ff(1,1)-ff(1,2)*ff(2,1)/ff(2,2);
  alpha:=tt*(-r*r-((ff(2,1)/ff(2,2))**2+ff(3,1)/ff(2,2))*tt);
  q:=1/sqrt(abs(alpha));
  l_g(1,1):=-q*s*sqrt(tt)*ff(2,1)/ff(2,2);
  l_g(1,2):=-q*s*sqrt(tt);l_g(1,3):=q*s*sqrt(tt)*ff(1,2)/ff(2,2);
  l_g(2,1):=1/(s*sqrt(tt));l_g(2,2):=l_g(2,3):=0;
  l_g(3,1):=q*r;l_g(3,2):=0;l_g(3,3):=-q*tt/ff(2,2);l_a:=l_g*l_a>> else
  <<s:=ff(2,2)/abs(ff(2,2));
  tt:=ff(1,2)**2+ff(1,3)*ff(2,2);
  r:=ff(1,1)-ff(1,2)*ff(2,1)/ff(2,2);
  alpha:=tt*(r*r-((ff(2,1)/ff(2,2))**2+ff(3,1)/ff(2,2))*tt);
  q:=1/sqrt(abs(alpha));
  if not(numberp(alpha)) then
  <<write "Is ",alpha,">0 ? (y/n) and press <RETURN>";
    he:=symbolic read();
    if he =y then
    <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*r;l_g(2,2):=0;l_g(2,3):=q*tt/ff(2,2);
   l_g(3,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(3,2):=q*s*sqrt(tt);
   l_g(3,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);l_a:=l_g*l_a>> else
   <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(2,2):=q*s*sqrt(tt);
   l_g(2,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);
   l_g(3,1):=q*r;l_g(3,2):=0;l_g(3,3):=q*tt/ff(2,2);
   l_a:=l_g*l_a>>>> else
  if alpha>0 then
   <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*r;l_g(2,2):=0;l_g(2,3):=q*tt/ff(2,2);
   l_g(3,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(3,2):=q*s*sqrt(tt);
   l_g(3,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);l_a:=l_g*l_a>> else
   <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(2,2):=q*s*sqrt(tt);
   l_g(2,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);
   l_g(3,1):=q*r;l_g(3,2):=0;l_g(3,3):=q*tt/ff(2,2);l_a:=l_g*l_a>>
>>>> else
 if ff(1,2)**2+ff(1,3)*ff(2,2)<0 then
  <<s:=ff(2,2)/abs(ff(2,2));
  tt:=abs(ff(1,2)**2+ff(1,3)*ff(2,2));
  r:=ff(1,1)-ff(1,2)*ff(2,1)/ff(2,2);
  alpha:=tt*(-r*r-((ff(2,1)/ff(2,2))**2+ff(3,1)/ff(2,2))*tt);
  q:=1/sqrt(abs(alpha));
  l_g(1,1):=-q*s*sqrt(tt)*ff(2,1)/ff(2,2);
  l_g(1,2):=-q*s*sqrt(tt);l_g(1,3):=q*s*sqrt(tt)*ff(1,2)/ff(2,2);
  l_g(2,1):=1/(s*sqrt(tt));l_g(2,2):=l_g(2,3):=0;
  l_g(3,1):=q*r;l_g(3,2):=0;l_g(3,3):=-q*tt/ff(2,2);
  l_a:=l_g*l_a>> else
  <<s:=ff(2,2)/abs(ff(2,2));
  tt:=ff(1,2)**2+ff(1,3)*ff(2,2);
  r:=ff(1,1)-ff(1,2)*ff(2,1)/ff(2,2);
  alpha:=tt*(r*r-((ff(2,1)/ff(2,2))**2+ff(3,1)/ff(2,2))*tt);
  q:=1/sqrt(abs(alpha));
  if not(numberp(alpha)) then
  <<write "Is ",alpha,">0 ? (y/n) and press <RETURN>";
    he:=symbolic read();
    if he =y then
    <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*r;l_g(2,2):=0;l_g(2,3):=q*tt/ff(2,2);
   l_g(3,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(3,2):=q*s*sqrt(tt);
   l_g(3,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);l_a:=l_g*l_a>> else
   <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(2,2):=q*s*sqrt(tt);
   l_g(2,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);
   l_g(3,1):=q*r;l_g(3,2):=0;l_g(3,3):=q*tt/ff(2,2);
   l_a:=l_g*l_a>>>> else
  if alpha>0 then
   <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*r;l_g(2,2):=0;l_g(2,3):=q*tt/ff(2,2);
   l_g(3,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(3,2):=q*s*sqrt(tt);
   l_g(3,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);l_a:=l_g*l_a>> else
   <<l_g(1,1):=1/(s*sqrt(tt));l_g(1,2):=l_g(1,3):=0;
   l_g(2,1):=q*s*sqrt(tt)*ff(2,1)/ff(2,2);l_g(2,2):=q*s*sqrt(tt);
   l_g(2,3):=-q*s*sqrt(tt)*ff(1,2)/ff(2,2);
   l_g(3,1):=q*r;l_g(3,2):=0;l_g(3,3):=q*tt/ff(2,2);l_a:=l_g*l_a>>>>;
 clear l_g
end;

endmodule;


end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]