/* load("./Eulix.mac")$ */
/*
 * (C) Helmut Jarausch
 *
 * @version 1.0 Date August 29th, 2017
 *
 * @author Helmut Jarausch
 *         RWTH Aachen University

 * @contents
 *  Eulix is an linearly implicit (by default) extrapolated Euler method.
 *  It uses variable step sizes, variable orders and offers dense output.
 *  Eulix can solve systems like  M y'(t)= f(t,y)  where M is a constant mass
 *  matrix. This enables the solution of differential algebraic equations (DAE)
 *  of index 1, as well.
 *
 *  I have made a simplified version of  SEULEX  published in
 *
 *  E. Hairer, G.Wanner
 *  Solving Ordinary Differential Equations II
 *  Stiff and Differential-Algebraic Problems
 *  Springer 1991

 *  The implicit version is  A-stable up to order 2  
 *  A(alpha) stable with alpha >= 89.81 up to order 8 and probably above
 *  where A-stable = A(alpha)-stable with alpha = 90 degree
 *
 * @license This library is free software; you can redistribute it and/or
 *      modify it under the terms of the GNU Lesser General Public
 *      License as published by the Free Software Foundation; either
 *      version 2.1 of the License, or (at your option) any later version.
 *
 *      This library is distributed in the hope that it will be useful,
 *      but WITHOUT ANY WARRANTY; without even the implied warranty of
 *      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 *       Lesser General Public License for more details.
 *
 *      You should have received a copy of the GNU Lesser General Public
 *      License along with this library; if not, write to the Free Software
 *      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */


SiEuler(t,h,n_step,nd,y,Rhs,fy,ft,J,MassMatrix):= block(
   /* nd = no of (Newton) DiffQuot
      on return:  YT(:,nd1-j) contains the j-th DiffQuot
    */
   [Dim:length(y),dy,hi,j,k,l,Jhq,Q,R,nd1,YT],

   local(Col,Householder,MyQR,BackSolve,YT,mynumer,n_step,nd,nd1,Dim,k,l),
   mode_declare(n_step,fixnum,nd,fixnum,nd1,fixnum,Dim,fixnum,k,fixnum,l,fixnum),

   nd1:nd+1,
   mynumer: if fpprec <= 16 then 'float else 'bfloat, declare(mynumer,evfun),
   
   Col(A,c,[range]):= block( [i0,i1], /* A[1..n,c] or  A[rg[0]..n,c] or A[rg[0]...rg[1],c] */
     local(c,i0,i1),
     mode_declare(c,fixnum,i0,fixnum,i1,fixnum),
     if not matrixp(A) then error("Col:A must be a matrix"),
     i0:1, i1:length(A),
     if length(range) =2 then i1:range[2],
     if length(range)>=1 then i0:range[1],
     genmatrix(lambda([i,j],A[i,j]),i1,c,i0,c)
   ),
   Householder(x):= block([beta,v:copymatrix(x)],
     v[1,1]:v[1,1]*(1+sqrt(dotproduct(x,x))/cabs(v[1,1])),
     beta:2/dotproduct(v,v),
     [v,beta]
   ),

   MyQR(A):= block([b,betas,c,j,k,m,n,Q,R:copymatrix(A),v,vtr,vtq],
     [m,n]:matrix_size(A),
     Q:ident(m),
     for c thru n do (
       [v,b]: Householder(Col(R,c,c)),
       for j thru c-1 do (
         vtq: dotproduct(v,Col(Q,j,c)),
         for k:c thru n do  Q[k,j]: Q[k,j]-(b*vtq)*v[k-c+1,1]
       ),
       for j:c thru n do (
         vtr: dotproduct(v,Col(R,j,c)),
         vtq: dotproduct(v,Col(Q,j,c)),
         for k:c thru n do  R[k,j]: R[k,j]-(b*vtr)*v[k-c+1,1],
         for k:c thru n do  Q[k,j]: Q[k,j]-(b*vtq)*v[k-c+1,1]
       )
     ),
     [Q,R]
   ),

   BackSolve(R,x):= block([j,k,n],
     local(j,k,n),
     mode_declare(j,fixnum,k,fixnum,n,fixnum),
     n:length(R),
     x[n,1]: x[n,1]/R[n,n],
     for j:n-1 step -1 thru 1 do (
       for k:j+1 thru n do x[j,1]: x[j,1]-R[j,k]*x[k,1],
       x[j,1]: x[j,1]/R[j,j]
     ),
     x
   ),
   h: h/n_step,  hi: 1/h,
   dy: fy,
   if matrixp(MassMatrix) then  [Q,R]:MyQR(hi*MassMatrix-J),
   YT:zeromatrix(Dim,nd1),
   for k:1 thru (n_step-nd1) do (
     dy: dy+h*ft,
     y: y + if matrixp(MassMatrix) then BackSolve(R,Q.dy) else h*dy,
     t: t+h,
     dy: ev(apply(Rhs,[t,y]),mynumer)
   ),
   for k:1 thru nd1 do (
     dy: dy+h*ft,
     y: y + if matrixp(MassMatrix) then BackSolve(R,Q.dy) else h*dy,
     for j thru Dim do YT[j,k]: y[j,1], /*  i-th derivative will be in   YT(:,nd+1-i) */
     for l:k-1 step -1 thru 1 do /* compute difference quotients */
        for j thru Dim do YT[j,l]: (YT[j,l+1]-YT[j,l])/h,
     t: t+h,
     if k < nd1 then dy: ev(apply(Rhs,[t,y]),mynumer)
   ),
   YT
)$

Eulix_Row(Rhs,level,Tab,t,h,hlv,nlv,dout, y,fy,ft,J,MassMatrix,Tol,work,swork):= block(
    [maxreduction:0.1,max_fac:4,m:length(y),mf,jd,lv,nd,Err,Err_min,YT,A,mynumer],
    local(mynumer),
    mynumer: if fpprec <= 16 then 'float else 'bfloat, declare(mynumer,evfun),
    mf:ev(m,mynumer),
    nd: if dout then level else 0,
    YT:SiEuler(t,h,nlv[level],nd,y,Rhs,fy,ft,J,MassMatrix),
    /* here  i-th derivative (0 <= i <=nd) is in   YT(:,nd+1-i) */
    for jd:0 thru nd do block( [jd1:jd+1,S:col(YT,nd+1-jd)],
      Tab[level,jd1]:copymatrix(S),
      if jd < level then 
        for lv:level-1 step -1 thru max(1,jd) do
          block([F1,F2],
                F2:ev(nlv[level]/nlv[lv],mynumer), F1: F2/(F2-1), F2:1/(F2-1), 
                S:F1*S-F2*Tab[lv,jd1],
                Tab[lv,jd1]:copymatrix(S)
               )
     ),
     Err:0,
     if level > 1 then
       block([fac,fac_min],
         Err: mat_norm(Tab[1,1]-Tab[2,1],'frobenius)/sqrt(mf),
         Err_min: maxreduction/1.67*Tol*0.93^level,
         if Err > Err_min then (
           fac:exp(log(1.67*Err/Tol)/level)/ 0.93,
           fac_min: exp(log(maxreduction)/level),
           fac: max(fac,fac_min),
           fac: min(fac,max_fac/fac_min)
         ) else fac: exp(log(maxreduction)/level),
         hlv[level]: h/fac,  /* new proposed stepsize */
         swork[level]: work[level]/abs(hlv[level]) /* scaled work */
       ),
      [Tab,hlv,swork,Err]
)$

Eulix_Step(y,t,Rhs,Rhs_Time,Rhs_Jac,h,me,[options]):= block(

  /* This routine is similar to  SEULEX published in
     Hairer/Wanner : Solving ODE II  Stiff and Differential-Algebraic Problems
     input parameters :
       y , t	solution at time  t
       h	initial step size (e.g. from prev. step)
       me	initial extrapolation tableau size (e.g. from prev. step)
     
     output :
       DO_DQ , t  new state y at t unless dout (dense output) is true
                  if dout then list of column vectors : Newton DiffQuot at new t  1..(order+1)
       h , me	  new optimal step size and tableau size for next step
       failed	  Eulix gave up due to more than 10 rejected steps in succession
   */
  [gain1:0.7, gain2:0.9, /* some tuning constants */
   l, m, me: max(3,me), mxp, max_ex, 
   nlv, hlv, work, swork,  fy, ft, Tol, rejected:false, reject_cnt:0, J, Tab, Err,
   dout, WkEst, atol, rtol, Debug, OK, DO_DQ,
   scalarmatrixp:false,keepfloat:true,nolabels:true],

   local(scalarmatrixp,keepfloat,nolabels,allnumberp,mynumer,
         me,l,m,mxp,reject_cnt),

   mynumer: if fpprec <= 16 then 'float else 'bfloat, declare(mynumer,evfun),
   max_ex: assoc('maximum_order,options,20), /* max_ex	max. extrapolation tableau size */
   mxp: max(4,max_ex+1),
   /* dout  if true, enable dense output: Newton DDs in DO_DQ */
   dout: assoc('dense_output,options,true),  
   WkEst: assoc('work_estimates,options,[1,1,0]),
     /* WkEst[1]  (relative) work to evaluate the Rhs
                   and to solve the lin. impl. eqns
        WkEst[2]  (relative) work to compute the Jacobian
        WkEst[3]  (relative) work to decompose the Jacobian (Q-R-decomposition)
     */

   /* atol , rtol absolute/relative tolerance  Tol= atol + rtol*mat_norm(y,'inf) */
   atol:  assoc('absolute_tolerance,options,1e-6),
   rtol:  assoc('relative_tolerance,options,1e-6),
   Debug   : assoc('check_parameters,options,true),
   
   allnumberp(E):= if matrixp(E) then apply("and",maplist(numberp,list_matrix_entries(E)))
                                else numberp(E),

   if Debug then (
     if not (matrixp(y) and length(first(y)) = 1 and allnumberp(y)) then
       error("first parameter of Eulix must be a numeric column"),
     if not (numberp(t) and numberp(h)) then
       error("time (t) and stepsize(h) must be numbers"),
     if not nonneginterp(me) then error("order (me) must be a positive integer"),
     if not nonneginterp(max_ex) then error("maximum_order must be a positive integer"),
     if me > max_ex then error("the order (me) must not be greater than maximum_order")
   ),
   mode_declare(me,fixnum,l,fixnum,m,fixnum,mxp,fixnum,reject_cnt,fixnum),
   Tol: atol+rtol*mat_norm(y,'inf),
   m:length(y),

   /*
     MassMatrix either `false or a square (mass-)matrix M for solving  M y'= Rhs(t,y)
                     it might be a singular matrix for differential-algebraic equations
                     of index 1
   */
   MassMatrix: assoc('mass_matrix,options,ident(m)),
   if Debug then (
     if not is(MassMatrix='false) then
       if not (matrixp(MassMatrix) and length(MassMatrix)=m and length(first(MassMatrix)) = m
          and allnumberp(MassMatrix)) then
          error(simplode(["The mass_matrix parameter must be either 'false or a square ",
                           m,"x",m," numeric matrix"]))
   ),
   fy:ev(apply(Rhs,[t,y]),mynumer),
   ft: ev(apply(Rhs_Time,[t,y]),mynumer),
   if Debug then (
     if not (matrixp(fy) and length(first(fy)) = 1 and length(fy)=m and allnumberp(fy)) then
       error("third parameter (Rhs) of Eulix must return a numeric column - got",fy),
     if not (matrixp(ft) and length(first(ft)) = 1 and length(ft)=m and allnumberp(ft)) then
       error("fifth parameter (Rhs_Time) of Eulix must return a numeric column - got",ft)
   ),
   Tab: if dout then zeromatrix(mxp+2,mxp+2)
                else zeromatrix(mxp+2,1),
   nlv:makelist(i,i,2,mxp+1), hlv:makelist(0,mxp),
   work:makelist(0,mxp), swork:makelist(0,mxp),
   if length(WkEst) # 3 then WkEst:[1,5,1],
   /* compute cummulative work for an extrapolation row */
   work[1]: WkEst[2]+nlv[1]*WkEst[1]+WkEst[3],
   for l:2 thru mxp do work[l]: work[l-1]+(nlv[l]-1)*WkEst[1]+WkEst[3],
   swork[1]: 1.0e30, /* large number */
   
   if matrixp(MassMatrix) then (
      J:ev(apply(Rhs_Jac,[t,y]),mynumer),
      if Debug then
        if not (matrixp(J) and length(J)=m and length(first(J)) = m and allnumberp(J)) then
          error("Jacobian must be a square numeric matrix within - got",J)
   ) else J:0,
   
   OK:false,
   while not OK and reject_cnt <= 10 do  /* build extrapolation tableau */
   block([level,c_me:me-1,opt_me],
     for level:1 thru c_me do 
       [Tab,hlv,swork,Err]: Eulix_Row(Rhs,level,Tab,t,h,hlv,nlv,dout,
                                      y,fy,ft,J,MassMatrix,Tol,work,swork),
     /* check convergence at column level-1 */
     if rejected or me=2 or (Err > Tol and Err < 4*nlv[me]*nlv[me+1]*Tol) then (
       c_me: me,
       /* compute column me */
       [Tab,hlv,swork,Err]: Eulix_Row(Rhs,me,Tab,t,h,hlv,nlv,dout,
                                      y,fy,ft,J,MassMatrix,Tol,work,swork),
       if Err > Tol  and  Err < 2*nlv[me+1]*Tol then (
         c_me: me+1, /* compute column  me+1 */
         [Tab,hlv,swork,Err]: Eulix_Row(Rhs,me+1,Tab,t,h,hlv,nlv,dout,
                                        y,fy,ft,J,MassMatrix,Tol,work,swork)
       )
     ),
     
     /* calculate new order and stepsize */

     if Err > Tol then (
       rejected: true, reject_cnt: reject_cnt+1,
       me: min(c_me,me),
       if  me > 2 and swork[me-1] < gain1*swork[me] then me: me-1,
       if logging then
          printf(true,"rejected at t=~11,3e  order dropped to ~d  new step=~11,3e~%",
                                        t,                    me,           hlv[me]),
       h: hlv[me]
     ) else ( /* accept the step */
       t: t+h,

       if  dout then block([S,nderiv],
         nderiv: c_me,
         DO_DQ: makelist(0,nderiv+2),
         DO_DQ[1]: copymatrix(Tab[1,1]),  /* y */

         /* compute Hermite Interpol (Newton form) p(theta), xi in [0,h] 
            which interpolates  p(0): y 
            p(h): (y(h):Tab[1,1] ...)  
            d^k p(h)/dt^k : d^k y(h)/dt^k : Tab[k,k+1]
          */

         /* best values of d-th derivative is in Tab[max(1,d],d+1) */
         for k:1 thru nderiv do
           
           DO_DQ[k+1]: copymatrix(Tab[k,k+1])/k!,

         /* Hermite Interpolation : all gener. Newton DQ at t+h 
            append a new lower diagonal
          */
         S:y,
         for k:1 thru (nderiv+1) do S: (S-DO_DQ[k])/(-h),
         DO_DQ[nderiv+2]: S
       ) else
         DO_DQ:makelist(copymatrix(Tab[1,1])),  /* y */
       


       if c_me = 2 then (
         opt_me: if rejected then  2 else 3
       ) else (
         if c_me <= me then (
           opt_me: c_me,
           if swork[c_me-1] < gain1*swork[c_me]   then   opt_me: c_me-1,
           if swork[c_me]   < gain2*swork[c_me-1] then  opt_me: c_me+1
         ) else (
           opt_me: c_me-1,
           if  c_me > 3 and swork[c_me-2] < gain1*swork[c_me-1] 
              then opt_me: c_me-2,
           if swork[c_me] < gain2*swork[opt_me] then opt_me: c_me  
         ),
         opt_me: min(max_ex,opt_me)
       ),

       if rejected then (
         me: opt_me,
         opt_me: min(opt_me,c_me),
         h: signum(h)*min(abs(h),abs(hlv[opt_me])),
         rejected: false

       ) else (

         if opt_me <= c_me then  h: hlv[opt_me]
         else if  c_me < me and swork[c_me] < gain2*swork[c_me-1]
               then
                 h: hlv[c_me] * work[opt_me+1]/work[c_me]
               else
                 h: hlv[c_me] * work[opt_me]/work[c_me],
         me: opt_me
       ),
       if logging then
         printf(true,"accepted at t=~11,3e  error=~11,3e  new order ~d  new step=~11,3e~%",
                                 t,         Err,            me,           hlv[me]),
       OK:true
     )
  ),
  
  failed: ev(reject_cnt > 10,pred),
  [DO_DQ,t,h,me,failed]
)$

/* DO_DQ contains the Taylor polynom at the new time tn = t+h
   if we evaluate it for tau in [t,tn]  we have to pass dt= tau-tn
 */

Eulix_Dense_Out(dt,DO_DQ):= block(
  [nd2:length(DO_DQ), y],
  y:copymatrix(DO_DQ[nd2]),
  for k :nd2-1 step -1 thru 1 do
    y: y*dt + DO_DQ[k],
  y
)$

Eulix_Dense_Deriv(dt,DO_DQ):= block(
  [nd2:length(DO_DQ), yt],
  yt:(nd2-1)*copymatrix(DO_DQ[nd2]),
  for k :nd2-1 step -1 thru 2 do yt: yt*dt + (k-1)*DO_DQ[k],
  yt
)$

Eulix_Table(t0,y0,delta_t,t_end,Rhs,Rhs_t,Rhs_jac,Roots,[options]):= block(
  [i,t,dout:false,h,h_sign,y,T,Y,
   DO_DQ,tn,yn,yd,hn,me,root_eps,logging,tabular,gen_table,full_table:false,failed,ttab,
   NumRootConds,find_root:false,State,active_roots,
   rt, Root_Found, Root_Solution,atol, Debug,
   keepfloat:true,scalarmatrixp:false,nolabels:true,RetVal:[],
   Newton_Root,t_left,t_right,f_norm,mynumer,Newton_failure],

   local(keepfloat,scalarmatrixp,nolabels,Newton_Root,mynumer),

  mynumer: if fpprec <= 16 then 'float else 'bfloat, declare(mynumer,evfun),

  h       : assoc('initial_step_size,options,0),
  me      : assoc('initial_order,options,6),
  root_eps: assoc('root_tolerance,options,0),
            /* if root_eps < 0 then use 
                  abs(root_eps)*max(mat_norm("y_left",'inf),mat_norm("y_right",'inf))
               if root_eps = 0 then set root_eps to -1E-8
            */
  logging    : assoc('logging,options,false),
  tabular    : assoc('tabular,options,'all),
  atol       : assoc('absolute_tolerance,options,1e-6),
  Debug      : assoc('check_parameters,options,true),
  
  if is(tabular='none) then gen_table:false
  else if is(tabular='tabular) then  gen_table:true
                               else (gen_table:true,full_table:true),

  options:delete('dense_output=false,delete('dense_output=true,options)),
  if (t_end-t0)*delta_t < 0 then
      error("Eulix: (t_end-t0) must be of same sign as delta_t"),
  if delta_t # 0 then ( dout:true,  options:cons('dense_output=true,options) )
                 else ( dout:false, options:cons('dense_output=false,options) ),

  NumRootConds: length(Roots),
  find_root: ev(NumRootConds > 0,pre),
  
  if find_root and not dout then (
     dout: true,
     if delta_t = 0 then delta_t: (t_end-t0)*0.01
  ),


  /* local Newton function */
  Newton_Root(tl,tr,fct,fctprime,root_eps):= block(
    [fl:fct(tl), fr:fct(tr), t:(tl+tr)/2, dt, f, fp, tmp, N_fail, it:0],
    /* fl * fr <= 0 when called */
    if fl*fr >= 0 then throw(printf(false,
       "Newton no inclusion tl=~14,8f  fl=~17,10e  tr=~14,8f  fr=~17,10e~%",tl,fl,tr,fr)),
    if tl > tr then (
      tmp:tl, tl:tr, tr:tmp,
      tmp:fl, fl:fr, fr:tmp
    ),

    f:fct(t),
    while it < 100 and abs(f) > root_eps do (
      it: it+1,
      fp:fctprime(t),
      /* check if new t would be outside [tl,tr] 
         t-tl < f/fp   or  t-tr > f/fp
       */
      if   (fp > 0   and ((t-tl)*fp < f  or  (t-tr)*fp > f ))
        or (fp <= 0  and ((t-tl)*fp > f  or  (t-tr)*fp < f )) then (
        /* Newton step would be outside [tl,tr] > take a bisection step */
        t:(tl+tr)/2
      ) else   t: t-f/fp,

      f:fct(t),
      if fl*f < 0 then (tr:t, fr:f)
                  else (tl:t, fl:f)
    ),
    if abs(f) > root_eps then throw(simplode(["Newton failed at t=",t])),

  t),

  t:t0,
  y:copymatrix(y0),
  if h=0 then block([atol_me,f0,f_bnd],
     /* estimate the initial step size by looking at Taylor's series for y
        see Gladwell, Shampine, Brankin "Automatic selection of the initial
        step size for an ODE solver", J Comput Appl Math 18(1987) pp175-192 */
    atol_me: exp(log(atol)/(me+1)),
    f0: ev(apply(Rhs,[t,y]),mynumer),
    f_norm: mat_norm(f0,'inf),
    if abs(f_norm) < atol then 
      h: abs((t_end-t0))*0.01
    else (
      if  not is(assoc('mass_matrix,options,0)='false) then (
        f_bnd: f_norm + mat_norm(ev(apply(Rhs_jac,[t,y]).f0,mynumer),'inf),
        h: ev(sqrt(2/f_bnd)*atol_me,mynumer)
      )
      else h: atol_me/f_norm
    ),
    if t_end < t then h: -h,
    if logging then print("computed initial step size=",h)
  ),

  h_sign: signum(h),
  if logging then  print("Eulix_Table : options in effect:",options),
  if gen_table then ( T:[t], Y:[y] ) else (T:[], Y:[]),
  if dout then ttab:t+delta_t,
  Root_Found: false,
  if find_root then  (
    rt:makelist(apply(first(Roots[i]),[t,y]),i,1,NumRootConds),
    State:[t,y,copylist(rt)],
    Root_Solution:[0,0,0]
  ),

  while not Root_Found and (t_end-t)*h_sign > 0 do (
    h: h_sign*min(abs(h),abs(t_end-t)),
    if logging then  (printf(true,"at t= ~10,4f  h= ~11,3e  me= ~2d~%",t,h,me), print(transpose(y))),
    [DO_DQ,tn,hn,me,failed]: apply(Eulix_Step,append([y,t,Rhs,Rhs_t,Rhs_jac,h,me],options)),
    /* tn, DO_DQ */
    yn:first(DO_DQ),
    h: tn-t,  /* <<<< in case of reject within Eulix */
    if  Debug then  ( /* check parameters on the first call at most */
     options: delete('check_parameters=true,options),  Debug: false
    ),
    if failed then (
      throw(simplode(["Eulix failed - too many rejected steps at",
                     t,first(DO_DQ)]))
    ),

    if dout then (   /* find_root  implies dout */
      if (tn-ttab)*h_sign <= 0 then (  /* tn <= ttab  => no extra dense steps */
        if find_root then (
          rt:makelist(apply(first(Roots[i]),[tn,yn]),i,1,NumRootConds),
          if root_eps <= 0 then (
            root_eps: (if root_eps < 0 then abs(root_eps) else 1E-8)*apply('max,abs(rt)),
            if logging then print("root_eps=",root_eps)
          ),
          active_roots:[],
          for i:1 thru NumRootConds do (
            if rt[i]*third(State)[i] <= 0 then (
              active_roots: endcons(i,active_roots)
            )
          ),
          Root_Found: ev(length(active_roots) > 0,pred),
          t_left:t, t_right:tn,
          if not Root_Found then State:[tn,yn,rt]
        )

      ) else  (  /* dense output  extra steps to produce solution at ttab(s) */

        while not Root_Found and (tn-ttab)*h_sign > 0 do (
          yd:Eulix_Dense_Out(ttab-tn,DO_DQ),   /*  DO_DQ is at  (tn,yn)  */
          if gen_table then ( T:cons(ttab,T), Y:cons(yd,Y) ),
          if find_root then (
            /* check sign change between t and ttab : State is at t */
            t_left:t, t_right:ttab,
            rt:makelist(apply(first(Roots[i]),[ttab,yd]),i,1,NumRootConds),
            if root_eps <= 0 then (
              root_eps: (if root_eps < 0 then abs(root_eps) else 1E-8)*apply('max,abs(rt)),
              if logging then print("root_eps=",root_eps)
            ),
            active_roots:[],
            for i:1 thru NumRootConds do (
              if rt[i]*third(State)[i] <= 0 then (
                active_roots: endcons(i,active_roots)
              )
            ),
            Root_Found: ev(length(active_roots) > 0,pred),
            t_left:t, t_right:tn
          ),
          ttab: ttab+delta_t
        )
      ) /* end of dense extra steps */
    ),
    y:copymatrix(first(DO_DQ)),
    if gen_table then ( T:cons(tn,T), Y:cons(y,Y) ),
    t: tn,  h: hn
  ),
  if  Root_Found  then block( [nr,eq,RT,RTprime,th,a_roots_init:false],
    for nr in active_roots do (
      RT: buildq([tn,Eq:first(Roots[nr])],
                 lambda([tau],Eq(tau,Eulix_Dense_Out(tau-tn,DO_DQ)))),
      RTprime: buildq([tn,Eq_y:second(Roots[nr]),Eq_t:third(Roots[nr])],
                      lambda([tau],block([Y:Eulix_Dense_Out(tau-tn,DO_DQ)],
                             dotproduct(Eq_y(tau,Y),Eulix_Dense_Deriv(tau-tn,DO_DQ))
                             + Eq_t(tau,Y))
                      )
                     ),
      th:catch (Newton_Root(t_left,t_right,RT,RTprime,root_eps)),
      if not numberp(th) then (
        print("*** Newton failed at",t_left,"  error:",th),
        Root_Solution:[0,t_left,first(DO_DQ)]
      ) else (
        if a_roots_init then (
           if  h_sign*(th - second(Root_Solution)) < 0  then 
             Root_Solution:[nr,th,Eulix_Dense_Out(th-tn,DO_DQ)]
        ) else (Root_Solution:[nr,th,Eulix_Dense_Out(th-tn,DO_DQ)], a_roots_init:true)
      )
    )

  ) else (
      y:if matrixp(first(DO_DQ))  then copymatrix(first(DO_DQ)) else first(DO_DQ),
      if full_table then ( T:cons(tn,T), Y:cons(y,Y) )
    ),
  if not gen_table then ( T:cons(tn,T), Y:cons(y,Y) ), /* store final time/state */
  if find_root then
    if  Root_Found then (T:cons(Root_Solution[2],T), Y:cons(Root_Solution[3],Y))
      else              Root_Solution:[0,t_end,Y[length(T)]]
  else 
    if dout and full_table then (T:cons(t,T), Y:cons(y,Y)),

  T: reverse(T), Y: reverse(Y),
  if gen_table then
    RetVal: if find_root then [Root_Solution,[T,Y]]  else [T,Y]
  else
    RetVal: if find_root then [Root_Solution,first(Y)]  else  first(Y),

  RetVal

)$

defstruct(Eulix_Spline_Type(t_left,t_right,NewtonPoly))$

Eulix_SplineEval(t,Spls):= block([degree,d,dir,dt,SPL,Spl,TP,y],
  /* search the interval containig t 
     assuming ODE has been integrated in positive t-direction
   */
   SPL: for Spl in Spls do (
      dir:signum(Spl@t_right-Spl@t_left),
      if  dir*(t-Spl@t_left) >= 0  and  dir*(Spl@t_right-t) >= 0  then return(Spl)
   ),
   if is (SPL = 'done) then
     throw(simplode(["SplineEval ",t," is not in [",
                     Spls[1]@t_left,",",Spls[length(Spls)]@t_right,"]"])),
   dt: if  SPL@t_left <= SPL@t_right then t-SPL@t_right  else  t-SPL@t_left,
   TP:SPL@NewtonPoly,  degree:length(TP),
   y:copymatrix(TP[degree]),
   for d:degree-1 step -1 thru 1 do  y: y*dt + TP[d],
   y
)$

Eulix_Spline(t0,y0,t_end,Rhs,Rhs_t,Rhs_jac,[options]):= block(
  [i,t,tn, h,hn,h_sign, me,logging,atol,Debug,y,
   failed, Splines:[], Spl, DO_DQ,
   keepfloat:true,scalarmatrixp:false,nolabels:true],
  local(keepfloat,scalarmatrixp,nolabels,mynumer),
  h       : assoc('initial_step_size,options,0),
  me      : assoc('initial_order,options,6),
  logging    : assoc('logging,options,false),
  atol       : assoc('absolute_tolerance,options,1e-6),
  Debug: assoc('check_parameters,options,true),
  options:delete('dense_output=false,delete('dense_output=true,options)),
  options:cons('dense_output=true,options),

  mynumer: if fpprec <= 16 then 'float else 'bfloat, declare(mynumer,evfun),

  t:t0,
  y:copymatrix(y0),
  if h=0 then block([atol_me,f0,f_bnd],
     /* estimate the initial step size by looking at Taylor's series for y
        see Gladwell, Shampine, Brankin "Automatic selection of the initial
        step size for an ODE solver, J Comput Appl Math 18(1987) pp175-192 */
    atol_me: exp(log(atol)/(me+1)),
    f0: ev(apply(Rhs,[t,y]),mynumer),
    h: ev(atol_me/mat_norm(f0,'inf),mynumer),
    if  not is(assoc('mass_matrix,options,0)='false) then (
      f_bnd: mat_norm(ev(apply(Rhs_t,[t,y]),mynumer),'inf)+ mat_norm(ev(apply(Rhs_jac,[t,y]).f0,mynumer),'inf),
      h: ev(sqrt(2/f_bnd)*atol_me,mynumer)
    ),
    if t_end < t then h: -h,
    if logging then print("computed initial step size=",h)
  ),

  h_sign: signum(h),
  if logging then  print("Eulix_Spline : options in effect:",options),

  while (t_end-t)*h_sign > 0 do (
    h: h_sign*min(abs(h),abs(t_end-t)),
    if logging then  printf(true,"at t= ~10,4f  h= ~11,3e  me= ~2d~%",t,h,me),
    [DO_DQ,tn,hn,me,failed]: apply(Eulix_Step,append([y,t,Rhs,Rhs_t,Rhs_jac,h,me],options)),
    h: tn-t,  /* <<<< in case of reject within Eulix */
    if  Debug then  ( /* check parameters on the first call at most */
     options: delete('check_parameters=true,options),  Debug: false
    ),
    if failed then (
      throw(simplode(["Eulix failed - too many rejected steps at",
                     t,if dout then first(DO_DQ) else DO_DQ]))
    ),

    Spl:new(Eulix_Spline_Type),
    Spl@t_left:t, Spl@t_right:tn,
    Spl@NewtonPoly:makelist(copymatrix(DO_DQ[i]),i,1,length(DO_DQ)),
    Splines:cons(Spl,Splines),
    y:copymatrix(first(DO_DQ)),
    t: tn,  h: hn
  ),
  reverse(Splines)
)$




Eulix(Expressions,Vars,initials,range,[options]):= block(
  [NumExpr,NumVars,MassMatrix,i,t0,t_end,delta_t,x,col2list,
   DO_DQ,Rhs,Rhs_jac,RootExpressions,tabular,gen_table:true,combined_t_y_list,
   Results,Root_Solution,tlist,ylist,
   keepfloat:true,scalarmatrixp:false,nolabels:true,RetVal:[],
   V,y, gen_rhs,gen_jacobian,gen_fct,gen_grad, Rhs_t],

   local(keepfloat,scalarmatrixp,nolabels,
   gen_rhs,gen_jacobian,gen_fct,gen_grad, Rhs_t,
         col2list,mynumer,MassMatrix),

  x:range[1],

  mynumer: if fpprec <= 16 then 'float else 'bfloat, declare(mynumer,evfun),

  gen_rhs (_Expr, _V, X) := block([Ex:_Expr,V:_V,%_y:gensym(),_y],
    Ex:maplist(lambda([E],if atom(E) then E
                      else if op(E)#"=" then E
                           else if is(rhs(E)=0) then lhs(E) else rhs(E)),Ex),
    subst (makelist (V[i] = %_y[i, 1], i, 1, length (V)), Ex),
     buildq ([MList : makelist ([ev(e,mynumer,nouns)], e, %%),t:X,_y:%_y],
             lambda ([t, _y], matrix (splice (MList))))),

  tabular          : assoc('tabular,options,'all),
  combined_t_y_list: assoc('combined_t_y_list,options,true),
  if not listp(Expressions) then Expressions:[Expressions],
  if not listp(Vars)        then Vars : [Vars],
  if not listp(initials)    then initials:[initials],
  NumExpr: length(Expressions), NumVars:length(Vars),
  MassMatrix:ident(NumExpr),
  for i:1 thru NumExpr do 
    if not atom(Expressions[i]) then
      if op(Expressions[i])="=" then MassMatrix[i,i]:0,

  options:cons('mass_matrix=MassMatrix,options),

  /* local col2list function */
  col2list(L):= block(
    if  listp(L) then  maplist(lambda([v],transpose(v)[1]),L)
    else transpose(L)[1]
  ),

  gen_fct(_Expr, _V, X) := block([Ex:_Expr,V:_V,%_y:gensym(),_y],
    local(V,_y),
    subst (makelist (V[i] = %_y[i, 1], i, 1, length (V)), ev(Ex,nouns,mynumer)),
    buildq([Fct:%%,t:X,_y:%_y], lambda ([t, _y], Fct))),


  gen_grad(F,xx,NVars)::= block([i,n:ev(NVars),J,X:ev(xx)],
    local(_y),
       J: genmatrix(lambda([i,j],diff(F(X,y),y[i,1])),n,1),
    J: genmatrix(lambda([i,j],ev(diff(F(X,_y),_y[i,1]),diff,mynumer)),n,1),
     buildq([J,t:X],lambda([t,y],J))
  ),

  gen_jacobian(F,xx,Fdim)::= block([i,n:ev(Fdim),J,X:ev(xx)],
    local(_y),
    J: genmatrix(lambda([i,j],ev(diff(F(X,_y)[i,1],_y[j,1]),diff,mynumer)),n,n),
     buildq([J,t:X],lambda([t,_y],J))
  ),

  Rhs:gen_rhs(Expressions,Vars,x),
  define(Rhs_t(x,'y),diff(apply(Rhs,[x,'y]),x)),
  Rhs_jac:gen_jacobian(Rhs,x,length(Expressions)),

  t0:range[2], t_end:range[3],
  if length(range) > 3 then  delta_t:range[4] else delta_t:0,
  gen_table: is(tabular # 'none),
  Roots:[],
  if length(range) > 4 then (
    RootExpressions: range[5],
    if not listp(RootExpressions) then RootExpressions:[RootExpressions],
    for Cond in RootExpressions do block([Eq,%_y:gensym(),t],
      Eq:gen_fct(Cond,Vars,x),
      Roots: endcons([Eq,gen_grad(Eq,x,NumVars),
                        buildq([t:x,_y:%_y,body:diff(Eq(t,_y),t)],
                               lambda ([t, _y],body))
                      ],
                      Roots)
    )
  ),
  options:cons('check_parameters=false, options),
  if logging then  print("Eulix : options in effect:",options),

  Results: apply(Eulix_Table,append([t0,transpose(matrix(initials)),delta_t,t_end,
                                  Rhs,Rhs_t,Rhs_jac,Roots],options)),

  if length(Roots) > 0 then (
    if gen_table then (
      [Root_Solution,[tlist,ylist]]: Results,
      ylist: col2list(ylist),
      if Root_Solution[1] > 0  then Root_Solution[3]:col2list(Root_Solution[3]),
      RetVal : if combined_t_y_list then (
                 [Root_Solution,
                  maplist(lambda([t,yl],cons(t,yl)),tlist,ylist)
                 ]
               ) else [Root_Solution,[tlist,ylist]]
    ) else RetVal :[Results[1],col2list(Results[2])]
  ) else 
      if gen_table then (
        [tlist,ylist]: Results,

        ylist: col2list(ylist),
        RetVal : if combined_t_y_list then (
                   maplist(lambda([t,yl],cons(t,yl)),tlist,ylist)
                 ) else [tlist,ylist]
      ) else RetVal :col2list(Results),
  RetVal
)$



eval_when(loadfile,
  compile(SiEuler,Eulix_Row,Eulix_Step,Eulix_Dense_Out,Eulix_Dense_Deriv,
          Eulix_Table,Eulix_SplineEval,Eulix_Spline,Eulix)
)$
