reduce-historical/r38/packages/crack/applysym.red

%********************************************************************
%                                                                   *
%  The program APPLYSYM for applying point-symmetries which are,    *
%  for example computed by the program LIEPDE. It also can be used  *
%  for solving quasilinear first order PDEs using QUASILINPDE.      *
%                                                                   *
%  Author: Thomas Wolf                                              *
%  Date:   summer 1995                                              *
%                                                                   *
%********************************************************************

symbolic fluid '(print_ logoprint_ nfct_ fname_ time_ facint_
                 adjust_fnc safeint_ freeint_ odesolve_)$
lisp flag('(yesp),'boolean)$
lisp(logoprint_:=t)$
symbolic operator freeoflist$
symbolic operator termxread$

%----------------------------

symbolic fluid '(tr_as)$
lisp(tr_as:=t)$

algebraic procedure ApplySym(problem,Symtry);
%  problem ... {{equations},{functions},{variables}}
%  Symtry  ... {{xi_..=..,..,eta_..=..,..},{constants in first list}}
begin
  scalar genlist,con,e1,e2,h1,h2,h3,h4,h5,h6,h7,modus,u,v,xlist,ylist,n,
	 cop1,cop2,symanz,oldsol,oldmodus,trafoprob,altlogo$
  backup_reduce_flags()$
  clear sy_,sym_;
  array sym_(length(second Symtry));
  symbolic put('sy_,'simpfn,'simpiden)$
  symbolic put('ff,'simpfn,'simpiden)$
  symbolic put('ffi,'simpfn,'simpiden)$

  ylist := maklist second problem;
  xlist := maklist  third problem;

  con:=second Symtry;
  symanz:=0;
  for each e1 in con do       % i.e. for all symmetries do:
  if freeoflist(e1,xlist) and
     freeoflist(e1,ylist) then        %------ no pseudo-Lie-symm.
  <<genlist:=sub(e1=1,first Symtry);  %------ calculate symmetry
    for each el2 in con do
    if el1 neq el2 then genlist:=sub(el2=0,genlist);
    symanz:=symanz+1;
    sym_(symanz):=genlist
  >>;

  repeat <<

    % Application
    oldmodus:=modus;
    repeat <<
      lisp <<terpri()$
	write"Do you want to find similarity and symmetry variables ",
             "(enter `1;')";terpri()$
	write"or generalize a special solution with new parameters  ",
             "(enter `2;')";terpri()$
	write"or exit the program                                   ",
	     "(enter  `;')";terpri()
      >>;
      modus:=termxread()

    >> until (modus=1) or (modus=2) or (modus=nil);

    if modus neq nil then <<
      % Preparing a combination of symmetries
      if symanz=1 then genlist:=sym_(1)
		  else <<
        for n:=1:symanz do <<
	  write"----------------------   The ",n,".  symmetry is:"$
	  for each e2 in sym_(n) do
	  if rhs e2 neq 0 then write e2
        >>;
        write"----------------------"$
	repeat
        <<lisp
          <<terpri()$
            write"Which single symmetry or linear combination of symmetries"$
            terpri()$write"do you want to apply? "$
            terpri()$write"Enter an expression with `sy_(i)' for the i'th ",
                          "symmetry. Terminate input with `$' or `;'."$
	    terpri()
          >>$

	  h1:=lisp(reval termxread());
          if h1 then <<
            for each h2 in xlist do if h1 then if df(h1,h2) neq 0 then h1:=nil;
            for each h2 in ylist do if h1 then if df(h1,h2) neq 0 then h1:=nil;
            if h1=nil then lisp <<
              terpri();write"The coefficients of the sy_(i) must be constant, ",
                            "i.e. numbers or constants";terpri()
            >>
          >>
	>> until h1;
        genlist:={};
        cop1:=sym_(1);
        while cop1 neq {} do <<
          h6:=lhs first cop1;cop1:=rest cop1;
          genlist:=cons(h6 = 0, genlist)
        >>;
        genlist:=reverse genlist;

        for h2:=1:symanz do <<
          h3:=coeffn(h1,sy_(h2),1);
          if h3 neq 0 then <<
	    cop1:=genlist;cop2:=sym_(h2);
	    genlist:={};
	    while cop1 neq {} do <<
	      h4:=first cop1; cop1:=rest cop1$
	      h5:=first cop2; cop2:=rest cop2$
	      h6:=lhs h4;
	      genlist:=cons(h6 = rhs h4 + h3*(rhs h5),genlist)
	    >>;
	    genlist:=reverse genlist
          >>
        >>
      >>;

      write"The symmetry to be applied in the following is ";
      write genlist;

      write"Terminate the following input with `$' or `;'."$
      if modus=1 then <<
	write"Enter the name of the new dependent variable(s):";
	u:=termxread();
	write"Enter the name of the new independent variable(s):";
	v:=termxread();
	altlogo:=logoprint_;
	logoprint_:=nil;
	trafoprob:=similarity(problem,genlist,{},u,v);
	logoprint_:=altlogo
      >>         else <<
	if length h1 < 2 then <<
	  lisp <<terpri()$
	    write"What shall the name of the new constant parameter",
		 " be? ";terpri()>>$
	  h2:=termxread()
	>>;
	repeat <<
	  lisp <<terpri()$
	    write"Enter the solution to be generalized in form of an ",
		 "expression, which vanishes";terpri()$
	    write"or in form of an equation `... = ...' ";
	    if oldsol=nil then write":" else <<
	      terpri()$
	      write"or enter semicolon `;' to work on the solution ",
		   "specified before:"
	    >>;terpri()
	  >>;
	  h3:=termxread();
	  if h3 neq nil then oldsol:=h3
	>> until oldsol neq nil;
	h3:=NewParam(oldsol,genlist,h2);
	if h3 neq nil then oldsol:=h3
      >>
    >>
  >> until modus=nil;
  clear sym_;
  recover_reduce_flags()$
  return if oldmodus=1 then trafoprob else
	 if oldmodus=2 then oldsol    else nil
end$ % of ApplySym

%----------------------------

algebraic procedure NewParam(oldsol,genlist,u_)$
% u_ is the name of the new parameter
begin
  scalar h1,h2,h20,h3,h30,h4,vari,pde,e1,printold,clist,newsol,
	 oldsol_ex,prev_depend;
  vari:=makepde(genlist,u_)$
  pde:=first vari;
  vari:=rest vari;

  % is oldsol an invariant?
  oldsol_ex:=equ_to_expr(oldsol)$      % oldsol as vanishing expression
  prev_depend:=storedepend(vari)$  
  h2:=sub(u_=oldsol_ex,pde);
  if h2 neq 0 then <<
    h1:=solve(oldsol_ex,vari);
    if h1 neq {} then <<
      h1=first h1;
      for each h3 in h1 do
      if freeof(h3,arbcomplex) then h2:=sub(h3,h2)
    >>
  >>;
  restoredepend(prev_depend)$  
  if 0=h2 then return lisp
  <<write"The special solution to be generalized is an invariant ",
	 "with respect to";terpri()$
    write"this symmetry, therefore no generalization is possible.";
    terpri()$
    for each h1 in fargs u_ do nodepend u_,h1;
    algebraic oldsol
  >>;

  pde:=pde-1;
  h1:= quasilinpde1(pde,u_,vari)$
  if h1 neq {} then <<
    h1:=first h1;
    % h2 is expressing the constants in terms of u_ and the xlist,ylist
    clist:={};
    h2:= for each e1 in h1 collect
    <<h3:=lisp(newfct(fname_,nil,nfct_))$
      lisp(nfct_:=add1 nfct_)$
      clist:=cons(h3,clist);
      h3 = e1>>;
    h20:=sub(u_=0,h2);
    h3:=solve(h2,vari);
    if h3 neq {} then <<
      h3:=first h3;
      h30:=sub(h20,h3);
      write"The substitutions to generalize the solution are: "$
      for each h4 in h30 do write h4$
      newsol:=sub(h30,oldsol_ex);
%      newsol:=second dropredundant(newsol,
%                                   alle Konstanten und
%                                   Funktionen die nicht in vari sind,
%                                   vari)$
      lisp <<write"The new solution";
%       if length algebraic h >2 then write"s are:" else write" is:";
%       terpri()$
      >>;
      write"0 = ",newsol
    >>
  >>;
  for each h1 in fargs u_ do nodepend u_,h1;
  return newsol
end$ % of NewParam

%----------------------------

symbolic operator  einfachst$
symbolic procedure einfachst(a,x)$
% a is an algebraic list and the element where x appears, but
% appears simplest, is found
begin
 scalar el1,el2,hp;
 hp:=10000;
 a:=cdr a;
 while a do <<
  el2:=car a;a:=cdr a;
  if not freeof(el2,x)                                  and
     ((not el1                                   ) or
      (el2 = x                                   ) or
      <<if not polyp(el2,cons(x,nil)) then nil
				      else
       <<coeff1(el2,x,nil)$ 
	 if hipow!*<hp then <<hp:=hipow!*; t>>
		       else nil               >> >>    ) then el1:=el2
 >>;
 return el1
end$

%----------------------------

algebraic procedure TransDf(y,yslist,vlist,indxlist)$
begin
 scalar m,n,e1,dfy;
 return
 if indxlist={} then sub(yslist,y)
		else <<
  m:=first indxlist;
  n:=0;
  dfy:=TransDf(y,yslist,vlist,rest indxlist);
  for each e1 in vlist sum <<
   n:=n+1;
   df(dfy,e1)*Dv!/Dx(n,m)   
  >>
 >>
end$ % of TransDf

%----------------------------

algebraic procedure TransDeriv(yik,yslist,vlist)$
begin
 scalar indxlist,y,l1,l2;
 indxlist:=lisp cons('LIST,combidif(yik))$
 return TransDf(first indxlist,yslist,vlist,rest indxlist)
end$ % of TransDeriv

%----------------------------

algebraic procedure DeTrafo(eqlist,yslist,xslist,ulist,vlist)$
% Transformations of all orders are performed (point-, contact-,...)
% but only x-derivatives of y's are transformed. To transform other
% any other derivatives, subdiff1 must be extended to include all other
% occuring x-derivatives.
begin
 scalar avar,nvar,detpd,n,m,ordr,e1,e2,e3,sb;
 m:=length(xslist); n:=length(yslist)+m;
 clear dyx!/duv,Dv!/Dx;
 matrix dyx!/duv(n,n);
 matrix Dv!/Dx(m,m);
 avar:=append(yslist,xslist);
 nvar:=append(ulist,vlist);
 n:=0;
 for each e1 in avar do <<
  n:=n+1;m:=0;
  for each e2 in nvar do <<
   m:=m+1;
   dyx!/duv(m,n):=df(rhs e1,e2)
  >>
 >>;
 detpd:=det(dyx!/duv);
%write"detpd=",detpd; 
 if detpd=0 then return
 <<write"The proposed transformation is not regular!";{}>>;
 clear dyx!/duv;

 ordr:=0;
 for each e1 in eqlist do
 for each e2 in yslist do
 <<n:=totdeg(e1,lhs e2);
  if n>ordr then ordr:=n>>;
 
 sb:=subdif1(for each e1 in xslist collect lhs e1,
	     for each e1 in yslist collect lhs e1,ordr);

 % computation of Dv/Dx:=(Dx/Dv)^(-1)
 n:=0;
 for each e1 in xslist do <<
  n:=n+1;m:=0;
  for each e2 in vlist do <<
   m:=m+1;
   Dv!/Dx(n,m):=total_alg_mode_deriv(rhs e1,e2) 
             % it is assumed ulist does depend on vlist
  >>
 >>;
 Dv!/Dx:=Dv!/Dx**(-1);

 % Substitution of all derivatives
 for each e1 in sb do
 for each e2 in e1 do <<
  if not freeof(eqlist,lhs e2) then <<
   % which function is to be differentiated wrt. which variable
   eqlist:=sub(lhs e2=TransDeriv(rhs e2,yslist,vlist),eqlist)
  >>
 >>;
 clear  Dv!/Dx;
 return sub(xslist,sub(yslist,eqlist))$
end$ % of DeTrafo

%----------------------------

algebraic procedure grouping(el1,el2,xlist,ylist,nx,ny)$
begin scalar h,el3,xslist,yslist$
  %------- Grouping the new variables to ulist and vlist
  h:={};
  xslist:={};   % list of expressions to calculate new indep. var.
  yslist:={};   % list of expressions to calculate new   dep. var.
  %---- at first the obvious allocations
  for each el3 in el1 do %-- all similarity variables
  if freeoflist(el3,ylist) then xslist:=cons(el3,xslist) else
  if freeoflist(el3,xlist) then yslist:=cons(el3,yslist) else
  h:=cons(el3,h);
  %---- now the symmetry variable
  if freeoflist(el2,ylist) or (length(yslist) = ny) then
  xslist:=cons(el2,xslist)                          else
  if freeoflist(el2,xlist) or (length(xslist) = nx) then
  yslist:=cons(el2,yslist)                          else
  xslist:=cons(el2,xslist);
  %---- now the remaining cases
  for each el3 in h do
  if length(yslist) < ny then yslist:=cons(el3,yslist)
			 else xslist:=cons(el3,xslist);
  return {xslist,yslist}
end$ % of grouping

%----------------------------

algebraic procedure rename_u_(xslist,yslist,el2,u_,u,v)$
begin scalar i,vlist,ulist,el3,h,smv$
  %---- Renaming the u_ to ui in yslist and to vi in xslist
  i:=0;
  vlist:={};
  xslist:=for each el3 in xslist collect
  <<i:=i+1;
    if length xslist>1 then h:=mkid(v,i)
		       else h:=v;
    vlist:=cons(h,vlist);
    if el3=el2 then smv:=h;
    sub(u_=h,el3)
  >>;
  i:=0;
  ulist:={};
  yslist:=for each el3 in yslist collect
  <<i:=i+1;
    if length yslist>1 then h:=mkid(u,i)
		       else h:=u;
    ulist:=cons(h,ulist);
    if el3=el2 then smv:=h;
    sub(u_=h,el3)
  >>;
  return {xslist,yslist,reverse vlist,reverse ulist,smv}
end$ % of rename_u_

%----------------------------

algebraic procedure solve_for_old_var(xslist,yslist,xlist,ylist,nx,ny)$
begin scalar h1,h2$
  %---- Solve for old variables
  h1:=nil;
  h2:=solve(append(yslist,xslist),append(xlist,ylist));

  if h2={} then h1:=t
	   else h2:=first h2; %--- possibly other solutions
  if LIST neq lisp(car algebraic h2) then h1:=t else
  if length(h2)<(nx+ny) then el2:=t;
  if h1 then repeat lisp
  <<write"The algebraic system ",append(xslist,yslist),
	 " could not be solved for ",append(xlist,ylist),".";
    write"Please enter the solution in form of a list {",
	 reval algebraic first xlist,"=...,...",
	 reval algebraic first ylist,"=...,...} or enter a ",
	 "semicolon ; to end this investigation:";
    algebraic(h2:=termxread())
  >> until h2=nil or ( lisp(pairp algebraic h2)    and
		     (LIST=lisp(car algebraic h2)) and
		     (length(h2)=(nx+ny))              )
	else
  <<lisp<<terpri()$
      write"The suggested solution of the algebraic system which will";
      terpri()$   
      write"do the transformation is: ";
      terpri()
    >>;
    write h2;
    if yesp "Is the solution ok?" then else lisp <<
      write"Please enter the solution in form of a list {",
	   reval algebraic first xlist,"=...,...",
	   reval algebraic first ylist,"=...,...} or enter a ",
	   "semicolon ; to end this investigation:";
      algebraic(h2:=termxread())
    >>
  >>;
  return h2
end$ % of solve_for_old_var$

%----------------------------

algebraic procedure switch_r_s(h2,smv,ylist,u,v)$
begin scalar xslist,yslist,el3,h$
  %---- Exchange of dependent and independent variables
  xslist:={};
  yslist:={};
  for each el3 in h2 do if freeof(ylist,lhs el3) then
  xslist:=cons(el3,xslist)                       else
  yslist:=cons(el3,yslist);
  lisp <<terpri()$
         write"In the intended transformation shown above",
	      " the dependent ";terpri()$
	 if length yslist>2 then
	 write"variables are the ",reval algebraic u,"i and " else
	 write"variable is ",reval algebraic u," and "; 
	 
	 if length xslist>2 then
	 write"the independent variables are the ",
	      reval algebraic v,"i." else
	 write"the independent variable is ",reval algebraic v,".";
         terpri()$
         write"The symmetry variable is ",reval algebraic smv,", i.e. the ",
              "transformed expression";terpri();
         write"will be free of ",reval algebraic smv,".";
  >>; 
  h:=if yesp "Is this selection of dependent and independent variables ok?"
    then nil else <<
    lisp <<write"Please enter a list of substitutions. For example, to";
	   terpri()$
           write"make the variable, which is so far call u1, to an";
           terpri()$
           write"independent variable v2 and the variable, which is ";
           terpri()$
           write"so far called v2, to an dependent variable u1, ";
           terpri()$
           write"enter: `{u1=v2, v2=u1};'">>;
    termxread()
  >>;
  if h and (h neq {}) then <<xslist:=sub(h,xslist);
			     yslist:=sub(h,yslist);
			     smv   :=sub(h,smv)>>;
  return {xslist,yslist,smv}
end$ % of switch_r_s

%----------------------------

algebraic procedure makepde(genlist,u_)$
begin scalar h,el2,el3,vari,bv;
  vari:={};
  return
  cons(
  num for each el2 in genlist sum
  <<h:=lhs el2;
    h:=lisp <<
      el3:=explode reval algebraic h;
      bv:=t;
      while bv do <<
	if car el3 ='!_ then bv:=nil;
	el3:=cdr el3
      >>;
      intern compress el3
    >>;
    depend u_,h;
    vari:=cons(h,vari);
    (rhs el2) * df(u_,h)
  >>,
  vari)
end$ % of makepde

%----------------------------

algebraic procedure totdeglist(eqlist,ylist)$
begin scalar n,ordr,e1,e2;
  ordr:=0;
  for each e1 in eqlist do
  for each e2 in ylist do
  <<n:=totdeg(e1,e2);
    if n>ordr then ordr:=n>>;
  return ordr
end$ % of totdeglist

%----------------------------

algebraic procedure similarity(problem,genlist,con,u,v)$

% con ... the free constants/functions in the general symmetry
% u ... the name of the new independent variables
% v ... the name of the new   dependent variables

begin scalar vari,pde,el1,el2,el3,el4,copgen,symvarfound,
	     trans1,trans2,i,j,h,h2,n,denew,xlist,ylist,
	     eqlist,ulist,vlist,nx,ny,xslist,yslist,smv,
	     trafoprob;

  cpu:=lisp time()$ gc:=lisp gctime()$

  %--------- extracting input data
  eqlist:=maklist  first problem;
  ylist :=maklist second problem;  ny:=length ylist;
  xlist :=maklist  third problem;  nx:=length xlist;

  trafoprob:={problem,nil};  % to be returned if trafo not possible
  problem:=nil;

  eqlist:=for each el1 in eqlist collect equ_to_expr el1;
%  if length eqlist > 1 then eqlist:=desort eqlist;
  %--------- initial printout
  lisp(
  if tr_as then terpri());
  %--------- initializations
  ordr:=totdeglist(eqlist,ylist)$
  vari:=append(ylist,xlist);
  for each el1 in xlist do
  for each el2 in ylist do
  if not my_freeof(el2,el1) then nodepend el2,el1;       

  lisp(
  if tr_as then << 
    write "The ODE/PDE (-system) under investigation is :";terpri()$
    for each el1 in cdr eqlist do algebraic write"0 = ",el1;
    terpri()$write "for the function(s) : ";
    fctprint( cdr reval algebraic ylist);write".";
    terpri()$terpri()
  >>);
  lisp(
  if tr_as then <<
    if length ylist >2 then  % not >1 because of alg. list in symb. mode
    write"It will be looked for new dependent variables ",u,"i "
		       else
    write"It will be looked for a new dependent variable ",u;
    terpri()$
    if length xlist >2 then
    write"and independent variables ",v,"i"
		       else
    write"and an independent variable ",v;
    write" such that the transformed";
    terpri()$
    write"de(-system) does not depend on ",u;
    if length ylist >2 then write"1";
    write" or ",v$
    if length xlist >2 then write"1";
    write".";
    terpri()
  >>);

%  for each el1 in con do       % i.e. for all symmetries do:
%  if freeoflist(el1,xlist) and
%     freeoflist(el1,ylist) then        %------ no pseudo-Lie-symm.
%  <<copgen:=sub(el1=1,genlist);        %------ calculate symmetry
%    for each el2 in con do
%    if el1 neq el2 then copgen:=sub(el2=0,copgen);

    copgen:=genlist;
%    write"The symmetry now under investigation is:";
%    for each el1 in copgen do write el1;

    %---------- formulate the PDE for the similarity variables
    pde:=first makepde(copgen,u_);
    %--------- find similarity variable
    trans2 :={};
    lisp<<terpri()$write"1. Determination of the similarity variable";
	  if nx+ny>2 then write"s">>;
    trans1 := quasilinpde1(pde,u_,vari); % for the similarity variable
    if trans1 neq {} then
    <<
      %-------------- Determining the similarity variables ui_
      i:=0;
      trans1:=for each el1 in trans1 collect
      <<i:=i+1;
	h:=length(genlist)-1;
	if h=1 then   % one single ODE
	<<
%         write"In the following 1 similarity variable U_ has to be";
%         write"determined through 0 = ff where ff is an"$
%         write"arbitrary function of arguments given in the ",
%              "following list:"$
%         write el1;
	  el2:=num(first el1 - second el1);
	  if freeof(el2,u_) then
	  el2:=num(first el1 - 2*second el1);
	  lisp<<write"A suggestion for this function ff provides:"$
		terpri()>>$
	  write"0 = ", el2$
	  if yesp "Do you like this choice?" then {el2}
					     else <<
	    repeat <<
	      lisp <<
		write"Put in an alternative expression which "$terpri()$
		write"- is functionally dependent only on elements of",
		     " ff given above and"$ terpri()$
		write"- depends on U_ and if set to zero determines U_"$
		terpri()>>$
	      h:=termxread()$
	    >> until not freeof(h,U_)$
	    {h}
	  >>
	>>     else   % a PDE or a system of DEs
	lisp
	<<
%         terpri()$
%         write"Now the similarity variables U_i, i=1,...",h,
%              " have to be"$terpri()$
%         write"determined through conditions 0 = ffi, i=1,...",h,
%              ", where ffi are"$terpri()$
%         write"arbitrary functions ";terpri()$
%         algebraic(write "ffi = ",
%         lisp( cons('ffi,cdr reval algebraic el1)));
%         terpri()$
%         write"such that the functional determinant of these ",
%               "expressions"$ terpri()$
%         write"including u_ from above taken w.r.t. ";
%         for each el3 in cdr algebraic ylist do write reval el3,",";
%         write reval cadr algebraic xlist;
%         for each el3 in cddr algebraic xlist do write ",",reval el3;
%         terpri()$
%         write"must not vanish."$terpri()$
	  algebraic <<
	    el2:=einfachst(el1,u_);
	    h2:={};
	    for each el3 in el1 do
	    if el3 neq el2 then h2:=cons(num(el2-el3),h2)
	  >>;
	  write"A suggestion for these functions ffi in form of a list ",
	       "{ff1,ff2,... } is: "$terpri()$
	  deprint(cdr reval algebraic h2);
	  if yesp "Do you like this choice?" then algebraic h2
					     else <<
	    write"Put in an alternative list of expression which"$
	    terpri()$
	    write"- are functionally dependent only on the above ",
		 "arguments and"$terpri()$
	    write"- which if set to zero determine U_i, i.e."$terpri()$
	    write"- the functional determinant of these expressions"$
	    terpri()$
	    write"  including U_ from above taken w.r.t. ",
	    cdr reval algebraic append(ylist,xlist)$
	    terpri()$
	    write"  must not vanish."$terpri()$
	    algebraic(h2):=termxread()
	  >>
	>>
      >>$
      %--------- find symmetry variable
      pde:=pde-1;
      lisp<<terpri()$write"2. Determination of the symmetry variable">>;
      trans2 := quasilinpde1(pde,u_,vari);  % for the symmetry variable

      if (length xlist=1) and (trans2={}) then 
      for each e1 in fargs u_ do nodepend u_,e1
					  else
      <<% If no symmetry variable is found (trans2={}) then proceed
	% only if special solutions of PDEs are to be found with the
	% solution being only a function of the similarity variables
	if trans2={} then << % take any variable
	  h:=reverse vari;  % reverse to have not a function as symvar
	  while 1+sub(u_=first h,pde)=0 do h:=rest h; % no similarity var.
	  for each e1 in fargs u_ do nodepend u_,e1;
	  h:=first h;
	  trans2:={u_ - h};
	  lisp<<write"Because the correct symmetry variable was not ",
		     "found, the program will";terpri()$
		write"take ",reval algebraic h,
		     " instead with the consequence ",
		     "that not the whole transformed ";terpri()$
		write"PDE will be free of ",
		     reval algebraic h," but only those ",
		     "terms without ",
		     reval algebraic h,"-derivative";terpri()$
		write"which is still of use for finding special ",
		     reval algebraic h,"-independent solutions ";
		terpri()$
		write"of the PDE."
	  >>
	>>           else <<
	  %--------------- Determining an optimal symmetry variable
	  for each e1 in fargs u_ do nodepend u_,e1;
	  symvarfound:=t;
	  i:=0;
	  trans2:=for each el1 in trans2 collect
	  <<i:=i+1;
	    lisp
	    <<
    %         terpri()$
    %         write"In the following the symmetry variable U_",
    %              " has to be"$terpri()$
    %         write"determined through a condition 0 = ff",
    %              ", where ff is"$terpri()$
    %         write"an arbitrary function ";terpri()$
    %         algebraic(write"ff = ",
    %         lisp( cons('ff,cdr reval algebraic el1)));terpri()$
	      write"A suggestion for this function ff(..) yields:";terpri()
	    >>;
	    h:=einfachst(el1,u_);
	    if lisp<<h2:=reval algebraic(num h);
		     (not pairp h2) or (car h2 neq 'PLUS)>> then
	    h:=num(h+1);
    %       if h= first el1 then
    %       if freeof(num(h+second el1),u_) then h:=num(h+2*second el1)
    %                                       else h:=num(h+  second el1)
    %                       else
    %       if freeof(num(h+ first el1),u_) then h:=num(h+2* first el1)
    %                                       else h:=num(h+   first el1);
	    write"0 = ",h$
	    if yesp "Do you like this choice?" then h
					       else <<
	      repeat <<
		lisp <<
		  write"Put in an alternative expression which "$terpri()$
		  write"- is functionally dependent only on arguments of",
		       " ff given above and"$terpri()$
		  write"- depends on u_ and if set to zero determines u_"$
		  terpri()>>$
		h:=termxread()$
	      >> until not freeof(h,u_)$
	      h
	    >>
	  >>
	>>$
	%for each el1 in trans1 do
	%for each el2 in trans2 do 
	
	el1:=first trans1;
	el2:=first trans2;
	
%        <<

	  %------- Grouping the new variables to ulist and vlist

	  yslist:=grouping(el1,el2,xlist,ylist,nx,ny)$
	  xslist:= first yslist;
	  yslist:=second yslist;

	  %---- Renaming the u_ to ui in yslist and to vi in xslist
	  smv:=rename_u_(xslist,yslist,el2,u_,u,v)$
	  xslist:= first smv;
	  yslist:=second smv;
	  vlist := third smv;
	  ulist:=part(smv,4);
	  smv:=part(smv,5);     % the symmetry variable

	  %---- Solve for old variables
	  h2:=solve_for_old_var(xslist,yslist,xlist,ylist,nx,ny);

	  if h2 neq nil then <<

	    %---- Exchange of dependent and independent variables
	    smv:=switch_r_s(h2,smv,ylist,u,v)$
	    xslist:= first smv;
	    yslist:=second smv;
	    smv   :=third smv;

	    %---- Doing the point transformation
	    for each el3 in ulist do
	    <<for each el4 in fargs el3 do nodepend el3,el4;
	      for each el4 in vlist do
	      %if el4 neq smv then % if new DEs without symm. var. smv
	      depend el3,el4>>;

	    for each el3 in ylist do
	    for each el4 in xlist do depend el3,el4;

	    eqlist:=DeTrafo(eqlist,yslist,xslist,ulist,vlist);
            lisp(
            if tr_as then <<
              terpri()$
	      write"The transformed equation";
	      if length(algebraic eqlist)>2 then write"s";
	      if symvarfound then
	      write" which should be free of ",reval algebraic smv,":"
			     else
	      write" in which the terms without ",reval algebraic smv,
		   "-derivative are free of ",reval algebraic smv,":";
	      terpri()
	    >>);
	    eqlist:=for each el3 in eqlist collect <<
	      el3:=factorize num el3;
	      for each el4 in el3 product
	      if 0=totdeglist({el4},ulist) then 1
					   else el4
	    >>;
	    lisp deprint(cdr reval algebraic eqlist);
	    
	    if (length(vlist)>1) and (not freeof(vlist,smv)) then <<
	      vlist:=cons(smv,lisp(delete(reval algebraic smv,
					  reval algebraic vlist)));
	      if yesp 
	    "Shall the dependence on the symmetry variable be dropped?"
	      then
	      <<for each el3 in ulist do 
                if not my_freeof(el3,smv) then nodepend el3,smv;
		vlist:=rest vlist>>;
	      eqlist:=for each el3 in eqlist collect <<
		el3:=factorize num el3;
		for each el4 in el3 product
		if 0=totdeglist({el4},ulist) then 1
					     else el4
	      >>
	    >>;
	    trafoprob:={{eqlist,ulist,vlist},append(xslist,yslist)}
	  >>
%        >>
      >>
    >>;
%  >>;
  for each el1 in xlist do
  for each el2 in ylist do
  depend el2,el1;      
  
  clear ff,ffi;
  return trafoprob
end$ % of similarity

%----------------------------

algebraic procedure quasilinpde1(pde,u_,vari)$
begin scalar trans1,e1,e2,q;
  trans1 := quasilinpde(pde,u_,vari); % for the similarity variable
  if trans1={} then <<
    write"The program was not able to find the general solution ",
	 "of the PDE: ",pde," for the function ",u_,".";
    lisp <<
      write"Please enter either only a semicolon if no solution ",
	   "is known or enter "$terpri()$
      write"the solution of the PDE in form ",
	   "of a list {A1,A2,...} where ";terpri()$
      write"the Ai are algebraic expressions in ",
	   cdr reval algebraic cons(u_,vari);terpri()$
      write"such that any function ff(A1,A2,...) which is not ",
	   "independent of `",u_;write"'";terpri()$
      write"determines a solution `",u_,"' of the PDE through 0=ff: "
    >>;
    trans1:={termxread()};
    if trans1={nil} then trans1:={}
  >>;
  return trans1
end$ % of quasilinpde1

end$