(**************************************************************************)
(*                                                                        *)
(*                          GEOTOOLS.M                                    *)
(*

   Copyright © 1993-1997, 1998 Techno-Sciences Incorporated
   All Rights Reserved                                                                       
*)
(*                                                                        *)
(**************************************************************************)
 
(**************************************************************************)

BeginPackage["ProPac`GeoTools`"]

(* ****************************************************** *)

(* Function Usage Statements *)

GeometricTools::usage="
Functions provided are\n
\n
Jacob, Grad, LieBracket, Ad,\n
ComplementDistribution, IntersectionDistribution\n
LieDerivative, Involutive, Rank, Span,\n
ExpMap, FlowComposition, EquilibriumSurface,\n
LargestInvariantDistribution,ParametricManifold,\n
SmallestInvariantDistribution,SpecialInverse, \n
RightInverse, LeftInverse, SpecialNullSpace,\n
SimplifyArray, TriangularDecomposition, WriteArray\n
PhasePortrait.
"

ExpMap::usage=
"ExpMap[f,x,s,n] computes an nth order approximation of the flow associated\n
with the vector field f, defined in terms of local coordinates x. The symbol\n
s denotes the indepedent variable.\n"

EquilibriumSurface::usage=
"EquilibriumSurface[f,var,param,var0,param0,newparam,m]
returns {Surf,par}, a local parametric approximation (of order m) to a
smooth surface S defined by the smooth relation f(var,param)=0. 
The approximation is valid around the point (var0,param0).
newparam is a scalar symbol and the surface is characterized 
by Surf(par)={var(par),param(par)} where 
par = {newparam1,..,newparamk} with k = dimension S.

See ParametricManifold.
"

ParametricManifold::usage=
"ParametricManifold[f,var,var0,m] or 
{F,par}=ParametricManifold[f,var,var0]
returns {F,par}, a local parametric representation of an imbedded manifold.
If a smooth manifold M is defined by a smooth relation f(var)=0, 
then par->F(par)=var(par) gives a local approximation of order 
m to M  around the point var0 (belonging to M). par is always of 
the formpar={k1,..,kn} where n = dimension M. Omitting m 
defaults to m=4.
                
See EquilibriumSurface.
"

FlowComposition::usage=
"FlowComposition[Phi,s,Var,Var0,Param,m] returns the composition of the\n
list of flows, Phi. s denotes the flow independent variable, Var is a\n
of dependent variables, Var0 is the initial point from which\n
the flows eminate, Param (optional - default s) is a list of names\n
for the parameters, and m (optional -default 3) is the desired order\n
of the result. It can be called with any of the\n
following argument sets:\n
FlowComposition[Phi,s,Var,Var0]\n
FlowComposition[Phi,s,Var,Var0,m]\n 
FlowComposition[Phi,s,Var,Var0,Param]\n
FlowComposition[Phi,s,Var,Var0,Param,m]\n
The composition can also be obtained without truncation using:\n
FlowComposition[Phi,s,Var,Var0,Infinity]\n 
FlowComposition[Phi,s,Var,Var0,Param,Infinity]\n
However, the composition of complex functions can be time consuming.
"

Grad::usage=
"Grad[f,varlist] computes the gradient of the scalar function f with 
respect to the variables varlist."

Jacob::usage=
"Jacob[f,x] computes the Jacobian of the list of functions f with\n 
respect to the list of variables x.\n
\n
Example: Jacob[{x y, Sin[x^2 +x y]}, {x,y}]"

PhasePortrait::usage=
"PhasePortrait[f,x,T,R] is a utility for plotting trajectoies\n
of flows on R^2. f is a 2-dimensional vector function of the\n
states named in the vector x={x1,x2}. T is the lenght of time for \n
each trajectory. R is a list of 2 lists, each of length 3 that\n
defines a grid of initial states. The first specifies x1 initial\n
states {min,max,increment} and the second specifies x2 initial\n
states.\n PhasePortrait returns a list of graphics objects that\n
can be displayed with Show.\n
\n
usage example:\n
graphs=PhasePortrait[f,x,15,{{-6,6,.5},{-5,5,5}}];\n
Show[graphs3,PlotRange->{{-4,4},{-4,4}},\n
  DisplayFunction->$DisplayFunction]\n
"
LieBracket::usage=
"LieBracket[f,g,var] computes the Lie Bracket of the vector\n
functions f,g with respect to the vector of variables var.\n
\n
Example: LieBracket[{x,Sin[x^2 +x y]},{y,Cos[x y]},{x,y}]"

Ad::usage=
"Ad[f,g,var,n] computes the nth Adjoint (iterated Lie Bracket) of\n
the vector fields f,g with respect to the vector of variables var.\n
        Ad[f,g,var,0]=g\n
        Ad[f,g,var,n]=LieBracket[f,Ad[f,g,var,n-1],var]\n
        Ad[f,g,var]=Ad[f,g,var,1] "

LieDerivative::usage=
"LieDerivative[f,h,x] computes the Lie derivative of the real valued\n
function h of the vector x along the direction defined by the vector\n
field f:\n
  LDf[h](x) = < dh(x),f(x) >\n
\n
LieDerivative[f,h,x,k] computes the k-th order Lie derivative of the\n
real valued function h of the vector x along the direction defined by\n 
the vector field f:\n
  LD^k f[h](x) = LD^(k-1) f[LDf[h]](x)\n
  LD^0 f[h](x) = h(x) "
  
ComplementDistribution::usage=
"ComplementDistribution[Del1,Del2] returns the complement of distrubution\n
Del2 in distribution Del1. Del2 must be contained in Del1."

IntersectionDistribution::usage=
"IntersectionDistribution[Del1,Del2] returns the intersection of the two\n
ditributions Del1 and Del2."
  
Involutive::usage=
"Involutive[X,x] tests a set X of vector fields to determine if it is\n
involutive. It reports the result as a value True or False. The argument\n 
X must be a list of vector fields, and x must be a list of the\n
variables."

Rank::usage=
"Rank[X] computes the (generic) rank of a list of vector fields X."

Span::usage=
"Span[X] gives a basis set for the span of a list of vector fields X."

SpecialInverse::usage=
"SpecialInverse[A] gives the inverse of a square (generically) invertible\n
matrix A. It can be considerably more efficient than the standard\n
Mathematica function Inverse if the elements of A are complex expressions."

RightInverse::usage=
"RightInverse[A] returns the right inverse of A."

LeftInverse::usage=
"LeftInverse[A] returns the left inverse of A."

SmallestInvariantDistribution::usage=
"SmallestInvariantDistribution[tau,del,var] returns the smallest\n
distribution invariant with respect to the set of vector fields\n
tau and containing the distribution del. The fields tau and the \n
distribution del are given in the local coordinates var.
"

LargestInvariantDistribution::usage=
"LargestInvariantDistribution[tau,h,var] returns the largest\n
distribution invariant with respect to the set of vector fields\n
tau and contained in the distribution annihilator of exact codistribution\n
{dh}. The fields tau and the vector-valued function h\n
are given in the local coordinates var.
"

SpecialNullSpace::usage=
"SpecialNullSpace[A] gives a basis for the Null Space of A. It\n
returns an analytic set of basis vector fields if A(x) is\n
analytic." 

SimplifyArray::usage=
"SimplifyArray[A] returns a simplified version of the list A.\n
It is intended to replace the standard function Simplify when\n
complex lists of expressions are to be simplified. SimplifyArray\n
applies Simplify to individual expressions in A or groups of\n
expressions with combined leaf count less than 200."

TriangularDecomposition::usage=
"TriangularDecomposition[f,Del,x,x0,m] returns {Psi,PsiInverse,fnew},\n
given an involutive distribution Del that is invariant with respect to the\n
vector field f - both described in terms of local coordinates x, around a \n
point x0. Psi and PsiInverse define a transformation to new coordinates z, x=Psi(z)\n
alligned with/and transverse to the integral manifolds of Del. It places f(x) in a\n
triangular form given by fnew(z). The transfrom x=Psi(z) and its inverse z=PsiInverse(x)\n
are obtained as a power series of order m. m can be set to Infinity to\n
obtain an exact result if it is computable.
"

WriteArray::usage=
"WriteArray[filename,A] writes the array A to the file filename.\n
WriteArray writes individual expressions or groups of expressions\n
with leaf count less than 200. This partially mitigates the memory\n
explosion that occurs when writing large arrays using the standard\n
Mathematica write functions. WriteArray can roughly double the time\n
required to write an array, but it may reduce the the maximum memory\n
used by an order of magnitude or more. For example, to write\n
and retrieve the two arrays A and B use:\n
\n
      WriteArray[Temp,{A,B}]\n
      {A,B}=Get[Temp]\n  
"

(* ****** Options ****** *)

Accelerate::"Accelerate is an option of EquilibriumSurface and ParametricManifold.\n
Accelerate->True can significantly reduce computation time but may not result in a\n
complete characterization of the manifold. In that event the computation will abort\n
with an error message."

MaxAccelerate::"MaxAccelerate is an option of EquilibriumSurface and ParametricManifold.\n
MaxAccelerate->True can significantly reduce computation time but may not result in a\n
complete characterization of the manifold. In that event the computation will abort\n
with an error message. Try the option Accelerate."

Options[EquilibriumSurface]={Accelerate->False,MaxAccelerate->False};
Options[ParametricManifold]={Accelerate->False,MaxAccelerate->False};

Options[SpecialNullSpace]={ZeroTest->Automatic};


(* ****************************************************** *)

(*  Functions *)

Begin["`private`"]

(* Grad  *)
Clear[Grad];
Grad[f_,var_?VectorQ]:=D[f,#]& /@ var
SetAttributes[Grad,ReadProtected];
SetAttributes[Grad,Protected];
SetAttributes[Grad,Locked];


(* Jacob *)
(*       Jacob[f,x]: computes the Jacobian of a vector function f.        *)
(*                                                                        *)
(*        Jacob[f,{x_j, j=1,...,n}] = {df_i/dx_j | i=i,...,m, j=1,...,n}  *)
Clear[Jacob];
Jacob[f_?VectorQ,var_?VectorQ]:=Outer[D,f,var]
Jacob[f_,var_?VectorQ]:=Grad[f,var]
Jacob[f_,var_]:=D[f,var]
SetAttributes[Jacob,ReadProtected];
SetAttributes[Jacob,Protected];
SetAttributes[Jacob,Locked];

Clear[PhasePortrait];
PhasePortrait[f_List,x_List,T_,R_?MatrixQ]:=Module[{s1,s2,R1,R2},
		R1=R[[1]];
		R2=R[[2]];
		Flatten[
      Table[PhaseTrajectory[f,x,T,s1,s2],{s1,R1[[1]],R1[[2]],R1[[3]]},{s2,
          R2[[1]],R2[[2]],R2[[3]]}]]
		]
SetAttributes[PhasePortrait,ReadProtected];
SetAttributes[PhasePortrait,Protected];
SetAttributes[PhasePortrait,Locked];

PhaseTrajectory[f_,x_,T_,s1_,s2_]:=Module[{t,Eqns,vars,ICs,Solver,TT},
		vars=Map[ToExpression[ToString[#]<>"["<>ToString[t]<>"]"]&,x];
  	ICs=Map[ToExpression[ToString[#]<>"[0]"]&,x];
		Eqns=MakeODEs[x,f,t];
	  (*Solver[ODE_,vars,s_,TT_]:=
		NDSolve[Join[Eqns,{ICs[[1]]==0,ICs[[2]]==0}],vars,{t,0,TT}];*)
		Solver=NDSolve[Join[Eqns,{ICs[[1]]==s1,ICs[[2]]==s2}],vars,{t,0,T},
        MaxSteps\[Rule]60000];
		ParametricPlot[vars/.Solver[[1]],{t,0,T},Compiled\[Rule]False,
      DisplayFunction\[Rule]Identity]
	];

(* LieBracket *)
(*       LieBracket[f,g]: computes the Lie brackets of f and g.           *)
(*                                                                        *)
(*                        dg      df                                      *)
(*                [f,g]=  __ .f - __ .g                                   *)
(*                        dx      dx                                      *)
Clear[LieBracket];
LieBracket[f_?VectorQ,g_?VectorQ,var_?VectorQ]:= (Jacob[g,var] . f -  Jacob[f,var] . g 
                                        /;Length[f]==Length[g]==Length[var])
LieBracket[f_,g_,var_?VectorQ]:=Print["incorrect argument type or size in LieBracket"]
SetAttributes[LieBracket,ReadProtected];
SetAttributes[LieBracket,Protected];
SetAttributes[LieBracket,Locked];

(* Ad *)
(*       Ad[f,g,n]: computes the adjoint of f and g of order n.           *)
(*                                                                        *)
(*                Ad[f,g,n]=[f,Ad[f,g,n-1]], n=1,2,...                    *)
(*                Ad[f,g,0]=g                                             *)
Clear[Ad];
Ad[f_?VectorQ,g_?VectorQ,var_?VectorQ,0]:=(g
       /;Length[f]==Length[g]==Length[var])
Ad[f_?VectorQ,g_List,var_?VectorQ,n_Integer]:=(LieBracket[f,Ad[f,g,var,n-1],var]
       /; VectorQ[f] && Length[f]==Length[g]==Length[var])
Ad[f_?VectorQ,g_?VectorQ,var_?VectorQ]:=Ad[f,g,var,1]
Ad[f_,g_,var_,n_]:=Print["incorrect argument type or size in Ad"]
SetAttributes[Ad,ReadProtected];
SetAttributes[Ad,Protected];
SetAttributes[Ad,Locked];


(* LieDerivative *)
(*       LieDerivative[f,h] : computes the Lie derivative of the          *)
(*                    real valued function h along the direction          *)
(*                    defined by the vector field f:                      *)
(*                                                                        *)
(*                    LDf[h] = < dh,f > = sum_i f_i dh/dx_i               *)
(*                                                                        *)
(*       LieDerivative[f,h,k] : computes the k-th order Lie derivative    *)
(*                    of the real valued function h along the direction   *)
(*                    defined by the vector field f:                      *)
(*                                                                        *)
(*                           k         k-1                                *)
(*                         LD f[h] = LD   f[LDf[h]], k=1,2,...            *)
(*                           0                                            *)
(*                         LD f[h] = LDf[h] = h                           *)
Clear[LieDerivative];
LieDerivative[f_List,h_,var_?VectorQ,0]:=h/; Length[f]==Length[var]
LieDerivative[f_List,h_,var_?VectorQ]:=(Inner[Times,Jacob[h,var],f]/;(VectorQ[f]||MatrixQ[f])&&Length[f]==Length[var])
LieDerivative[f_List,h_,var_?VectorQ,n_Integer]:=
             (LieDerivative[f,LieDerivative[f,h,var],var,n-1]
                                   /; Length[f]==Length[var])

LieDerivative[f_,h_,var_?VectorQ]:=Jacob[h,var] f       (* Scalar f *)
LieDerivative[f_,h_,var_?VectorQ,n_Integer]:=           
             LieDerivative[f,LieDerivative[f,h,var],var,n-1];
SetAttributes[LieDerivative,ReadProtected];
SetAttributes[LieDerivative,Protected];
SetAttributes[LieDerivative,Locked];


(* Involutive *)
Clear[Involutive];
Involutive[f_List,var_?VectorQ]:=Module[{k,h,vec},
    k=Length[f];
    h=Table[LieBracket[f[[i]],f[[j]],var],{i,1,k},{j,i+1,k}];
    vec=Union[Flatten[h,1],f];
    If[Rank[vec]>Rank[f],False,True]
];
SetAttributes[Involutive,ReadProtected];
SetAttributes[Involutive,Protected];
SetAttributes[Involutive,Locked];

(* Distribution Calculations *)
Clear[AddDistribution];
AddDistribution[Del1_?MatrixQ,Del2_?MatrixQ]:=
  Span[Join[Del1,Del2]]/;Length[Del1[[1]]]==Length[Del2[[1]]]
Clear[KerDistrbution];
KerDistribution[Del_?MatrixQ]:=SpecialNullSpace[Del];
Clear[IntersectionDistribution];
IntersectionDistribution[Del1_?MatrixQ,Del2_?MatrixQ]:=
  Span[KerDistribution[AddDistribution[KerDistribution[Del1],KerDistribution[Del2]]]]/;
    Length[Del1[[1]]]==Length[Del2[[1]]];
IntersectionDistribution[Del1_?MatrixQ,{}]:={};
IntersectionDistribution[{},Del2_?MatrixQ]:={};
IntersectionDistribution[{},{}]:={};
SetAttributes[IntersectionDistribution,ReadProtected];
SetAttributes[IntersectionDistribution,Protected];
SetAttributes[IntersectionDistribution,Locked];

Clear[ComplementDistribution];
ComplementDistribution[Del1_?MatrixQ,Del2_?MatrixQ]:=Module[{Op},
		Op=IdentityMatrix[Length[Del2[[1]]]]-RightInverse[Del2].Del2;
		Span[Del1.Op]
   ];
ComplementDistribution[Del1_?MatrixQ,{}]:=Del1;
SetAttributes[ComplementDistribution,ReadProtected];
SetAttributes[ComplementDistribution,Protected];
SetAttributes[ComplementDistribution,Locked];

(* Rank *)
Clear[Rank];
Rank[(m_)?MatrixQ] := Module[{},
     Dimensions[m][[2]]-Length[SpecialNullSpace[m]]
];
SetAttributes[Rank,ReadProtected];
SetAttributes[Rank,Protected];
SetAttributes[Rank,Locked];

(* Span *)
Clear[Span]
Span[A_?MatrixQ]:=Module[{B,n=Length[A],Den,
m=Dimensions[A][[2]],
mat,            (* matrix of symbolic terms of same size as A*)
a,              (* a[i,j] are elements of mat *)
Inv,            (* inverse[mat] *)
ElemsA,         (* List of elements of A *)
ZeroElemsA,     (* positions of the zero elements of A *)
NonZeroElemsA,  (* Complement of ZeroElemsA*)
ZeroRule,       (* Rule to substitute the zero elements first *)
NonZeroRule     (* Rule to substitute the rest of the elements *)
},
(*
    mat=Table[a[i,j], {i,Dimensions[A][[1]]},{j,Dimensions[A][[2]]}];
    ElemsA=Flatten[A];
    ZeroElemsA=Flatten[Position[ElemsA,0]];
    NonZeroElemsA=Complement[Range[Length[ElemsA]],ZeroElemsA];
    ZeroRule=Thread[Flatten[mat][[ZeroElemsA]]->ElemsA[[ZeroElemsA]]];
    NonZeroRule=Thread[Flatten[mat][[NonZeroElemsA]]->ElemsA[[NonZeroElemsA]]];
    B=Span1[mat/.ZeroRule]/.NonZeroRule;
*)
    B=Span1[A];
    Do[Den=Table[Denominator[B[[i]][[j]]],{j,m}];
      {Den}=MapThread[PolynomialLCM,Transpose[{Den}]];
      B[[i]]=Chop[Cancel[Den*B[[i]]]],
      {i,Length[B]}];
    Return[B];
 ];
 Span[{}]:={};
(*
Span1[X_?MatrixQ]:=Module[{XX},
        XX=RowReduce[X];
        XX//.{XX->If[XX[[-1]].XX[[-1]]===0,Drop[XX,-1],XX]}
]
*)
Span1[X_?MatrixQ]:=Module[{XX,XX1},
  		  XX=RowReduce[X];
        If[XX=={},Return[XX]];
        XX1=XX/.{XX->If[XX[[-1]].XX[[-1]]===0,Drop[XX,-1],XX]};
        While[XX=!=XX1,
           XX=XX1;
           If[XX=={},Return[XX]];
           XX1=If[XX1[[-1]].XX1[[-1]]===0,Drop[XX1,-1],XX1]];
        XX
]
SetAttributes[Span,ReadProtected];
SetAttributes[Span,Protected];
SetAttributes[Span,Locked];

(* SpecialInverse *)
Clear[SpecialInverse];
SpecialInverse[A_?MatrixQ]:=Module[{
mat,            (* matrix of symbolic terms of same size as A*)
a,              (* a[i,j] are elements of mat *)
Inv,            (* inverse[mat] *)
ElemsA,         (* List of elements of A *)
ZeroElemsA,     (* positions of the zero elements of A *)
NonZeroElemsA,  (* Complement of ZeroElemsA*)
ZeroRule,       (* Rule to substitute the zero elements first *)
NonZeroRule     (* Rule to substitute the rest of the elements *)
},
mat=Table[a[i,j], {i,Dimensions[A][[1]]},{j,Dimensions[A][[2]]}];
ElemsA=Flatten[A];
ZeroElemsA=Flatten[Position[ElemsA,0]];
NonZeroElemsA=Complement[Range[Length[ElemsA]],ZeroElemsA];
ZeroRule=Thread[Flatten[mat][[ZeroElemsA]]->ElemsA[[ZeroElemsA]]];
NonZeroRule=Thread[Flatten[mat][[NonZeroElemsA]]->ElemsA[[NonZeroElemsA]]];
Inv=Inverse[mat/.ZeroRule];
Inv/.NonZeroRule
]
SetAttribute[SpecialInverse,ReadProtected];
SetAttributes[SpecialInverse,Protected];
SetAttribute[SpecialInverse,Locked];


(* SpecialNullSpace *)
Clear[SpecialNullSpace]
SpecialNullSpace[A_?MatrixQ,opts___]:=Module[{B,n=Dimensions[A][[2]],Den,
mat,            (* matrix of symbolic terms of same size as A*)
a,              (* a[i,j] are elements of mat *)
Inv,            (* inverse[mat] *)
ElemsA,         (* List of elements of A *)
ZeroElemsA,     (* positions of the zero elements of A *)
NonZeroElemsA,  (* Complement of ZeroElemsA*)
ZeroRule,       (* Rule to substitute the zero elements first *)
TT,
NonZeroRule     (* Rule to substitute the rest of the elements *)
},
    B=NullSpace[A,Flatten[{opts}]];
    Do[B[[i]]=Together[B[[i]],Trig->True];
      Den=Product[Denominator[B[[i]]][[j]],{j,n}];
      B[[i]]=Chop[Cancel[Den*B[[i]]]],
      {i,Length[B]}];
    Return[Chop[B]];
]
SetAttributes[SpecialNullSpace,ReadProtected];
SetAttributes[SpecialNullSpace,Protected];
SetAttributes[SpecialNullSpace,Locked];

Clear[GenericNullSpace]
GenericNullSpace[A_?MatrixQ]:=Module[{B,n=Length[A],Den,
mat,            (* matrix of symbolic terms of same size as A*)
a,              (* a[i,j] are elements of mat *)
Inv,            (* inverse[mat] *)
ElemsA,         (* List of elements of A *)
ZeroElemsA,     (* positions of the zero elements of A *)
NonZeroElemsA,  (* Complement of ZeroElemsA*)
ZeroRule,       (* Rule to substitute the zero elements first *)
TT,
NonZeroRule     (* Rule to substitute the rest of the elements *)
},

    mat=Table[a[i,j], {i,Dimensions[A][[1]]},{j,Dimensions[A][[2]]}];
    ElemsA=Flatten[A];
    ZeroElemsA=Flatten[Position[ElemsA,0]];
    NonZeroElemsA=Complement[Range[Length[ElemsA]],ZeroElemsA];
    ZeroRule=Thread[Flatten[mat][[ZeroElemsA]]->ElemsA[[ZeroElemsA]]];
    NonZeroRule=Thread[Flatten[mat][[NonZeroElemsA]]->ElemsA[[NonZeroElemsA]]];
    B=NullSpace[mat/.Dispatch[ZeroRule]];

(*  B=NullSpace[A]; *)

    Do[B[[i]]=Together[B[[i]],Trig->True];
      Den=Product[Denominator[B[[i]]][[j]],{j,n}];
      B[[i]]=Den*B[[i]],
      {i,Length[B]}];
    Return[Chop[B/.NonZeroRule]];
]
SetAttributes[GenericNullSpace,ReadProtected];
SetAttributes[GenericNullSpace,Protected];
SetAttributes[GenericNullSpace,Locked];

Clear[ExpMap];
ExpMap[f_?VectorQ,x_?VectorQ,s_,n_Integer]:=Module[{Exp1,ExpM=x,k=0},
While[k<n,
      ExpM1=ExpM+LieDerivative[f,f,x,k]*s^(k+1)/((k+1)!);
      ExpM=ExpM1;
      k=k+1;
      ];
ExpM
]
SetAttributes[ExpMap,ReadProtected];
SetAttributes[ExpMap,Protected];
SetAttributes[ExpMap,Locked];

Clear[FlowComposition];
FlowComposition[Phi_List,s_,Var_List,Var0_List]:=Module[{
Param},
Param=Table[ToExpression[StringJoin["s",ToString[i]]],{i,Length[Phi]}];
FlowComposition[Phi,s,Var,Var0,Param]
];
FlowComposition[Phi_List,s_,Var_List,Var0_List,m_Integer]:=Module[{
Param},
Param=Table[ToExpression[StringJoin["s",ToString[i]]],{i,Length[Phi]}];
FlowComposition[Phi,s,Var,Var0,Param,m]
];
FlowComposition[Phi_List,s_,Var_List,Var0_List,Param_List]:=
  FlowComposition[Phi,s,Var,Var0,Param,3];
FlowComposition[Phi_List,s_,Var_List,Var0_List,Param_List,m_Integer]:=
Module[{kk=1,n=Length[Phi],CompositeMap,CompositeMap1},
If[Length[Param]!=n,
   If[Length[Param]>n,Print["Too many parameters!"];
                      Return[{}],
                      Print["Too few parameters!"];
                      Return[{}]
   ]
];
CompositeMap=Chop[Phi[[1]]/.Dispatch[Join[Inner[Rule,Var,Var0,List],{s->Param[[1]]}]]];
While[kk<n,
    CompositeMap1=Phi[[kk+1]]/.Dispatch[Join[Inner[Rule,Var,CompositeMap,List],
                               {s->Param[[kk+1]]}]];
    CompositeMap=SeriesExpansion0[CompositeMap1,Param,m];
    kk=kk+1
];
CompositeMap
]
FlowComposition[Phi_List,s_,Var_List,Var0_List,Infinity]:=Module[{
Param},
Param=Table[ToExpression[StringJoin["s",ToString[i]]],{i,Length[Phi]}];
FlowComposition[Phi,s,Var,Var0,Param,Infinity]
];
FlowComposition[Phi_List,s_,Var_List,Var0_List,Param_List,Infinity]:=
Module[{kk=1,n=Length[Phi],CompositeMap,CompositeMap1},
If[Length[Param]!=n,
   If[Length[Param]>n,Print["Too many parameters!"];
                      Return[{}],
                      Print["Too few parameters!"];
                      Return[{}]
   ]
];
CompositeMap=Chop[Phi[[1]]/.Dispatch[Join[Inner[Rule,Var,Var0,List],{s->Param[[1]]}]]];
While[kk<n,
    CompositeMap=Phi[[kk+1]]/.Dispatch[Join[Inner[Rule,Var,CompositeMap,List],
          {s->Param[[kk+1]]}]];
	 kk=kk+1
];
CompositeMap
]
SetAttributes[FlowComposition,ReadProtected];
SetAttributes[FlowComposition,Protected];
SetAttributes[FlowComposition,Locked];

Clear[SmallestInvariantDistribution];
Clear[LargestInvariantDistribution];
MaxExpandDistribution[tau_List,del_List,var_?VectorQ,IntermediateResults_]:=
  Module[{kdel,ktau,h,vec},
    kdel=Length[del];
    ktau=Length[tau];
    h=Table[LieBracket[tau[[i]],del[[j]],var],{i,1,ktau},{j,1,kdel}];
    vec=Span[Union[Flatten[h,1],del]];
    If[IntermediateResults,
            Print["Intermediate distribution is:"];
            Print[vec]];
    If[(Rank[vec]>Rank[del])&&(Rank[vec]!=Length[var]),
       Span[MaxExpandDistribution[tau,vec,var,IntermediateResults]],
      Return[vec]]
];
MaxExpandCodistribution[tau_List,omega_List,var_?VectorQ]:=
  Module[{komega,ktau,h,vec},
		komega=Length[omega];
    	ktau=Length[tau];
    	h=Table[CoLieBracket[tau[[i]],omega[[j]],var],{i,1,ktau},{j,1,komega}];
    	vec=Span[Union[Flatten[h,1],omega]];
		If[(Rank[vec]>Rank[omega])&&(Rank[vec]!=Length[var]),
       	Span[MaxExpandCodistribution[tau,vec,var]],Return[vec]]
 ];
 
SmallestInvariantDistribution[tau_List,del_List,var_?VectorQ]:=
	MaxExpandDistribution[tau,del,var,False];
LargestInvariantDistribution[tau_List,h_?VectorQ,var_?VectorQ]:=
	Module[{omega0,omega},
		omega0=Jacob[h,var];
		omega=MaxExpandCodistribution[tau,omega0,var];
		SpecialNullSpace[omega]
   ];

CoLieBracket[f_?VectorQ,g_?VectorQ,var_?VectorQ]:= (f.Transpose[Jacob[g,var] ] +g.  Jacob[f,var] 
                                        /;Length[f]==Length[g]==Length[var]);
CoLieBracket[f_,g_,var_?VectorQ]:=
	Print["Incorrect argument type or size in LieBracket"];

SetAttributes[SmallestInvariantDistribution,ReadProtected];
SetAttributes[SmallestInvariantDistribution,Protected];
SetAttributes[SmallestInvariantDistribution,Locked];
SetAttributes[LargestInvariantDistribution,ReadProtected];
SetAttributes[LargestInvariantDistribution,Protected];
SetAttributes[LargestInvariantDistribution,Locked];

Clear[TriangularDecomposition];
TriangularDecomposition[f_?VectorQ,Del_?MatrixQ,var_?VectorQ,var0_?VectorQ,
    m_]:=Module[{Phi,Psi,PsiInv,Newf,z,t,
		Trans,InvTrans},
		z=Table[ToExpression[StringJoin["z",ToString[i]]],{i,
          Length[var]}];
		Phi=Map[Flow[#,var,t,m]&,Del];
		Psi=FlowComposition[Reverse[Phi],t,var,var0,Reverse[z],m];
		Trans=Inner[Equal,var,Psi,List];
		If[m==Infinity,InvTrans=Solve[Trans,z],
      	InvTrans={Inner[Rule,z,LocalInverse[z,var,Psi,m],List]}];
		PsiInv=z/.InvTrans[[1]];
		Newf=Simplify[(Jacob[PsiInv,var].f)/.Inner[Rule,var,Psi,List]];
		{Psi,PsiInv,Newf}
   ];
TriangularDecomposition[f_?VectorQ,h_?VectorQ,Del_?MatrixQ,var_?VectorQ,
    var0_?VectorQ,m_]:=Module[{Psi,Phi,ff},
		{Psi,Phi,ff}=TriangularDecomposition[f,Del,var,var0,m];
		{Psi,Phi,ff,h/.Inner[Rule,var,Psi,List]}
		];
SetAttributes[TriangularDecomposition,ReadProtected];
SetAttributes[TriangularDecomposition,Protected];
SetAttributes[TriangularDecomposition,Locked];

MakeODEs[q_,F_,t_]:=Module[{qq,FF,Dynamics},
qq=Table[ToExpression[StringJoin[ToString[q[[i]]],"["<>ToString[t]<>"]"]],{i,
          Length[q]}];
qrule=Inner[Rule,q,qq,List];
FF=F/.qrule;
Dynamics=Inner[Equal,D[qq,t]-FF,Table[0,{i,Length[q]}],List];
Dynamics
];

Flow[f_?VectorQ,x_?VectorQ,t_,m_Integer]:=ExpMap[f,x,t,m];
Flow[f_?VectorQ,x_?VectorQ,t_,Infinity]:=Module[{xx,xx0,yy,Eqnf,sols,Phi},
		xx=Table[
        ToExpression[StringJoin[ToString[x[[i]]],"["<>ToString[t]<>"]"]],{i,
          Length[x]}];
		xx0=Table[
        ToExpression[StringJoin[ToString[x[[i]]],"["<>ToString[0]<>"]"]],{i,
          Length[x]}];
		yy=Table[ToExpression[StringJoin[ToString[y],ToString[i]]],{i,
          Length[x]}];
		Eqnf=MakeODEs[x,f,t];
		sols=DSolve[Join[Eqnf,Inner[Equal,xx0,yy,List]],xx,t];
		Phi=(xx/.sols[[1]])/.Inner[Rule,yy,x,List]
   ];

LocalInverse[var_,newvar_,Trans_]:=LocalInverse[var,newvar,Trans,4];
LocalInverse[var_,var0_,newvar_,Trans_,order_]:=
  var0+LocalInverse[var,newvar,Trans/.Inner[Rule,var,var+var0,List],order];
LocalInverse[var_,newvar_,Trans_,order_]:=Module[
	{A,NN,v},
	A=Jacob[Trans,var]/.Inner[Rule,var,Table[0,{Length[var]}],List];
	NN=Simplify[Trans-A.var];
	v=0*var;
	Do[v=LinearSolve[A,-(NN/.Inner[Rule,var,v,List])+newvar],
  		{i,1,order+1}];
	Clear[MySeries];
	MySeries[FF_,{XX__}]:=Series[FF,XX];
	v=MySeries[v,Map[{#,0,order+1}&,newvar]];
	Simplify[Normal[v]]
];

Clear[SeriesExpansion0];
SeriesExpansion0[A_,x_?VectorQ,n_Integer]:=Module[{
YYY,YY,a},
YYY=A/.Inner[Rule,x,a*x,List];
YY=Normal[Series[YYY,{a,0,n}]]/.{a->1};
Chop[YY]
]
SetAttributes[SeriesExpansion0,ReadProtected];
SetAttributes[SeriesExpansion0,Protected];
SetAttributes[SeriesExpansion0,Locked];

Clear[Truncate0];
Truncate0[A_List,x_List,m_Integer]:=Map[Truncate0[#,x,m]&,A]
Truncate0[A_,x_List,m_Integer]:=
  Chop[Normal[(A/.Inner[Rule,x,a*x,List])+O[a]^(m+1)]/.a->1];
SetAttributes[Truncate0,ReadProtected];
SetAttributes[Truncate0,Protected];
SetAttributes[Truncate0,Locked];

Clear[EquilibriumSurface];
EquilibriumSurface[f_,var_,param_,var0_,param0_,newparam_,m_,opts___]:=Module[
        {n=Length[f],xbar,xbar0,Surf,kk,Par,Index},
        xbar=Join[param,var];   xbar0=Join[param0,var0];
                (* test for dimensions *)
        If[Length[var]!=n,Print["incorrect number of variables"];Return[{}]];
        {Surf,kk}=ParametricManifold[f,xbar,xbar0,m,Flatten[{opts}]];
        Index=Join[Table[i,{i,Length[param]+1,Length[param]+Length[var]}],
          Table[i,{i,Length[param]}]];
        Surf=Surf[[Index]];
        Par=Table[
          ToExpression[StringJoin[ToString[newparam],ToString[i]]],{i,
          Length[kk]}];
        Surf=NormalizeParam[Surf/.Inner[Rule,kk,Par,List],Par];
        {Surf,Par}
        ]
SetAttributes[EquilibriumSurface,ReadProtected];
SetAttributes[EquilibriumSurface,Protected];
SetAttributes[EquilibriumSurface,Locked];

Clear[NormalizeParam];
NormalizeParam[Surf_,Par_]:=Module[{F,A,ALeft,ARight,B,K,
Trans,TransRule,m=Length[Par]},
  F=Take[Surf,-m];
  A=Jacob[F,Par]/.Inner[Rule,Par,0*Par,List];
  If[Rank[A]===m,Trans=Inverse[A],
    ALeft=Transpose[Span1[Transpose[A]]];
    ARight=Transpose[ALeft].A;
    K=NullSpace[ARight];
    B=RightInverse[ARight];
    Trans=Transpose[Join[Transpose[B],K]]
  ];
  TransRule=Inner[Rule,Par,Trans.Par,List];
  Chop[Expand[Surf/.TransRule]]
]                
SetAttributes[NormalizeParam,ReadProtected];
SetAttributes[NormalizeParam,Protected];
SetAttributes[NormalizeParam,Locked];

Clear[ParametricManifold];
ParametricManifold[f_,var_List,var0_List]:=ParametricManifold[f,var,var0,3,{}];
ParametricManifold[f_,var_List,var0_List,m_Integer,opts___]:=Module[
      {n1=Length[f],n2=Length[var],n3,DF,GamVecs,ss,kk,Phi,Index,Index0,Index1,
      DFRep,rules,
      MaxAccelFlag=MaxAccelerate/.Flatten[{opts}]/.Options[ParametricManifold],
      AccelFlag=Accelerate/.Flatten[{opts}]/.Options[ParametricManifold]},
      If[n2!=Length[var0],Print["Inconsistent specification of nominal point."];
       Return[]];
      DF=Jacob[f,var];
      n3=Rank[DF/.Inner[Rule,var,var0,List]];                 
      If[n3==n2,Print["Manifold consists of a single point."];Return[{var0}]];
      If[n3!=n1,Print["Equations may be redundant"]];                                                                                 
      If[MaxAccelFlag,
         GamVecs=GenericNullSpace[DF],
         If[AccelFlag,
            {DFRep,rules}=TrigReplacement[DF];
            GamVecs=SpecialNullSpace[DFRep]/.rules,
            GamVecs=SpecialNullSpace[DF]
         ]
      ];
      Print[ToString[Length[GamVecs]]<>" vector fields computed."];
      If[n2-n3!=Length[GamVecs],
         If[MaxAccelFlag,Print["Warning! MaxAccelerate option may not be appropriate."],
            If[AccelFlag,Print["Warning! Accelerate option may not be appropriate."],
               Print["Warning! Manifold may not be regular at nominal point."]
            ]
         ]
      ];
      If[(LeafCount[GamVecs]>10*Length[GamVecs]*n2*(1+n2+n2^2+n2^3))&&(LeafCount[GamVecs]>10000),
        Print["LeafCount complexity of vector fields is high: "<>ToString[LeafCount[GamVecs]]];
        Print["Simplification will be attempted before proceeding."];
        GamVecs=SimplifyArray[Truncate0[GamVecs/.Inner[Rule,var,var+var0,List],var,3]/.
         Inner[Rule,var,var-var0,List]];
        Print["Final LeafCount complexity of vector fields: "<>ToString[LeafCount[GamVecs]]];
      ];
      kk=Table[ToExpression[StringJoin["k",ToString[i]]],{i,Length[GamVecs]}];
      Phi=Map[ExpMap[#,var,ss,m]&,GamVecs];Print[ToString[Length[Phi]]<>" flow functions computed."];
      If[Rank[(GamVecs/.Inner[Rule,var,var0,List])]!=Length[GamVecs],
        Print["Manifold may not be regular at nominal point."];
        Index0=
            Flatten[Position[(GamVecs/.Inner[Rule,var,var0,List]),
            Table[0,{Dimensions[GamVecs][[2]]}]]];
        Index1=Complement[Table[i,{i,Length[GamVecs]}],Index0];
        Index=Join[Index1,Index0];
        Phi=Phi[[Index]]
       ];
       {FlowComposition[Phi,ss,var,var0,kk,m],kk}
       ]
SetAttributes[ParametricManifold,ReadProtected];
SetAttributes[ParametricManifold,Protected];
SetAttributes[ParametricManifold,Locked];                

Clear[SimplifyArray];
SimplifyArray[A_List/;(Length[A]>0)&&(LeafCount[A]>200)]:= Module[{B},
                B=Map[SimplifyArray[#]&,A]
                ]
SimplifyArray[A_]:=Simplify[Chop[Simplify[Chop[A]]]]
SetAttributes[SimplifyArray,ReadProtected];
SetAttributes[SimplifyArray,Protected];
SetAttributes[SimplifyArray,Locked];                

Clear[TrigReplacement];
TrigReplacement[Fp_]:= Module[{FCombined,FExpU,FExpLength,
                                     SinCosPowerHeads,SinCosPowerTerms ,
                                     NumberOfSinCosPowerTerms,Replacements,
                                     rules,FNew,MNew,CNew},(
       FCombined = Apply[Plus,Flatten[{Fp}]];    
       FExp = Level[FCombined,Infinity];
       FExpU = Union[FExp];
       FExpLength = Length[FExp];
       SinCosPowerHeads = {_Sin,_Cos,_Tan,_Cot,_Sec,_Csc};
       SinCosPowerTerms = Flatten[Map[Cases[FExpU,SinCosPowerHeads[[#]]]&,
                                   Range[1,Length[SinCosPowerHeads]]]];
       NumberOfSinCosPowerTerms = Length[SinCosPowerTerms];
       Replacements = Map[Rule[SinCosPowerTerms[[#]],
                        ToExpression[StringJoin["t",ToString[#]]]]&,
                   Range[1,NumberOfSinCosPowerTerms]];
       rules = Map[Rule[ToExpression[StringJoin["t",ToString[#]]],
                        SinCosPowerTerms[[#]]]&,
                   Range[1,NumberOfSinCosPowerTerms]];
       FNew  = Fp/. Replacements;
{FNew,rules} )];
SetAttributes[TrigReplacement,ReadProtected];
SetAttributes[TrigReplacement,Protected];
SetAttributes[TrigReplacements,Locked];

Clear[WriteArray];
WriteArray[filename_String,array_] := 
        Module[{stream},
            stream = OpenWrite[ filename];
            MyPutAppend[ array, stream];
            Close[ stream];
        ];
MyPutAppend[ array_List /;
                  Length[array] > 0 && LeafCount[array] > 200,
                  openfile_ ] :=
            WriteString[ openfile, "{" (* )}( *) ];
            MapIndexed[
                Function[{element, poslist},
                MyPutAppend[ element, openfile];
                    If[ poslist[[1]] < Length[array],
                            WriteString[ openfile, ", "],
                        (*else*)
                            WriteString[ openfile, (* ){( *) "}"]
                    ];
                ],
                array
            ];
MyPutAppend[ expr_, openfile_ ] := PutAppend[ expr, openfile];
SetAttributes[WriteArray,ReadProtected];
SetAttributes[WriteArray,Protected];
SetAttributes[WriteArray,Locked];

(* Right Inverse *)
Clear[RightInverse];
RightInverse[A_?MatrixQ]:=Module[{m,n,test,
  Id,B,DD,DD1,DD2,ZeroRow,G,IndexSet,XX,row,RowNo},
  {m,n}=Dimensions[A];
  Id=IdentityMatrix[m];
  B=Transpose[Join[Transpose[A],Id]];
  DD=RowReduce[B];
  DD1=DD[[Range[1,m],Range[1,n]]];
  DD2=DD[[Range[1,m],Range[n+1,n+m]]];
  {ZeroRow}=Table[0,{1},{m}];
  G=Position[DD1,1];
  IndexSet={};RowNo=1;
   Do[(If[G[[j,1]]==RowNo,
          IndexSet=Append[IndexSet,G[[j,2]]];
          RowNo=RowNo+1
         ]
   ),{j,Length[G]}];
   XX={};row=1;
   Do[(If[Intersection[{j},IndexSet]=={},
          XX=Append[XX,ZeroRow],
          XX=Append[XX,DD2[[row]]];row=row+1;
         ]
   ),{j,n}];
  XX
]
SetAttributes[RightInverse,ReadProtected];
SetAttributes[RightInverse,Locked];

(*Left Inverse *)
Clear[LeftInverse]
LeftInverse[A_?MatrixQ]:=Module[{B,XX},
  B=Transpose[A];
  XX=Transpose[RightInverse[B]]
]
SetAttributes[LeftInverse,ReadProtected];
SetAttributes[LeftInverse,Locked];


End[]

EndPackage[ ]

