/* Filename reduct3.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 12: a liapunov-schmidt reduction for steady state
   bifurcations in systems of partial differential equations 
   depending on one independent space variable. see page 189 in
   "perturbation methods, bifurcation theory and computer algebra".
*/




/*this file contains reduction3(), a function to perform a liapunov-
schmidt reduction for steady state bifurcations from n coupled
partial differential equations on one spatial dimension. 
the following additional functions are supplied:
  setup() allows the problem to be entered.
  g_poly(i,j) calculates the coefficient of amp^i lam^j in the bifurcation
  equation g(amp,lam).
  w_poly(i,j) calculates the coefficient of amp^i lam^j in w(x;amp,lam).
  solve_ode(exp) solves certain ordinary differential equations via a fourier
  mode ansatz.
  feedw(exp) ensures that <afun,w> = 0 .
  find_trig(exp) identifies fourier modes.
  setify(list) transforms a list into a set.
  g_eq() assembles the bifurcation equation.
  vfun(list,value) creates the substitution list 
          [list[1] = value, list[2] = value, ...]
  diffnull(i,j) sets the derivative diff(w,amp,i,lam,j) to zero.*/

reduction3():=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():=( /* this function performs the input for the liapunov-schmidt 
	      reduction*/
assume_pos:true,
ls_list:[],
n:read("enter the number of differential equations"),
y:read("enter the dependent variables as a list"),
xvar:read("enter the spatial coordinate"),
alpha:read("enter the bifurcation parameter"),
cal:read("enter the critical bifurcation value"),
print("we define lam = ",alpha - cal),
cfun:read("enter the critical eigenfunction as a list"),
afun:read("enter the adjoint critical eigenfunction as a list"),
kill(w),
w:makelist(concat(w,i),i,1,n),
zwlist:makelist(concat(zw,i),i,1,n),
nullist:makelist(0,i,1,n),
depends(append(zwlist,w,y),cons(xvar,[amp,lam])),
eqs:makelist(read("enter the differential equation number",i),i,1,n),
eqlam:ev(eqs,ev(alpha) = lam + cal),
print(eqlam),
len:read("what is the length of the space interval"),
wnull:vfun(w,0),
sub:maplist("=",y,amp*cfun+w),
database:append(difnull(1,0),difnull(0,1)),
zwnull:vfun(zwlist,0),
norm:integrate(afun.cfun,xvar,0,len),
temp1:ev(eqlam,sub,diff),
print("do you know apriori that some taylor coefficients are 0"),
nullans:read("y,n")
)$


g_poly(i,j):=block(
/*this is a function to determine a particular taylor coefficient of the
bifurcation equation g(amp,lam) = 0. it requires kowledge about the taylor 
coefficients of w(amp,lam). this knowledge is stored in the list database*/
       ls_list:cons([k=i,l=j],ls_list),
       if nullans = y then (
			    zeroans:read("is g_poly(",i,",",j,")identically 
						zero, y/n"),
			    if zeroans = y then return(bifeq[i,j]:0)),
       temp2:diff(temp1,amp,i,lam,j),
       derivsubst:true,
       /*set the derivatives diff(w,amp,i,lam,j) to zero*/
       temp3:subst(difnull(i,j),temp2),
       /*enter all information in database*/
       d_base_length:length(database),
       for ii thru d_base_length do
                temp3:ev(subst(database[d_base_length+1-ii],temp3),diff),
       derivsubst:false,
       temp4:expand(ev(temp3,amp=0,lam=0,wnull,integrate)),
       /*project onto afun*/
       temp5:ratsimp(temp4.afun),
       bifeq[i,j]:integrate(trigreduce(temp5),xvar,0,len))$




w_poly(i,j):=block(
/* this function allows to determine iteratively any particular taylor 
coefficient of the function w(amp,lam). it returns a differential equation 
for the particular coefficient of interest (called zw1,zw2...). this d.e. 
is solved via solve_ode and the result is fed into database from feedw*/
       if nullans = y then (
		    zeroans:read("is diff(w(amp,",i,",lam,",j,") identically 
					zero, y/n"),
		    if zeroans = y then (
				 addbase:difnull(i,j),
				 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),
       derivsubst:true,
       /*rename the derivatives diff(w,amp,i,lam,j) to zw */
       temp3:subst(wmax_diff,temp2),
       /*enter all information in stored in database*/
       d_base_length:length(database),
       for ii thru d_base_length do
                temp3:ev(subst(database[d_base_length+1-ii],temp3),diff),
       derivsubst:false,
       temp4:ev(temp3,amp=0,lam=0,wnull,integrate),
       /*this is the projection q onto the range of the
         linear differential operator in the problem*/
       temp5:integrate(ev(temp4,zwnull).afun,xvar,0,len),
       temp6:temp4-temp5/norm*cfun, 
       temp7:trigreduce(temp6),
       /*the set of o.d.e.'s to solve */
       w_de:expand(temp7),
       temp8:ev(w_de,vfun(zwlist,0)),
       /*if the particular solution of w_de is zero then w=0 */
       if nullist=temp8 then ( addbase:difnull(i,j),
			       database:append(database,addbase),
			       return(addbase)),
       temp9:solve_ode(temp8),
       feedw(temp9)
       )$
 

solve_ode(exp):=(
/*this function solve the d.e. w_de by a fourier mode ansatz*/
       trigfun:[],
       const:false,
       for i thru n do (
       /*determine the fourier modes*/
		    trig1:exp[i],
		    if trig1 # 0 then  (
		                 trig2:apply1(trig1,sinnull,cosnull),
				 if trig2 # 0 then (
			                      const:true,
					      trig1:trig1-trig2),
		    trigfun:append(find_trig(trig1),trigfun))),
       sol1:delete(dummy,setify(trigfun)),
       /*make an ansatz*/
       ansatz:makelist(sum(am[i,j]*sol1[i],i,1,length(sol1)),j,1,n),
       sol2:ev(w_de,map("=",zwlist,ansatz),diff),
       sol3:makelist(ratcoef(sol2,i),i,sol1),
       eqlist:[],
       for i thru length(sol3) do eqlist:append(eqlist,sol3[i]),
       varlist:[],
       for i thru n do 
		for j thru length(sol1) do varlist:cons(am[j,i],varlist),
       /*find the amplitudes of the fourier modes*/
       sol4:solve(eqlist,varlist),
       /*solve for the constant fourier mode if necessary*/
       cansatz:0,
       if const = true then (cansatz:makelist(concat(con,i),i,1,n),
			     csol1:ev(w_de,map("=",zwlist,cansatz),diff),
			     csol2:apply1(csol1,sinnull,cosnull),
			     csol3:solve(csol2,cansatz)),
       ev(ansatz+cansatz,sol4,csol3))$


feedw(exp):=(
/* this function allows the result of the ode-solver to be entered into 
   the list database. it checks for orthogonality to the critical adjoint
   eigenfunction and removes  solutions of the homogeneous equation (i.e. 
   nonorthogonal terms)*/
       f2:integrate(exp.afun,xvar,0,len),
       if ratsimp(f2)=0 
	        then 
                     addbase:map("=",makelist('diff(w[u],amp,i,lam,j),u,1,n),
							exp)
	        else (ortho_result:ratsimp(exp- f2/norm*cfun),
		     addbase:map("=",makelist('diff(w[u],amp,i,lam,j),u,1,n),
						ortho_result)),
       database:append(database,addbase),
       print(addbase))$
/*collect all information stored in bifeq and assemble the bifurcation
equation*/
g_eq():=  sum(ev(amp^k*lam^l/k!*bifeq[k,l],ls_list[n]),n,1,length(ls_list))$


setify(list):=(/*transforms a list into a set, i.e. removes duplicates*/
	set:[list[1]],
        for i :2 thru length(list) do
	       if not member(list[i],set) then
			set:cons(list[i],set),
	set)$

find_trig(exp):=(/*finds the fourier modes*/
	f_a1:args(exp+dummy),
	f_a2:apply1(f_a1,sinfind,cosfind)
	)$

/*auxiliary functions */
matchdeclare([dummy1,dummy2],true)$
defrule(cosfind,dummy1*cos(dummy2),cos(dummy2))$
defrule(sinfind,dummy1*sin(dummy2),sin(dummy2))$
defrule(cosnull,cos(dummy1),0)$
defrule(sinnull,sin(dummy1),0)$


vfun(list,value):=map(lambda([u],u=value),list)$
difnull(i,j):=map(lambda([u],'diff(u,amp,i,lam,j)=0),w) $
