/* Filename reduct2.mac

   ***************************************************************
   *							         *
   *                     <package name>                          *
   *                <functionality description>                  *
   *                                                             *
   *          from: Perturbation Methods, Bifurcation            *
   *                Theory and Computer Algebra.                 *
   *           by Rand & Armbruster (Springer 1987)              *
   *                Programmed by Richard Rand                   *
   *      These files are released to the public domain          *
   *            						 *
   ***************************************************************
*/ 
   /* program number 11: reduction2(), a liapunov-schmidt reduction for
   steady state bifurcations in systems of ordinary differential
   equations. see page 176 and page 211 in "perturbation methods, 
   bifurcation  theory and computer algebra".*/





reduction2():=block(
	   setup(),
	   order:read("to which order do you want to calculate"),
	   for i:2 thru order-1 do  w_poly(i,0),
	   for i:1 thru order-2 do  w_poly(i,1),
	   for i:1 thru order do g_poly(i,0),
	   for i:1 thru order-1 do g_poly(i,1),
	   g_eq())$




setup():=(/*the function setup needs the dimension n of the system of
            o.d.e., the n-dimensional list of variables y, the system
	    of o.d.e's called eqs, the critical eigenvector cfun and
	    the adjoint critical eigenvector afun.*/
   printflag:true,
   ls_list:[],
   n:read("number of equations"),
   y:makelist(read("enter variable number",i),i,1,n),
   alpha:read("enter the bifurcation parameter"),
   cal:read("enter the critical bifurcation value",alpha),
   print("we define lam =",alpha - cal),
   cfun:read("enter the critical eigenvector as a list"),
   afun:read("enter the adjoint critical eigenvector"),
   kill(w,zwlist),
   w:makelist(concat(w,i),i,1,n),
   zwlist:makelist(concat(zw,i),i,1,n),
   depends(append(zwlist,w),[amp,lam]),
   print("enter the differential equation"),
   eqs:makelist(read("diff(",y[i],",t)="),i,1,n),
   eqlam:ev(eqs,ev(alpha) = lam + cal),
   print(eqlam),
   wnull:vfun(w,0),
   zwnull:vfun(zwlist,0),
   sub:maplist("=",y,amp*cfun+w),
   database:map(lambda([u],diff(u,amp)=0),w),
   database:append(database,map(lambda([u],diff(u,lam)=0),w)),
   norm:afun.cfun,
   temp1:ev(eqlam,sub,diff),
   print("do you know apriori that some taylor coefficients"),
	  nullans:read(" are zero, y/n")
   )$


g_poly(i,j):=block(/*provided all  necessary knowledge about the taylor
		     coefficients of w(amp,lam) is stored in the list
		     database, g_poly calculates any specific taylor
		     coefficient of the bifurcation equation 
		     g(amp,lam)= 0 via the projection onto cfun.*/
    ls_list:cons([k=i,l=j],ls_list),
    if nullans = y then (
	     zeroans:read("is ls(",i,j,") identically zero, y/n"),
	     if zeroans = y then  return(bifeq[i,j]:0)),
   wmax_diff:map(lambda([u],'diff(u,amp,i,lam,j) = 0),w),
   temp2:diff(temp1,amp,i,lam,j),
   temp2:subst(wmax_diff,temp2),
   temp3:subst(database,temp2),
   temp4:expand(ev(temp3,amp=0,lam=0,wnull)),
   bifeq[i,j]:ratsimp(temp4.afun))$



w_poly(i,j):=block(/*the function w_poly allows to calculate iteratively,
		     i.e. starting with the lowest order, all taylor
		     coefficients of w(amp,lam) by projecting onto the
		     complement of cfun*/
   if nullans = y then (
		  zeroans:read("is diff(w,amp,",i,"lam,",j," 
                                identically zero, y/n"),
		  if zeroans = y then 
			(addbase:['diff(w,amp,i,lam,j)=0],
			 database:append(database,addbase),
			 return(addbase))),

   wmax_diff:map(lambda([u],'diff(u,amp,i,lam,j) = concat(z,u)),w),
   temp2:diff(temp1,amp,i,lam,j),
   temp2:subst(wmax_diff,temp2),
   temp3:subst(database,temp2),		
   temp4:ev(temp3,amp=0,lam=0,wnull),
   temp5:ev(temp4,zwnull).afun,
   temp6:temp4-temp5/norm*cfun,
   temp7:solve(temp6,zwlist),
   temp8:ev(zwlist,temp7),
   temp9:ratsimp(temp8.afun),
   if temp9 = 0 then 
            addbase:map("=",makelist('diff(w[u],amp,i,lam,j),u,1,n),temp8)
		       else 
			    (temp10:ratsimp(temp8 - temp9/norm*cfun),
			     addbase:map("=",makelist('diff(w[u],amp,i,lam,j),
						u,1,n),temp10)),
   database:append(database,addbase),
   print(addbase))$



vfun(list,value):=map(lambda([u],u=value),list)$
 
g_eq():=  sum(ev(amp^k*lam^l/k!*bifeq[k,l],ls_list[n]),n,1,length(ls_list))$
