/* ndifsub.c
   
     Modification for linking by Don Maszle of ...

   difsub.c

   written by Frederic Yves Bois
   28 August 1991
   
   Copyright (c) 1993.  Don Maszle, Frederic Bois.  All rights reserved.

   -- Revisions -----
     Logfile:  SCCS/s.ndifsub.c
    Revision:  1.1
        Date:  7/14/93
     Modtime:  19:14:48
      Author:  @a
   -- SCCS  ---------

   Differential equation integrator
*/

#ifdef __LOCAL_HDR__
#include "math.h"
#include "string.h"
#include "stdlib.h"

#else
#include <math.h>
#include <string.h>
#include <stdlib.h>
#endif

#include "sim.h"


/* local variables for difsub: */
struct LOC_difsub {
  double *t, *h, *hmax;
  double *ymax;
  long   *maxder;
  controlRec *control;
  paramRec *param;
} ;

/*-------------------------------------------------------------------------*/
void initPertst(matType3 (*pertst)[3],
                struct LOC_difsub *LINK)
{
/*---------------------------------------------------------------------------
For attribution of pertst values.  Called only at a first step.
The coefficients in pertst are used in selecting the step and order.
---------------------------------------------------------------------------*/

  pertst[0][0][0] = 2.0;
  pertst[0][0][1] = 4.5;
  pertst[0][0][2] = 7.333;
  pertst[0][0][3] = 10.42;
  pertst[0][0][4] = 13.7;
  pertst[0][0][5] = 17.15;
  pertst[0][0][6] = 1.0;

  pertst[1][0][0] = 2.0;
  pertst[1][0][1] = 12.0;
  pertst[1][0][2] = 24.0;
  pertst[1][0][3] = 37.89;
  pertst[1][0][4] = 53.33;
  pertst[1][0][5] = 70.08;
  pertst[1][0][6] = 87.97;

  pertst[0][1][0] = 3.0;
  pertst[0][1][1] = 6.0;
  pertst[0][1][2] = 9.167;
  pertst[0][1][3] = 12.5;
  pertst[0][1][4] = 15.98;
  pertst[0][1][5] = 1.0;
  pertst[0][1][6] = 1.0;

  pertst[1][1][0] = 12.0;
  pertst[1][1][1] = 24.0;
  pertst[1][1][2] = 37.89;
  pertst[1][1][3] = 53.33;
  pertst[1][1][4] = 70.08;
  pertst[1][1][5] = 87.97;
  pertst[1][1][6] = 1.0;

  pertst[0][2][0] = 1.0;
  pertst[0][2][1] = 1.0;
  pertst[0][2][2] = 0.5;
  pertst[0][2][3] = 0.1667;
  pertst[0][2][4] = 0.04133;
  pertst[0][2][5] = 0.008267;
  pertst[0][2][6] = 1.0;

  pertst[1][2][0] = 1.0;
  pertst[1][2][1] = 1.0;
  pertst[1][2][2] = 2.0;
  pertst[1][2][3] = 1.0;
  pertst[1][2][4] = 0.3157;
  pertst[1][2][5] = 0.07407;
  pertst[1][2][6] = 0.0139;

}  /* initPertst */


/*-------------------------------------------------------------------------*/
void initPtrs(double **deriv,
              memRec *mem,
	      struct LOC_difsub *LINK)
{
/*--------------------------------------------------------------------------
Inits the dynamic variables by allocating storage for them.
N.B. maxder and n are globals.
--------------------------------------------------------------------------*/
  long i;

  for (i = 0; i <= 6; i++) {
    if (!(deriv[i] = (double *)malloc(sizeof(matType1))))
      ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "initPtrs", NULL);
    if (!(mem->olds.derivold[i] = (double *)malloc(sizeof(matType1))))
      ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "initPtrs", NULL);
  }

  for (i = 0; i < dim1Max; i++)
    if (!(mem->utils.psave[i] = (double *)malloc(sizeof(matType1))))
      ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "initPtrs", NULL);

}  /* initPtrs */


/*------------------------------------------------------------------------*/
void setCoefs (double *eps,
               long *mf, long *n, long *order,
	       coefsRec *coefs,
	       long *kflag,
	       utilsRec *utils,
	       struct LOC_difsub *LINK)
{
/*--------------------------------------------------------------------------
Set the coefficients that determine the order and the method type.
Check for excessive order.

The coefficients are in the order used :

  -1
  -1/2,-1/2
  -5/12,-3/4,-1/6
  -3/8,-11/12,-1/3,-1/24
  -251/720,-25/24,-35/72,-5/48,-1/120
  -95/288,-137/120,-5/8,-17/96,-1/40,-1/720
  -19087/60480,-49/40,-203/270,-49/192,-7/144,-7/1440,-1/5040

  -1
  -2/3,-1/3
  -6/11,-6/11,-1/11
  -12/25,-7/10,-1/5,-1/50
  -120/274,-225/274,-85/274,-15/274,-1/274
  -180/441,-58/63,-15/36,-25/252,-3/252,-1/1764
---------------------------------------------------------------------------*/
  double tempo;

  if (*mf == 0) {
    coefs->a[1] = -1.0000000000000000000;

    switch (*order) {

    case 1:
      coefs->a[0] = -1.0000000000000000000;
      break;

    case 2:
      coefs->a[0] = -0.5000000000000000000;
      coefs->a[2] = -0.5000000000000000000;
      break;

    case 3:
      coefs->a[0] = -0.4166666666666666667;
      coefs->a[2] = -0.7500000000000000000;
      coefs->a[3] = -0.1666666666666666667;
      break;

    case 4:
      coefs->a[0] = -0.3750000000000000000;
      coefs->a[2] = -0.9166666666666666667;
      coefs->a[3] = -0.3333333333333333333;
      coefs->a[4] = -0.0416666666666666667;
      break;

    case 5:
      coefs->a[0] = -0.3486111111111111111;
      coefs->a[2] = -1.0416666666666666667;
      coefs->a[3] = -0.4861111111111111111;
      coefs->a[4] = -0.1041666666666666667;
      coefs->a[5] = -0.0083333333333333333;
      break;

    case 6:
      coefs->a[0] = -0.3298611111111111111;
      coefs->a[2] = -1.1416666666666666667;
      coefs->a[3] = -0.6250000000000000000;
      coefs->a[4] = -0.1770833333333333333;
      coefs->a[5] = -0.0250000000000000000;
      coefs->a[6] = -0.0013888888888888889;
      break;

    case 7:
      coefs->a[0] = -0.3155919312169312000;
      coefs->a[2] = -1.2250000000000000000;
      coefs->a[3] = -0.7518518518518518519;
      coefs->a[4] = -0.2552083333333333333;
      coefs->a[5] = -0.0486111111111111111;
      coefs->a[6] = -0.0048611111111111111;
      coefs->a[7] = -0.0001984126984126984;
      break;

    } /* end of case */

    if (*order > 7)
      *kflag = -2;

  } /* end of if mf = 0 then */

  else {  /* so mf <> 0 */
    coefs->a[1] = -1.0000000000000000000;

    switch (*order) {

    case 1:
      coefs->a[0] = -1.0000000000000000000;
      break;

    case 2:
      coefs->a[0] = -0.6666666666666666667;
      coefs->a[2] = -0.3333333333333333333;
      break;

    case 3:
      coefs->a[0] = -0.5454545454545454545;
      coefs->a[2] = -0.5454545454545454545;
      coefs->a[3] = -0.0909090909090909091;
      break;

    case 4:
      coefs->a[0] = -0.4800000000000000000;
      coefs->a[2] = -0.7000000000000000000;
      coefs->a[3] = -0.2000000000000000000;
      coefs->a[4] = -0.0200000000000000000;
      break;

    case 5:
      coefs->a[0] = -0.4379562043795620438;
      coefs->a[2] = -0.8211678832116788000;
      coefs->a[3] = -0.3102189781021898000;
      coefs->a[4] = -0.0547445255474452555;
      coefs->a[5] = -0.0036496350364963504;
      break;

    case 6:
      coefs->a[0] = -0.408163265306122500;
      coefs->a[2] = -0.920634920634920600;
      coefs->a[3] = -0.416666666666666667;
      coefs->a[4] = -0.099206349206349206;
      coefs->a[5] = -0.011904761904761905;
      coefs->a[6] = -0.000566893424036281;
      break;

    } /* end of case */

    if (*order > 6)
      *kflag = -2;

  } /* end of if mf = 0 else */

  coefs->enq1 = 0.5 / *order;
  coefs->enq2 = 0.5 / (*order + 1);
  coefs->enq3 = 0.5 / (*order + 2);

  if (*mf == 0) {
    tempo = coefs->pertst[1][0][*order - 1] * *eps;
    coefs->e = tempo * tempo;

    tempo = coefs->pertst[1][1][*order - 1] * *eps;
    coefs->eup = tempo * tempo;

    tempo = coefs->pertst[1][2][*order - 1] * *eps;
    coefs->edwn = tempo * tempo;
  } else {
    tempo = coefs->pertst[0][0][*order - 1] * *eps;
    coefs->e = tempo * tempo;

    tempo = coefs->pertst[0][1][*order - 1] * *eps;
    coefs->eup = tempo * tempo;

    tempo = coefs->pertst[0][2][*order - 1] * *eps;
    coefs->edwn = tempo * tempo;
  }

  if (coefs->edwn == 0)
    *kflag = -4;
  else
    coefs->bnd = *eps * coefs->enq3 / *n;

  /* order changed, so : */

  utils->flagpsaveEval = -1;   /* means false */

}  /* setCoefs */


/*-------------------------------------------------------------------------*/
void rescale (double **derivold,
              double *hPrev, double *hmax, double *hmin,
	      long *n, long *order,
	      double *yold,
	      double **deriv,
	      double *h, double *scalFact,
	      double *y,
	      struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Rescale the derivatives with the scaling factor, at exit the scaling factor
  is set to 1, h (the increment) is equal to the previous h multiplied by the
  scaling factor, y equal yold.
  --------------------------------------------------------------------------*/
  long i, j;
  double tempo;
  long FORLIM, FORLIM1;

  tempo = *hmax / *hPrev;

  if (*scalFact > tempo)
    *scalFact = tempo;
  else {
    tempo = *hmin / *hPrev;

    if (*scalFact < tempo)
      *scalFact = tempo;
  }

  tempo = 1.0;
  FORLIM = *order;
  for (i = 0; i < FORLIM; i++) {
    tempo *= *scalFact;
    FORLIM1 = *n;
    for (j = 0; j < FORLIM1; j++)
      deriv[i][j] = derivold[i][j] * tempo;
  }  /*of for i*/

  *h = *hPrev * *scalFact;
  memcpy(y, yold, (size_t) *n * sizeof(double));  /*sizeof(matType1));*/

}  /* rescale */


/*-------------------------------------------------------------------------*/
void initDif (double *eps, double *hmin, double *hmax,
              long *jstart, long *mf, long *n,
	      double *t,
	      double **deriv,
	      double *h,
	      memRec *mem,
	      double *y,
	      long *kflag,
	      double *ymax,
	      struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Initialise la routine dans differents cas de figure: normal step (avec
  eventuel changement d'increment; starting step; redo the last step with
  new increment.
  --------------------------------------------------------------------------*/
  long i, j;
  oldsRec *WITH1;
  coefsRec *WITH2;
  utilsRec *WITH3;
  long FORLIM;

  WITH1 = &mem->olds;   /*of with*/
  WITH2 = &mem->coefs;
  WITH3 = &mem->utils;
  switch (*jstart) {

  case 1:
    WITH1->told = *t;
    memcpy(WITH1->yold, y, sizeof(matType1));
    WITH1->currOrderold = WITH3->currOrder;

    FORLIM = WITH3->currOrder;
    for (i = 0; i < FORLIM; i++)
      memcpy(WITH1->derivold[i], deriv[i], sizeof(matType1));

    WITH1->hold = *h;
    WITH1->hPreviousold = WITH3->hPrevious;

    /*c* if step changed by user, rescale deriv : */
    if (*h != WITH3->hPrevious) {
      WITH3->scalFact = *h / WITH3->hPrevious;
      rescale(WITH1->derivold, &WITH3->hPrevious, hmax, hmin, n,
	      &WITH3->currOrder, WITH1->yold, deriv, h, &WITH3->scalFact, y,
	      LINK);
    }

    WITH3->scalFact = 1.0;

    *kflag = 1;   /*c* succesful completion*/
    break;
    /*of case jstart = 1*/

  case 0:
    initPertst(WITH2->pertst, LINK);   /*c* initialized once for ever*/

/* THIS SHOULD NOT BE DONE WITH EACH ITERATION! */
   initPtrs(deriv, mem, LINK);   /*init dynamics*/

    FORLIM = *n;
    for (i = 0; i < FORLIM; i++)
      ymax[i] = 1.0;

    WITH3->currOrder = 1;

    calcDeriv(LINK->param, t, y, LINK->control, deriv[0]);

    FORLIM = *n;
    for (j = 0; j < FORLIM; j++)
      deriv[0][j] *= *h;

    WITH1->told = *t;
    memcpy(WITH1->yold, y, sizeof(matType1));
    WITH1->currOrderold = WITH3->currOrder;
    memcpy(WITH1->derivold[0], deriv[0], sizeof(matType1));
    WITH1->hold = *h;
    WITH3->hPrevious = *h;

    setCoefs(eps, mf, n, &WITH3->currOrder, &mem->coefs, kflag, &mem->utils,
	     LINK);
    WITH3->nbrStepBeforModif = WITH3->currOrder;
    WITH3->scalFact = 1.0;

    if (*kflag != -4)
      *kflag = 1;
    break;
    /*c* on the first call, the order is set to 1 and
        the initial derivatives are computed : */

    /*of case jstart = 0*/


  case -1:
    *t = WITH1->told;
    WITH3->currOrder = WITH1->currOrderold;
    WITH3->scalFact = *h / WITH1->hold;
    rescale(WITH1->derivold, &WITH1->hold, hmax, hmin, n, &WITH3->currOrder,
	    WITH1->yold, deriv, h, &WITH3->scalFact, y, LINK);
    WITH3->scalFact = 1.0;
    *kflag = 1;
    break;
    /*c* repeat last step by restoring saved
        information : */

    /*of case jstart = -1*/

  }  /* switch */
  
}  /* initDif */


/*-------------------------------------------------------------------------*/
void predict (double *h,
              long *n, long *order,
	      double **deriv,
	      double *t,
	      double *y,
	      struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  The next three for loops compute the predicted values by multiplying
  the information saved in the pascal triangle matrix.
  --------------------------------------------------------------------------*/
  long i, j, j1, j2, FORLIM, FORLIM1, FORLIM2;
  
  *t += *h;

  for (j2 = *order - 1; j2 >= 1; j2--) {
    FORLIM1 = *n;
    for (i = 0; i < FORLIM1; i++)
      deriv[j2 - 1][i] += deriv[j2][i];
  }

  FORLIM1 = *n;
  for (i = 0; i < FORLIM1; i++)
    y[i] += deriv[0][i];

  FORLIM1 = *order;
  for (j = 2; j <= FORLIM1; j++) {
    FORLIM = *order;
    for (j1 = j; j1 <= FORLIM; j1++) {
      j2 = *order - j1 + j - 1;
      FORLIM2 = *n;
      for (i = 0; i < FORLIM2; i++)
	deriv[j2 - 1][i] += deriv[j2][i];

    }  /*of for j1*/
  }  /* for */

}  /* predict */




/*-------------------------------------------------------------------------*/
void evalpsv (double *a,
              double *eps, double *h,
	      long *mf, long *n,
	      paramRec *param,
	      double *sdot1, double *y,
	      double **psave,
	      struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Evalue la matrice jacobienne correspondant au systeme d'equations resolues.
  Si mf (methode) = 1 appelle la routine calcJacob fournie par l'utilisateur
  et qui doit retouner la matrice (fast).
  Si mf (methode) = 2 utilise une differentiation numerique (slow).
  --------------------------------------------------------------------------*/
  long i, j;
  matType1 sdot2;
  double tempo, tempo2;
  matType1 tempoArray;
  long FORLIM, FORLIM1;

  if (*mf == 1) {
    calcJacob(n, param, LINK->t, y, psave);
    tempo = a[0] * *h;

    FORLIM = *n;
    for (i = 0; i < FORLIM; i++) {
      FORLIM1 = *n;
      for (j = 0; j < FORLIM1; j++)
	psave[i][j] *= tempo;
    }

    FORLIM = *n;
    for (i = 0; i < FORLIM; i++)
      psave[i][i] += 1.0;

    return;
  }  /*of if mf = 1 then*/


  memcpy(tempoArray, y, sizeof(matType1));

  FORLIM = *n;
  for (i = 0; i < FORLIM; i++) {
    tempo = fabs(tempoArray[i]);
    if (tempo > *eps)
      tempo = *eps * tempo;
    else
      tempo = *eps * *eps;

    tempoArray[i] += tempo;
    calcDeriv(param, LINK->t, tempoArray, LINK->control, sdot2);

    tempo2 = a[0] * *h / tempo;

    FORLIM1 = *n;
    for (j = 0; j < FORLIM1; j++)
      psave[j][i] = (sdot2[j] - sdot1[j]) * tempo2;

    tempoArray[i] = y[i];
  }  /*of for i*/

  FORLIM = *n;
  for (i = 0; i < FORLIM; i++)
    psave[i][i] += 1.0;


  /*stiff method 2, numerical differentiation : */
  /*of if mf = 1 else*/
}  /* evalpsv */


/*-------------------------------------------------------------------------*/
void correct (double *eps,
              long *mf, long *n,
	      double *ymax,
	      double **deriv,
	      double *error,
	      memRec *mem,
	      double *y,
	      long *kflag,
	      struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Up to 3 corrector iterations are taken.  Convergence is tested by requiring
  changes to be less than bnd which is dependent on the error test constant.
  The sum of the corrections is accumulated in the array error[i].  It is
  equal to the i-th derivative of y multiplied by h**k/(factorial(k-1)*a[k]),
  and is therefore proportional to the actual errors to the lowest power of
  h present (h**k).  If there has been a change of order or there has been
  trouble with convergence, psave is re-evaluated prior to starting the
  corrector iteration in the case of stiff methods.
  --------------------------------------------------------------------------*/
  long areOK;
  double det;
  long i, j, iteration;
  matType1 sdot1;
  double tempo1, tempo2, tempo3;
  matType1 tempoArray;
  coefsRec *WITH1;
  utilsRec *putils;
  long FORLIM, FORLIM1;
  
  WITH1 = &mem->coefs;   /*of with*/
  putils = &mem->utils;

  FORLIM = *n;
  for (i = 0; i < FORLIM; i++)
    error[i] = 0.0;

  iteration = 0;

  while (iteration < 3 && *kflag == 0) {
    iteration++;

    calcDeriv(LINK->param, LINK->t, y, LINK->control, sdot1);

    /*c* non stiff method : */
    if (*mf == 0) {
      areOK = 0;

      FORLIM = *n;
      for (i = 0; i < FORLIM; i++) {
	tempo1 = sdot1[i] * *LINK->h;
	tempo2 = deriv[0][i] - tempo1;
	tempo3 = WITH1->a[0] * tempo2;

	y[i] += tempo3;
	deriv[0][i] = tempo1;
	error[i] += tempo2;

	if (fabs(tempo2) <= WITH1->bnd * ymax[i])
	  areOK++;
      }  /*of for i*/

      /*c* convergence obtained --> exit : */
      if (areOK == *n) {
	*kflag = 1;

      }
      continue;
    }  /*of if mf = 0 then*/

    /*c* stiff methods : */
    if (putils->flagpsaveEval == -1) {   /*c* so false*/
      evalpsv(WITH1->a, eps, LINK->h, mf, n, LINK->param, sdot1, y,
	      putils->psave, LINK);

      matinv(putils->psave, *n, &det);

      if (det == 0.0)   /*c* psave singular*/
	*kflag = -3;   /*c* exit of correct*/
      else
	putils->flagpsaveEval = 0;   /*c* recent*/
    }

    if (putils->flagpsaveEval <= -1) {   /*c* recent or ancient*/
      continue;
    }  /*of if flagpsaveEval > -1  then*/
    areOK = 0;
    FORLIM = *n;
    for (i = 0; i < FORLIM; i++)
      tempoArray[i] = deriv[0][i] - sdot1[i] * *LINK->h;



    FORLIM = *n;
    for (i = 0; i < FORLIM; i++) {
      tempo2 = 0.0;
      FORLIM1 = *n;
      for (j = 0; j < FORLIM1; j++)
	tempo2 += putils->psave[i][j] * tempoArray[j];

      tempo3 = WITH1->a[0] * tempo2;

      y[i] += tempo3;
      deriv[0][i] -= tempo2;
      error[i] += tempo2;

      if (fabs(tempo2) <= WITH1->bnd * ymax[i])
	areOK++;
    }  /* for */

    if (areOK == *n)
      *kflag = 1;

  }  /* while */

  /*c* si sortie sans convergence : */
  if (*kflag == 0)
    *kflag = -3;
  
}  /* correct */





/*-------------------------------------------------------------------------*/
void tryLowerH (double *hmax, double *hmin,
                long *mf, long *n,
		double **deriv,
		double *h,
		long *kflag,
		memRec *mem,
		double *t,
		double *y,
		struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Si la convergence n'a pas ete obtenue dans correct, alors reduire le step
  et, si stiff method, order a reevaluation de la matrice jacobienne.
  --------------------------------------------------------------------------*/
  oldsRec *WITH1;
  utilsRec *WITH2;

  WITH1 = &mem->olds;   /*of with*/

  WITH2 = &mem->utils;
  if (*mf == 0) {
    if (*h <= *hmin * 1.00001)
      return;
    *t -= *h;
    WITH2->scalFact *= WITH2->scalFact * 0.5;

    rescale(WITH1->derivold, &WITH1->hold, hmax, hmin, n, &WITH2->currOrder,
	    WITH1->yold, deriv, h, &WITH2->scalFact, y, LINK);

    *kflag = 0;
    return;
  }

  if (WITH2->flagpsaveEval == 1) {   /*c* ancienne evaluation*/
    WITH2->flagpsaveEval = -1;   /*c* to be reevaluated*/
    *kflag = 0;
  }

  if (*h <= *hmin * 1.00001) {   /*c* step can be halved : */
    return;
  }  /*of if*/

  *t -= *h;
  WITH2->scalFact *= WITH2->scalFact * 0.5;

  rescale(WITH1->derivold, &WITH1->hold, hmax, hmin, n, &WITH2->currOrder,
	  WITH1->yold, deriv, h, &WITH2->scalFact, y, LINK);

  *kflag = 0;

  /*c* mf <> 0 : */
  /*of else*/

}  /* tryLowerH */


/*-------------------------------------------------------------------------*/
void calcError(double *error,
               long *n,
	       double *ymax,
	       double *globError,
	       struct LOC_difsub *LINK)
{
/*--------------------------------------------------------------------------
Calcule l'erreur globale sur un step.
--------------------------------------------------------------------------*/
  long i;
  double tempo;

  *globError = 0.0;
  for (i = 0; i < *n; i++) {
    tempo = error[i] / ymax[i];
    *globError += tempo * tempo;
  }
}  /* calcError */


/*-------------------------------------------------------------------------*/
void calcScale(double *pr, double *scal,
               struct LOC_difsub *LINK)
{
/*---------------------------------------------------------------------------
Compute the scaling factor.
---------------------------------------------------------------------------*/

  if (*pr > 0.0001) *scal = 1.0 / *pr;
  else *scal = 10000.0;

}  /* calcScale */


/*-------------------------------------------------------------------------*/
void lookForModif (double **deriv,
                   double *error,
		   long *maxder,
		   memRec *mem,
		   long *n,
		   double *y, double *ymax,
		   double *globErr,
		   long *newOrder,
		   double *scale,
		   struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Regarde si le step peut etre modifie ou si l'ordre peut etre change.
  --------------------------------------------------------------------------*/
  long j;
  double pr1, pr2, pr3, tempo;
  oldsRec *WITH1;
  coefsRec *WITH2;
  utilsRec *WITH3;
  long FORLIM;

  WITH1 = &mem->olds;   /*of with*/
  WITH2 = &mem->coefs;
  WITH3 = &mem->utils;
  tempo = *globErr / WITH2->e;
  if (tempo != 0.0)
    pr2 = exp(WITH2->enq2 * log(tempo)) * 1.2;
  else
    pr2 = 0.0;

  if (WITH3->currOrder < *maxder && *globErr <= WITH2->e) {
    *globErr = 0.0;

    FORLIM = *n;
    for (j = 0; j < FORLIM; j++) {
      tempo = (error[j] - WITH1->errorold[j]) / ymax[j];
      *globErr += tempo * tempo;
    }

    tempo = *globErr / WITH2->eup;
    if (tempo != 0.0)
      pr3 = exp(WITH2->enq3 * log(tempo)) * 1.4;
    else
      pr3 = 0.0;
  }  /*of if not then*/
  else
    pr3 = 1.0e+20;

  if (WITH3->currOrder > 1) {
    *globErr = 0.0;

    FORLIM = *n;
    for (j = 0; j < FORLIM; j++) {
      tempo = deriv[WITH3->currOrder - 1][j] / ymax[j];
      *globErr += tempo * tempo;
    }

    tempo = *globErr / WITH2->edwn;
    if (tempo != 0.0)
      pr1 = exp(WITH2->enq1 * log(tempo)) * 1.3;
    else
      pr1 = 0.0;
  }  /*of if currOrder > 1 then*/
  else
    pr1 = 1.0e+20;

  if (pr2 <= pr3) {
    if (pr2 > pr1) {
      *newOrder = WITH3->currOrder - 1;
      calcScale(&pr1, scale, LINK);
    } else {  /*c* so pr2 <= pr1 : */
      *newOrder = WITH3->currOrder;
      calcScale(&pr2, scale, LINK);
    }
    return;
  }

  if (pr3 >= pr1) {
    *newOrder = WITH3->currOrder - 1;
    calcScale(&pr1, scale, LINK);
  } else {  /*c* so pr3 < pr1 : */
    *newOrder = WITH3->currOrder + 1;
    calcScale(&pr3, scale, LINK);
  }

  /*c* so pr2 > pr3 : */
}  /* lookForModif */



/*-------------------------------------------------------------------------*/
void calcYmax (long *n, double *y, double *ymax, struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Update eventually ymax with the absolute value of the corresponding y.
  --------------------------------------------------------------------------*/
  long i;
  double tempo;
  long FORLIM;

  FORLIM = *n;
  for (i = 0; i < FORLIM; i++) {
    tempo = fabs(y[i]);
    if (tempo > ymax[i])
      ymax[i] = tempo;
  }
}  /* calcYmax */


/*-------------------------------------------------------------------------*/
void changeOrd (double *eps,
                double *error,
		long *mf, long *n, long *newOrd,
		coefsRec *coefs,
		long *currOrd,
		double **deriv,
		long *kflag,
		utilsRec *utils,
		struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  --------------------------------------------------------------------------*/
  long j;
  double tempo;
  long FORLIM;

  if (*newOrd > *currOrd) {
    tempo = coefs->a[*newOrd - 1] / *newOrd;
    FORLIM = *n;
    for (j = 0; j < FORLIM; j++)
      deriv[*newOrd - 1][j] = error[j] * tempo;
  }

  if (*newOrd != *currOrd) {   /*of with*/
    *currOrd = *newOrd;
    setCoefs(eps, mf, n, currOrd, coefs, kflag, utils, LINK);
  }

}  /* changeOrd */

/*-------------------------------------------------------------------------*/


/*-------------------------------------------------------------------------*/
void preparNextStep (double *eps,
                     double *error,
		     long *maxder, long *mf, long *n,
		     double *y,
		     double *globError,
		     long *kflag,
		     memRec *mem,
		     double **deriv,
		     struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  Prepare le step suivant quand celui en cours est accepte (convergence de
  correct obtenue et erreur globale acceptable).
  Si modifications autorisees:
  Si modifications non autorisees: update errorold, hPrevious, ymax et exit.
  --------------------------------------------------------------------------*/
  long i, j, newOrder;
  double scalfact2, tempo;
  oldsRec *WITH1;
  coefsRec *WITH2;
  utilsRec *WITH3;
  long FORLIM, FORLIM1;

  WITH1 = &mem->olds;   /*of with*/

  WITH2 = &mem->coefs;
  WITH3 = &mem->utils;
  if (WITH3->currOrder > 1) {

    FORLIM = WITH3->currOrder;
    for (i = 2; i <= FORLIM; i++) {
      FORLIM1 = *n;
      for (j = 0; j < FORLIM1; j++)
	deriv[i - 1][j] += WITH2->a[i] * error[j];
    }
  }

  if (WITH3->nbrStepBeforModif == 0) {
    lookForModif(deriv, error, maxder, mem, n, y, LINK->ymax, globError,
		 &newOrder, &scalfact2, LINK);

    if (scalfact2 < 1.1) {
      WITH3->nbrStepBeforModif = 10;
      WITH3->hPrevious = *LINK->h;
      calcYmax(n, y, LINK->ymax, LINK);
      *kflag = 1;   /*c* --> succesful exit*/
      return;
    }

    changeOrd(eps, error, mf, n, &newOrder, &mem->coefs, &WITH3->currOrder,
	      deriv, kflag, &mem->utils, LINK);

    WITH3->nbrStepBeforModif = WITH3->currOrder;

    if (*kflag == -4)
      return;
    tempo = *LINK->hmax / *LINK->h;
    if (scalfact2 > tempo)
      scalfact2 = tempo;

    tempo = 1.0;
    FORLIM = WITH3->currOrder;
    for (i = 0; i < FORLIM; i++) {
      tempo *= scalfact2;
      FORLIM1 = *n;
      for (j = 0; j < FORLIM1; j++)
	deriv[i][j] *= tempo;
    }  /*of for i*/

    *LINK->h *= scalfact2;
    WITH3->hPrevious = *LINK->h;

    calcYmax(n, y, LINK->ymax, LINK);
    *kflag = 1;   /*c* --> succesful exit*/
    return;
  }  /*of if nbrStepBeforModif = 0 then*/


  WITH3->nbrStepBeforModif--;

  if (WITH3->nbrStepBeforModif == 0)
    memcpy(WITH1->errorold, error, sizeof(matType1));

  WITH3->hPrevious = *LINK->h;
  calcYmax(n, y, LINK->ymax, LINK);
  *kflag = 1;   /*c* --> succesful exit*/


  /*c* nbrStepBeforModif <> 0 : */

}  /* preparNextStep */



/*-------------------------------------------------------------------------*/
void prepareReDo (double *eps,
                  double *error,
		  double *hmax, double *hmin,
		  long *mf, long *n,
		  double *ymax,
		  double **deriv,
		  double *globError, double *h,
		  long *kflag,
		  memRec *mem,
		  double *t,
		  long *trialNumber,
		  double *y,
		  struct LOC_difsub *LINK)
{
  /*--------------------------------------------------------------------------
  If the error is too large the optimum step size for this or lower order is
  computed and the step will be retried.  If it should fail two more times
  this is the indication that the derivatives have errors of the wrong order
  so the first derivatives are recomputed and the order is set to 1.
  --------------------------------------------------------------------------*/
  long i;
  double r;
  long newOrder;
  oldsRec *WITH1;
  coefsRec *WITH2;
  utilsRec *WITH3;
  long FORLIM;

  WITH1 = &mem->olds;
  WITH2 = &mem->coefs;
  WITH3 = &mem->utils;
  if (*h <= *hmin * 1.00001) {
    *kflag = -1;

    return;
  }  /*of if h > hmin * 1.00001 then*/

  *t = WITH1->told;

  if (*trialNumber < 3) {
    lookForModif(deriv, error, LINK->maxder, mem, n, y, ymax, globError,
		 &newOrder, &r, LINK);

    /*c* si r has gone crazy : */
    if (r >= 1.0)
      r = 0.1;

    changeOrd(eps, error, mf, n, &newOrder, &mem->coefs, &WITH3->currOrder,
	      deriv, kflag, &mem->utils, LINK);

    WITH3->nbrStepBeforModif = WITH3->currOrder;

    if (*kflag != -4) {
      WITH3->scalFact *= r;
      rescale(WITH1->derivold, &WITH1->hold, hmax, hmin, n, &WITH3->currOrder,
	      WITH1->yold, deriv, h, &WITH3->scalFact, y, LINK);
    }  /*of then*/
    return;
  }  /*of then*/


  if (WITH3->currOrder == 1) {
    *kflag = -4;
    return;
  }  /*of if currOrder <> 1 then*/


  WITH3->currOrder = 1;
  calcDeriv(LINK->param, t, y, LINK->control, WITH1->derivold[0]);
  memcpy(y, WITH1->yold, (size_t) *n * sizeof(double)); /*sizeof(matType1));*/

  FORLIM = *n;
  for (i = 0; i < FORLIM; i++) {
    deriv[0][i] = WITH1->derivold[0][i] * *h;
    WITH1->derivold[0][i] *= WITH1->hold;
  }  /*of for i*/

  setCoefs(eps, mf, n, &WITH3->currOrder, &mem->coefs, kflag, &mem->utils,
	   LINK);

  WITH3->nbrStepBeforModif = WITH3->currOrder;
  *trialNumber = 0;

  /*c* trialNumber >= 3, order -> 1, and restart : */
  /*c* currOrder already = 1 : */
  /*of if trialNumber < 3 else*/
  /*c* d > e and h already at hmin*/

}  /* prepareReDo */



/*-------------------------------------------------------------------------*/
void treatError (long *kflag,
                 memRec *mem,
		 double **deriv,
		 double *h, double *t,
		 long *n,
		 double *y,
		 struct LOC_difsub *LINK)
{
  long i;
  oldsRec *WITH1;
  utilsRec *WITH2;
  long FORLIM;

  WITH1 = &mem->olds;

  WITH2 = &mem->utils;
  if (*kflag >= 0)
    return;
  *t = WITH1->told;
  memcpy(y, WITH1->yold, (size_t) *n * sizeof(double));  /*sizeof(matType1));*/
  WITH2->currOrder = WITH1->currOrderold;

  FORLIM = WITH2->currOrder;
  for (i = 0; i < FORLIM; i++)
    memcpy(deriv[i], WITH1->derivold[i], sizeof(matType1));

  *h = WITH1->hold;
  WITH2->hPrevious = WITH1->hPreviousold;

}  /* treatError */


/*----------------------------------------------------------------------------*/
void difsub (long *n,
             double *t_,
	     double *y,
	     double **deriv,
	     double *h_, double *hmin, double *hmax_, double *eps,
	     long *mf,
	     double *ymax_, double *error,
	     long *kflag, long *jstart, long *maxder_,
	     memRec *mem,
	     controlRec *control_,
	     paramRec *param_)
{
  /*-----------------------------------------------------------------------------
The parameters passed to the subroutine difsub are the following :

n........The number of first order differential equations.  n may be
             decreased on later calls if the number of active equations
             reduces, but it must not be increased without calling with
             jstart = 0
t........The independent variable.
y........An n array containing the dependent variables.  y need to be
             provided by the calling program on the first entry.
deriv....A 7 by n array containing the scaled derivatives.
             deriv[j,i] contains the j-th derivative of y[i]
             scaled by h**j/factorial(j) where h is the current step size.
             If it is desired to interpolate to non mesh points these
             values can be used.  If the current step size is h and the value
             at t + e is needed, form s = e/h, and then compute
                                       j=nq
                   y[i][t+e] = y[i] + Sum  deriv[j,i]*s**j
                                       j=1
h........The step size to be attempted on the next step.  h may be adjusted
             up or down by the program in order to acheive an economical
             integration.  However, if the h provided by the user does not
             cause a larger error than requested, it will be used.  To save
             computer time, the user is advised to use a fairly small step
             for the first call.  It will be automatically increased later.
hmin.....The minimum step size that will be used for the integration.
             Note that on starting this must be much smaller than the average
             h expected since a first order method is used initially.
hmax.....The maximum size to which the step will be increased.
eps......The error test constant.  Single step error estimates divided by
             ymax[i] must be less than this in the euclidean norm.  The step
             and/or order is adjusted to achieve this.
mf.......The method indicator.  The following are allowed :
                0    An adams predictor corrector is used.
                1    A multi-step method suitable for stiff systems is used.
                       It will also work for non-stiff systems.  However the
                       user must provide a subroutine calcJacob which evaluates
                       the partial devivatives of the differential equations
                       with respect to the y's.  This is done by calling
                       calcJacob (n,param,t,y,psave).  psave is an n by n array
                       which must be set to the partial of the i-th equation
                       with respect to the j dependent variable in psave[i,j].
                       psave is actually stored in an m by m array where m
                       is the value of n used on the first call to this
                       program.
                2    The same as case 1, except that this subroutine computes
                       the partial devivatives by numerical differencing of
                       the devivatives.  Hence calcJacob is not called.
ymax.....An array of n locations which contains the maximum of each y seen
             so far.  It is set to 1 in each component at a first entry
             (jstart = 0).  (see the description of eps).
error....An array of n elements which contains the estimated one step error
             in each component.
kflag....A completion code with the following meanings :
                +1   The step was successful.
                 0   Internal use only.
                -1   The convergence of correct is achieved with h = hmin, but
                       the requested error was not achieved.
                -2   The maximum order specified was found to be too large.
                -3   Corrector convergence could not be achieved for h > hmin.
                -4   The requested error is smaller than can be handled for
                       this problem.
jstart...An input indicator with the following meanings :
                -1   Repeat the last step eventually with a new h.
                 0   Perform the first step.  The first step must be done with
                       this value of jstart so that the subroutine can
                       initialize itself.
                +1   Take a new step continuing from the last, eventually with
                       a new h.
maxder...The maximum derivative that should be used in the method.  Since
             the order is equal to the highest derivative used, this restricts
             the order.  It must be less than 8 for adams and 7 for stiff
             methods.
mem......A working space the type of which is defined in the following
             lines.
param....A structure to be passed to the procedures calcDeriv and calcJacob.

The comment Vfs means Var for speed.
The following types must be declared in the calling program :

Const  dim1Max = ...;    (number of equations)

Type
matType1   = Array [1..dim1Max] Of Extended;
matType2   = Array [1..8] Of Extended;
matType3   = Array [1..7] Of Extended;
matType11  = Array [1..dim1Max] Of matType1;
matType31  = Array [1..7] Of matType1;
matType543 = Array [1..2] Of Array [1..3] Of Array [1..7] Of Extended;

oldsRec = Record
              derivold     : matType31;
              errorold     : matType1;
              hold         : Extended;
              hPreviousold : Extended;
              currOrderold : Integer;
              told         : Extended;
              yold         : matType1
             End;

coefsRec = Record
              a      : matType2;
              bnd    : Extended;
              e      : Extended;
              eup    : Extended;
              edwn   : Extended;
              enq1   : Extended;
              enq2   : Extended;
              enq3   : Extended;
              pertst : matType543
             End;

utilsRec = Record
              currOrder         : Integer;
              flagpsaveEval     : Integer;
              hPrevious         : Extended;
              nbrStepBeforModif : Integer;
              psave             : matType11;
              scalFact          : Extended
             End;

memRec   = Record
              olds  : oldsRec;
              coefs : coefsRec;
              utils : utilsRec
             End;
-----------------------------------------------------------------------------*/
  struct LOC_difsub V;
  double globError;
  long trialNumber;

/*-------------------------------------------------------------------------*/


/*---------------------------------------------------- INSTRUCTIONS DE DIFSUB */

  V.t = t_;
  V.h = h_;
  V.hmax = hmax_;
  V.ymax = ymax_;
  V.maxder = maxder_;
  V.control = control_;
  V.param = param_;
  *kflag = 0;   /*c* a priori non exit flag*/

  initDif(eps, hmin, V.hmax, jstart, mf, n, V.t, deriv, V.h, mem, y, kflag,
	  V.ymax, &V);

  if (*kflag == 1) {   /*c* if initDif succesful : */
    *kflag = 0;
    trialNumber = 1;

    while (*kflag == 0 && trialNumber < 5) {
      while (*kflag == 0) {   /*c* iterate only predict and correct : */
	predict(V.h, n, &mem->utils.currOrder, deriv, V.t, y, &V);
	correct(eps, mf, n, V.ymax, deriv, error, mem, y, kflag, &V);

	if (*kflag == -3)   /*c* no convergence in correct : */
	  tryLowerH(V.hmax, hmin, mf, n, deriv, V.h, kflag, mem, V.t, y, &V);
      }

      if (*kflag != 1) {   /*c* if correct succesful : */
	continue;
      }  /*of if kflag = 1 then*/

      *kflag = 0;
      calcError(error, n, V.ymax, &globError, &V);
      mem->utils.flagpsaveEval = 1;   /*c* ancient*/

      if (globError <= mem->coefs.e) {   /*c* error ok : */
	preparNextStep(eps, error, V.maxder, mf, n, y, &globError, kflag, mem,
		       deriv, &V);
	if (*jstart < 1)
	  *jstart = 1;
      } else {  /*c* error too large : */
	prepareReDo(eps, error, V.hmax, hmin, mf, n, V.ymax, deriv,
		    &globError, V.h, kflag, mem, V.t, &trialNumber, y, &V);
	trialNumber++;
      }
    }  /*of while kflag = 0*/

  }  /*of first if kflag = 1 then*/

  if (*kflag != 1)
    treatError(kflag, mem, deriv, V.h, V.t, n, y, &V);

}  /* difsub */



/*----------------------------------------------------------------------------*/
void interpole (double **deriv,
                double *incremTemps,
		long *nbrEq,
		memRec *mem,
		double *temps, double *tToReach,
		double *y, double *yInterpole)
{
  /*Vfs*/
  /*Vfs*/
  /*Vfs*/
  /*Vfs*/
  /*Vfs*/
  /*Vfs*/
  /*Vfs*/

  /*-----------------------------------------------------------------------------
Deriv[j,i] contains the j-th derivative of y[i] scaled by h**j/factorial(j)
where h is the current step size.
This procedure interpolates to non mesh points using these values.
If the current step size is h and the value at t + e is needed, form s = e/h,
and then compute
                                       j=nq
                   y[i][t+e] = y[i] + Sum  deriv[j,i]*(s**j)
                                       j=1
-----------------------------------------------------------------------------*/
  long i, j;
  double s, temp1, temp2;
  long FORLIM, FORLIM1;

  if (*temps == *tToReach) {
    memcpy(yInterpole, y, sizeof(matType1));
    return;
  }
  s = (*tToReach - *temps) / *incremTemps;
  FORLIM = *nbrEq;
  for (i = 0; i < FORLIM; i++) {
    temp1 = 1.0;
    temp2 = 0.0;
    FORLIM1 = mem->utils.currOrder;
    for (j = 0; j < FORLIM1; j++) {
      temp1 *= s;
      temp2 += deriv[j][i] * temp1;
    }
    yInterpole[i] = y[i] + temp2;
  }  /* for */

}  /* interpole */

