/* ddaspk.f -- translated by f2c (version 20030320).
   You must link the resulting object file with the libraries:
	-lf2c -lm   (in that order)
*/

#include "f2c.h"

/* Table of constant values */

static integer c__49 = 49;
static integer c__201 = 201;
static integer c__0 = 0;
static doublereal c_b37 = 0.;
static integer c__47 = 47;
static integer c__202 = 202;
static integer c__1 = 1;
static integer c__41 = 41;
static integer c__203 = 203;
static integer c__4 = 4;
static doublereal c_b67 = .6667;
static integer c__9 = 9;
static integer c__5 = 5;
static integer c__56 = 56;
static integer c__501 = 501;
static integer c__2 = 2;
static integer c__502 = 502;
static integer c__503 = 503;
static integer c__38 = 38;
static integer c__610 = 610;
static integer c__48 = 48;
static integer c__611 = 611;
static integer c__620 = 620;
static integer c__621 = 621;
static integer c__45 = 45;
static integer c__622 = 622;
static integer c__630 = 630;
static integer c__28 = 28;
static integer c__631 = 631;
static integer c__44 = 44;
static integer c__640 = 640;
static integer c__57 = 57;
static integer c__641 = 641;
static integer c__650 = 650;
static integer c__651 = 651;
static integer c__40 = 40;
static integer c__652 = 652;
static integer c__655 = 655;
static integer c__46 = 46;
static integer c__656 = 656;
static integer c__660 = 660;
static integer c__661 = 661;
static integer c__670 = 670;
static integer c__671 = 671;
static integer c__672 = 672;
static integer c__675 = 675;
static integer c__51 = 51;
static integer c__676 = 676;
static integer c__677 = 677;
static integer c__680 = 680;
static integer c__36 = 36;
static integer c__681 = 681;
static integer c__685 = 685;
static integer c__686 = 686;
static integer c__690 = 690;
static integer c__35 = 35;
static integer c__691 = 691;
static integer c__695 = 695;
static integer c__50 = 50;
static integer c__696 = 696;
static integer c__25 = 25;
static integer c__34 = 34;
static integer c__3 = 3;
static integer c__60 = 60;
static integer c__39 = 39;
static integer c__6 = 6;
static integer c__7 = 7;
static integer c__8 = 8;
static integer c__54 = 54;
static integer c__10 = 10;
static integer c__11 = 11;
static integer c__29 = 29;
static integer c__12 = 12;
static integer c__13 = 13;
static integer c__14 = 14;
static integer c__15 = 15;
static integer c__52 = 52;
static integer c__17 = 17;
static integer c__18 = 18;
static integer c__19 = 19;
static integer c__20 = 20;
static integer c__21 = 21;
static integer c__22 = 22;
static integer c__58 = 58;
static integer c__23 = 23;
static integer c__24 = 24;
static integer c__26 = 26;
static integer c__27 = 27;
static integer c__701 = 701;
static integer c__702 = 702;
static integer c__901 = 901;
static integer c__902 = 902;
static integer c__903 = 903;
static integer c__904 = 904;
static integer c__43 = 43;
static integer c__905 = 905;
static integer c__42 = 42;
static integer c__906 = 906;
static integer c__921 = 921;
static integer c__922 = 922;
static integer c__923 = 923;
static integer c__924 = 924;
static integer c__925 = 925;
static integer c__926 = 926;

/* Subroutine */ int ddaspk_(U_fp res, integer *neq, doublereal *t, 
	doublereal *y, doublereal *yprime, doublereal *tout, integer *info, 
	doublereal *rtol, doublereal *atol, integer *idid, doublereal *rwork, 
	integer *lrw, integer *iwork, integer *liw, doublereal *rpar, integer 
	*ipar, U_fp jac, U_fp psol)
{
    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1, d__2;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
	    doublereal *, doublereal *);
    integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
	    e_wsle(void);

    /* Local variables */
    doublereal h__;
    integer i__;
    doublereal r__, h0;
    integer le;
    doublereal rh, tn;
    integer ici, idi;
    static integer lid;
    integer ier;
    char msg[80];
    integer lwm, lvt, lwt, nwt, nli0, nni0;
    logical lcfl, lcfn, done;
    doublereal rcfl;
    integer nnid;
    logical lavl;
    integer maxl, iret;
    doublereal hmax;
    integer lphi;
    doublereal hmin;
    integer lyic, lpwk, nstd;
    doublereal rcfn;
    integer ncfl0, ncfn0;
    extern /* Subroutine */ int dnedd_();
    integer mband;
    extern /* Subroutine */ int dnedk_();
    integer lenic;
    static integer lenid, ncphi;
    integer lenpd, lsoff, msave, index, itemp, leniw, nzflg;
    doublereal atoli;
    integer lypic;
    logical lwarn;
    doublereal avlin;
    integer lenwp, lenrw, mxord, nwarn;
    doublereal rtoli;
    integer lsavr;
    extern doublereal d1mach_(integer *);
    doublereal tdist, tnext, fmaxl;
    extern /* Subroutine */ int ddstp_(doublereal *, doublereal *, doublereal 
	    *, integer *, U_fp, U_fp, U_fp, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     integer *, integer *, integer *, integer *, integer *, integer *,
	     integer *, U_fp);
    doublereal tstop;
    extern /* Subroutine */ int dcnst0_(integer *, doublereal *, integer *, 
	    integer *), ddasic_(doublereal *, doublereal *, doublereal *, 
	    integer *, integer *, integer *, U_fp, U_fp, U_fp, doublereal *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, integer *
	    , doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *, integer *, integer *, U_fp)
	    ;
    extern /* Subroutine */ int ddasid_(), ddasik_();
    integer icnflg;
    doublereal tscale, epconi;
    extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    doublereal *);
    doublereal floatn;
    static integer nonneg;
    extern /* Subroutine */ int ddawts_(integer *, integer *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *)
	    ;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    integer leniwp;
    extern /* Subroutine */ int xerrwd_(char *, integer *, integer *, integer 
	    *, integer *, integer *, integer *, integer *, doublereal *, 
	    doublereal *, ftnlen), dinvwt_(integer *, doublereal *, integer *)
	    ;
    doublereal uround, ypnorm;

    /* Fortran I/O blocks */
    static cilist io___49 = { 0, 6, 0, 0, 0 };
    static cilist io___57 = { 0, 6, 0, 0, 0 };
    static cilist io___59 = { 0, 6, 0, 0, 0 };
    static cilist io___60 = { 0, 6, 0, 0, 0 };



/* ***BEGIN PROLOGUE  DDASPK */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  910624   (Added HMAX test at 525 in main driver.) */
/* ***REVISION DATE  920929   (CJ in RES call, RES counter fix.) */
/* ***REVISION DATE  921215   (Warnings on poor iteration performance) */
/* ***REVISION DATE  921216   (NRMAX as optional input) */
/* ***REVISION DATE  930315   (Name change: DDINI to DDINIT) */
/* ***REVISION DATE  940822   (Replaced initial condition calculation) */
/* ***REVISION DATE  941101   (Added linesearch in I.C. calculations) */
/* ***REVISION DATE  941220   (Misc. corrections throughout) */
/* ***REVISION DATE  950125   (Added DINVWT routine) */
/* ***REVISION DATE  950714   (Misc. corrections throughout) */
/* ***REVISION DATE  950802   (Default NRMAX = 5, based on tests.) */
/* ***REVISION DATE  950808   (Optional error test added.) */
/* ***REVISION DATE  950814   (Added I.C. constraints and INFO(14)) */
/* ***REVISION DATE  950828   (Various minor corrections.) */
/* ***REVISION DATE  951006   (Corrected WT scaling in DFNRMK.) */
/* ***REVISION DATE  951030   (Corrected history update at end of DDASTP.) */
/* ***REVISION DATE  960129   (Corrected RL bug in DLINSD, DLINSK.) */
/* ***REVISION DATE  960301   (Added NONNEG to SAVE statement.) */
/* ***REVISION DATE  000512   (Removed copyright notices.) */
/* ***REVISION DATE  000622   (Corrected LWM value using NCPHI.) */
/* ***REVISION DATE  000628   (Corrected I.C. stopping tests when index = 0.) */
/* ***REVISION DATE  000628   (Fixed alpha test in I.C. calc., Krylov case.) */
/* ***REVISION DATE  000628   (Improved restart in I.C. calc., Krylov case.) */
/* ***REVISION DATE  000628   (Minor corrections throughout.) */
/* ***REVISION DATE  000711   (Fixed Newton convergence test in DNSD, DNSK.) */
/* ***REVISION DATE  000712   (Fixed tests on TN - TOUT below 420 and 440.) */
/* ***CATEGORY NO.  I1A2 */
/* ***KEYWORDS  DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, */
/*             IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION */
/* ***AUTHORS   Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and */
/*                  Clement W. Ulrich */
/*             Center for Computational Sciences & Engineering, L-316 */
/*             Lawrence Livermore National Laboratory */
/*             P.O. Box 808, */
/*             Livermore, CA 94551 */
/* ***PURPOSE  This code solves a system of differential/algebraic */
/*            equations of the form */
/*               G(t,y,y') = 0 , */
/*            using a combination of Backward Differentiation Formula */
/*            (BDF) methods and a choice of two linear system solution */
/*            methods: direct (dense or band) or Krylov (iterative). */
/*            This version is in double precision. */
/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* *Usage: */

/*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
/*      INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) */
/*      DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), */
/*         RWORK(LRW), RPAR(*) */
/*      EXTERNAL  RES, JAC, PSOL */

/*      CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, */
/*     *   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) */

/*  Quantities which may be altered by the code are: */
/*     T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) */


/* *Arguments: */

/*  RES:EXT          This is the name of a subroutine which you */
/*                   provide to define the residual function G(t,y,y') */
/*                   of the differential/algebraic system. */

/*  NEQ:IN           This is the number of equations in the system. */

/*  T:INOUT          This is the current value of the independent */
/*                   variable. */

/*  Y(*):INOUT       This array contains the solution components at T. */

/*  YPRIME(*):INOUT  This array contains the derivatives of the solution */
/*                   components at T. */

/*  TOUT:IN          This is a point at which a solution is desired. */

/*  INFO(N):IN       This is an integer array used to communicate details */
/*                   of how the solution is to be carried out, such as */
/*                   tolerance type, matrix structure, step size and */
/*                   order limits, and choice of nonlinear system method. */
/*                   N must be at least 20. */

/*  RTOL,ATOL:INOUT  These quantities represent absolute and relative */
/*                   error tolerances (on local error) which you provide */
/*                   to indicate how accurately you wish the solution to */
/*                   be computed.  You may choose them to be both scalars */
/*                   or else both arrays of length NEQ. */

/*  IDID:OUT         This integer scalar is an indicator reporting what */
/*                   the code did.  You must monitor this variable to */
/*                   decide what action to take next. */

/*  RWORK:WORK       A real work array of length LRW which provides the */
/*                   code with needed storage space. */

/*  LRW:IN           The length of RWORK. */

/*  IWORK:WORK       An integer work array of length LIW which provides */
/*                   the code with needed storage space. */

/*  LIW:IN           The length of IWORK. */

/*  RPAR,IPAR:IN     These are real and integer parameter arrays which */
/*                   you can use for communication between your calling */
/*                   program and the RES, JAC, and PSOL subroutines. */

/*  JAC:EXT          This is the name of a subroutine which you may */
/*                   provide (optionally) for calculating Jacobian */
/*                   (partial derivative) data involved in solving linear */
/*                   systems within DDASPK. */

/*  PSOL:EXT         This is the name of a subroutine which you must */
/*                   provide for solving linear systems if you selected */
/*                   a Krylov method.  The purpose of PSOL is to solve */
/*                   linear systems involving a left preconditioner P. */

/* *Overview */

/*  The DDASPK solver uses the backward differentiation formulas of */
/*  orders one through five to solve a system of the form G(t,y,y') = 0 */
/*  for y = Y and y' = YPRIME.  Values for Y and YPRIME at the initial */
/*  time must be given as input.  These values should be consistent, */
/*  that is, if T, Y, YPRIME are the given initial values, they should */
/*  satisfy G(T,Y,YPRIME) = 0.  However, if consistent values are not */
/*  known, in many cases you can have DDASPK solve for them -- see INFO(11). */
/*  (This and other options are described in more detail below.) */

/*  Normally, DDASPK solves the system from T to TOUT.  It is easy to */
/*  continue the solution to get results at additional TOUT.  This is */
/*  the interval mode of operation.  Intermediate results can also be */
/*  obtained easily by specifying INFO(3). */

/*  On each step taken by DDASPK, a sequence of nonlinear algebraic */
/*  systems arises.  These are solved by one of two types of */
/*  methods: */
/*    * a Newton iteration with a direct method for the linear */
/*      systems involved (INFO(12) = 0), or */
/*    * a Newton iteration with a preconditioned Krylov iterative */
/*      method for the linear systems involved (INFO(12) = 1). */

/*  The direct method choices are dense and band matrix solvers, */
/*  with either a user-supplied or an internal difference quotient */
/*  Jacobian matrix, as specified by INFO(5) and INFO(6). */
/*  In the band case, INFO(6) = 1, you must supply half-bandwidths */
/*  in IWORK(1) and IWORK(2). */

/*  The Krylov method is the Generalized Minimum Residual (GMRES) */
/*  method, in either complete or incomplete form, and with */
/*  scaling and preconditioning.  The method is implemented */
/*  in an algorithm called SPIGMR.  Certain options in the Krylov */
/*  method case are specified by INFO(13) and INFO(15). */

/*  If the Krylov method is chosen, you may supply a pair of routines, */
/*  JAC and PSOL, to apply preconditioning to the linear system. */
/*  If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME */
/*  (of order NEQ).  This system can then be preconditioned in the form */
/*  (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. */
/*  (DDASPK does not allow right preconditioning.) */
/*  Then the Krylov method is applied to this altered, but equivalent, */
/*  linear system, hopefully with much better performance than without */
/*  preconditioning.  (In addition, a diagonal scaling matrix based on */
/*  the tolerances is also introduced into the altered system.) */

/*  The JAC routine evaluates any data needed for solving systems */
/*  with coefficient matrix P, and PSOL carries out that solution. */
/*  In any case, in order to improve convergence, you should try to */
/*  make P approximate the matrix A as much as possible, while keeping */
/*  the system P*x = b reasonably easy and inexpensive to solve for x, */
/*  given a vector b. */


/* *Description */

/* ------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- */


/*  The first call of the code is defined to be the start of each new */
/*  problem.  Read through the descriptions of all the following items, */
/*  provide sufficient storage space for designated arrays, set */
/*  appropriate variables for the initialization of the problem, and */
/*  give information about how you want the problem to be solved. */


/*  RES -- Provide a subroutine of the form */

/*             SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) */

/*         to define the system of differential/algebraic */
/*         equations which is to be solved. For the given values */
/*         of T, Y and YPRIME, the subroutine should return */
/*         the residual of the differential/algebraic system */
/*             DELTA = G(T,Y,YPRIME) */
/*         DELTA is a vector of length NEQ which is output from RES. */

/*         Subroutine RES must not alter T, Y, YPRIME, or CJ. */
/*         You must declare the name RES in an EXTERNAL */
/*         statement in your program that calls DDASPK. */
/*         You must dimension Y, YPRIME, and DELTA in RES. */

/*         The input argument CJ can be ignored, or used to rescale */
/*         constraint equations in the system (see Ref. 2, p. 145). */
/*         Note: In this respect, DDASPK is not downward-compatible */
/*         with DDASSL, which does not have the RES argument CJ. */

/*         IRES is an integer flag which is always equal to zero */
/*         on input.  Subroutine RES should alter IRES only if it */
/*         encounters an illegal value of Y or a stop condition. */
/*         Set IRES = -1 if an input value is illegal, and DDASPK */
/*         will try to solve the problem without getting IRES = -1. */
/*         If IRES = -2, DDASPK will return control to the calling */
/*         program with IDID = -11. */

/*         RPAR and IPAR are real and integer parameter arrays which */
/*         you can use for communication between your calling program */
/*         and subroutine RES. They are not altered by DDASPK. If you */
/*         do not need RPAR or IPAR, ignore these parameters by treat- */
/*         ing them as dummy arguments. If you do choose to use them, */
/*         dimension them in your calling program and in RES as arrays */
/*         of appropriate length. */

/*  NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). */

/*  T -- Set it to the initial point of the integration. (T must be */
/*       a variable.) */

/*  Y(*) -- Set this array to the initial values of the NEQ solution */
/*          components at the initial point.  You must dimension Y of */
/*          length at least NEQ in your calling program. */

/*  YPRIME(*) -- Set this array to the initial values of the NEQ first */
/*               derivatives of the solution components at the initial */
/*               point.  You must dimension YPRIME at least NEQ in your */
/*               calling program. */

/*  TOUT - Set it to the first point at which a solution is desired. */
/*         You cannot take TOUT = T.  Integration either forward in T */
/*         (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. */

/*         The code advances the solution from T to TOUT using step */
/*         sizes which are automatically selected so as to achieve the */
/*         desired accuracy.  If you wish, the code will return with the */
/*         solution and its derivative at intermediate steps (the */
/*         intermediate-output mode) so that you can monitor them, */
/*         but you still must provide TOUT in accord with the basic */
/*         aim of the code. */

/*         The first step taken by the code is a critical one because */
/*         it must reflect how fast the solution changes near the */
/*         initial point.  The code automatically selects an initial */
/*         step size which is practically always suitable for the */
/*         problem.  By using the fact that the code will not step past */
/*         TOUT in the first step, you could, if necessary, restrict the */
/*         length of the initial step. */

/*         For some problems it may not be permissible to integrate */
/*         past a point TSTOP, because a discontinuity occurs there */
/*         or the solution or its derivative is not defined beyond */
/*         TSTOP.  When you have declared a TSTOP point (see INFO(4) */
/*         and RWORK(1)), you have told the code not to integrate past */
/*         TSTOP.  In this case any tout beyond TSTOP is invalid input. */

/*  INFO(*) - Use the INFO array to give the code more details about */
/*            how you want your problem solved.  This array should be */
/*            dimensioned of length 20, though DDASPK uses only the */
/*            first 15 entries.  You must respond to all of the following */
/*            items, which are arranged as questions.  The simplest use */
/*            of DDASPK corresponds to setting all entries of INFO to 0. */

/*       INFO(1) - This parameter enables the code to initialize itself. */
/*              You must set it to indicate the start of every new */
/*              problem. */

/*          **** Is this the first call for this problem ... */
/*                yes - set INFO(1) = 0 */
/*                 no - not applicable here. */
/*                      See below for continuation calls.  **** */

/*       INFO(2) - How much accuracy you want of your solution */
/*              is specified by the error tolerances RTOL and ATOL. */
/*              The simplest use is to take them both to be scalars. */
/*              To obtain more flexibility, they can both be arrays. */
/*              The code must be told your choice. */

/*          **** Are both error tolerances RTOL, ATOL scalars ... */
/*                yes - set INFO(2) = 0 */
/*                      and input scalars for both RTOL and ATOL */
/*                 no - set INFO(2) = 1 */
/*                      and input arrays for both RTOL and ATOL **** */

/*       INFO(3) - The code integrates from T in the direction of TOUT */
/*              by steps.  If you wish, it will return the computed */
/*              solution and derivative at the next intermediate step */
/*              (the intermediate-output mode) or TOUT, whichever comes */
/*              first.  This is a good way to proceed if you want to */
/*              see the behavior of the solution.  If you must have */
/*              solutions at a great many specific TOUT points, this */
/*              code will compute them efficiently. */

/*          **** Do you want the solution only at */
/*               TOUT (and not at the next intermediate step) ... */
/*                yes - set INFO(3) = 0 */
/*                 no - set INFO(3) = 1 **** */

/*       INFO(4) - To handle solutions at a great many specific */
/*              values TOUT efficiently, this code may integrate past */
/*              TOUT and interpolate to obtain the result at TOUT. */
/*              Sometimes it is not possible to integrate beyond some */
/*              point TSTOP because the equation changes there or it is */
/*              not defined past TSTOP.  Then you must tell the code */
/*              this stop condition. */

/*           **** Can the integration be carried out without any */
/*                restrictions on the independent variable T ... */
/*                 yes - set INFO(4) = 0 */
/*                  no - set INFO(4) = 1 */
/*                       and define the stopping point TSTOP by */
/*                       setting RWORK(1) = TSTOP **** */

/*       INFO(5) - used only when INFO(12) = 0 (direct methods). */
/*              To solve differential/algebraic systems you may wish */
/*              to use a matrix of partial derivatives of the */
/*              system of differential equations.  If you do not */
/*              provide a subroutine to evaluate it analytically (see */
/*              description of the item JAC in the call list), it will */
/*              be approximated by numerical differencing in this code. */
/*              Although it is less trouble for you to have the code */
/*              compute partial derivatives by numerical differencing, */
/*              the solution will be more reliable if you provide the */
/*              derivatives via JAC.  Usually numerical differencing is */
/*              more costly than evaluating derivatives in JAC, but */
/*              sometimes it is not - this depends on your problem. */

/*           **** Do you want the code to evaluate the partial deriv- */
/*                atives automatically by numerical differences ... */
/*                 yes - set INFO(5) = 0 */
/*                  no - set INFO(5) = 1 */
/*                       and provide subroutine JAC for evaluating the */
/*                       matrix of partial derivatives **** */

/*       INFO(6) - used only when INFO(12) = 0 (direct methods). */
/*              DDASPK will perform much better if the matrix of */
/*              partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is */
/*              a scalar determined by DDASPK), is banded and the code */
/*              is told this.  In this case, the storage needed will be */
/*              greatly reduced, numerical differencing will be performed */
/*              much cheaper, and a number of important algorithms will */
/*              execute much faster.  The differential equation is said */
/*              to have half-bandwidths ML (lower) and MU (upper) if */
/*              equation i involves only unknowns Y(j) with */
/*                             i-ML .le. j .le. i+MU . */
/*              For all i=1,2,...,NEQ.  Thus, ML and MU are the widths */
/*              of the lower and upper parts of the band, respectively, */
/*              with the main diagonal being excluded.  If you do not */
/*              indicate that the equation has a banded matrix of partial */
/*              derivatives the code works with a full matrix of NEQ**2 */
/*              elements (stored in the conventional way).  Computations */
/*              with banded matrices cost less time and storage than with */
/*              full matrices if  2*ML+MU .lt. NEQ.  If you tell the */
/*              code that the matrix of partial derivatives has a banded */
/*              structure and you want to provide subroutine JAC to */
/*              compute the partial derivatives, then you must be careful */
/*              to store the elements of the matrix in the special form */
/*              indicated in the description of JAC. */

/*          **** Do you want to solve the problem using a full (dense) */
/*               matrix (and not a special banded structure) ... */
/*                yes - set INFO(6) = 0 */
/*                 no - set INFO(6) = 1 */
/*                       and provide the lower (ML) and upper (MU) */
/*                       bandwidths by setting */
/*                       IWORK(1)=ML */
/*                       IWORK(2)=MU **** */

/*       INFO(7) - You can specify a maximum (absolute value of) */
/*              stepsize, so that the code will avoid passing over very */
/*              large regions. */

/*          ****  Do you want the code to decide on its own the maximum */
/*                stepsize ... */
/*                 yes - set INFO(7) = 0 */
/*                  no - set INFO(7) = 1 */
/*                       and define HMAX by setting */
/*                       RWORK(2) = HMAX **** */

/*       INFO(8) -  Differential/algebraic problems may occasionally */
/*              suffer from severe scaling difficulties on the first */
/*              step.  If you know a great deal about the scaling of */
/*              your problem, you can help to alleviate this problem */
/*              by specifying an initial stepsize H0. */

/*          ****  Do you want the code to define its own initial */
/*                stepsize ... */
/*                 yes - set INFO(8) = 0 */
/*                  no - set INFO(8) = 1 */
/*                       and define H0 by setting */
/*                       RWORK(3) = H0 **** */

/*       INFO(9) -  If storage is a severe problem, you can save some */
/*              storage by restricting the maximum method order MAXORD. */
/*              The default value is 5.  For each order decrease below 5, */
/*              the code requires NEQ fewer locations, but it is likely */
/*              to be slower.  In any case, you must have */
/*              1 .le. MAXORD .le. 5. */
/*          ****  Do you want the maximum order to default to 5 ... */
/*                 yes - set INFO(9) = 0 */
/*                  no - set INFO(9) = 1 */
/*                       and define MAXORD by setting */
/*                       IWORK(3) = MAXORD **** */

/*       INFO(10) - If you know that certain components of the */
/*              solutions to your equations are always nonnegative */
/*              (or nonpositive), it may help to set this */
/*              parameter.  There are three options that are */
/*              available: */
/*              1.  To have constraint checking only in the initial */
/*                  condition calculation. */
/*              2.  To enforce nonnegativity in Y during the integration. */
/*              3.  To enforce both options 1 and 2. */

/*              When selecting option 2 or 3, it is probably best to try the */
/*              code without using this option first, and only use */
/*              this option if that does not work very well. */

/*          ****  Do you want the code to solve the problem without */
/*                invoking any special inequality constraints ... */
/*                 yes - set INFO(10) = 0 */
/*                  no - set INFO(10) = 1 to have option 1 enforced */
/*                  no - set INFO(10) = 2 to have option 2 enforced */
/*                  no - set INFO(10) = 3 to have option 3 enforced **** */

/*                  If you have specified INFO(10) = 1 or 3, then you */
/*                  will also need to identify how each component of Y */
/*                  in the initial condition calculation is constrained. */
/*                  You must set: */
/*                  IWORK(40+I) = +1 if Y(I) must be .GE. 0, */
/*                  IWORK(40+I) = +2 if Y(I) must be .GT. 0, */
/*                  IWORK(40+I) = -1 if Y(I) must be .LE. 0, while */
/*                  IWORK(40+I) = -2 if Y(I) must be .LT. 0, while */
/*                  IWORK(40+I) =  0 if Y(I) is not constrained. */

/*       INFO(11) - DDASPK normally requires the initial T, Y, and */
/*              YPRIME to be consistent.  That is, you must have */
/*              G(T,Y,YPRIME) = 0 at the initial T.  If you do not know */
/*              the initial conditions precisely, in some cases */
/*              DDASPK may be able to compute it. */

/*              Denoting the differential variables in Y by Y_d */
/*              and the algebraic variables by Y_a, DDASPK can solve */
/*              one of two initialization problems: */
/*              1.  Given Y_d, calculate Y_a and Y'_d, or */
/*              2.  Given Y', calculate Y. */
/*              In either case, initial values for the given */
/*              components are input, and initial guesses for */
/*              the unknown components must also be provided as input. */

/*          ****  Are the initial T, Y, YPRIME consistent ... */

/*                 yes - set INFO(11) = 0 */
/*                  no - set INFO(11) = 1 to calculate option 1 above, */
/*                    or set INFO(11) = 2 to calculate option 2 **** */

/*                  If you have specified INFO(11) = 1, then you */
/*                  will also need to identify  which are the */
/*                  differential and which are the algebraic */
/*                  components (algebraic components are components */
/*                  whose derivatives do not appear explicitly */
/*                  in the function G(T,Y,YPRIME)).  You must set: */
/*                  IWORK(LID+I) = +1 if Y(I) is a differential variable */
/*                  IWORK(LID+I) = -1 if Y(I) is an algebraic variable, */
/*                  where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ */
/*                  if INFO(10) = 1 or 3. */

/*       INFO(12) - Except for the addition of the RES argument CJ, */
/*              DDASPK by default is downward-compatible with DDASSL, */
/*              which uses only direct (dense or band) methods to solve */
/*              the linear systems involved.  You must set INFO(12) to */
/*              indicate whether you want the direct methods or the */
/*              Krylov iterative method. */
/*          ****   Do you want DDASPK to use standard direct methods */
/*                 (dense or band) or the Krylov (iterative) method ... */
/*                   direct methods - set INFO(12) = 0. */
/*                   Krylov method  - set INFO(12) = 1, */
/*                       and check the settings of INFO(13) and INFO(15). */

/*       INFO(13) - used when INFO(12) = 1 (Krylov methods). */
/*              DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the */
/*              iterative solution of linear systems.  INFO(13) allows */
/*              you to override the default values of these parameters. */
/*              These parameters and their defaults are as follows: */
/*              MAXL = maximum number of iterations in the SPIGMR */
/*                 algorithm (MAXL .le. NEQ).  The default is */
/*                 MAXL = MIN(5,NEQ). */
/*              KMP = number of vectors on which orthogonalization is */
/*                 done in the SPIGMR algorithm.  The default is */
/*                 KMP = MAXL, which corresponds to complete GMRES */
/*                 iteration, as opposed to the incomplete form. */
/*              NRMAX = maximum number of restarts of the SPIGMR */
/*                 algorithm per nonlinear iteration.  The default is */
/*                 NRMAX = 5. */
/*              EPLI = convergence test constant in SPIGMR algorithm. */
/*                 The default is EPLI = 0.05. */
/*              Note that the length of RWORK depends on both MAXL */
/*              and KMP.  See the definition of LRW below. */
/*          ****   Are MAXL, KMP, and EPLI to be given their */
/*                 default values ... */
/*                  yes - set INFO(13) = 0 */
/*                   no - set INFO(13) = 1, */
/*                        and set all of the following: */
/*                        IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) */
/*                        IWORK(25) = KMP  (1 .le. KMP .le. MAXL) */
/*                        IWORK(26) = NRMAX  (NRMAX .ge. 0) */
/*                        RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** */

/*        INFO(14) - used with INFO(11) > 0 (initial condition */
/*               calculation is requested).  In this case, you may */
/*               request control to be returned to the calling program */
/*               immediately after the initial condition calculation, */
/*               before proceeding to the integration of the system */
/*               (e.g. to examine the computed Y and YPRIME). */
/*               If this is done, and if the initialization succeeded */
/*               (IDID = 4), you should reset INFO(11) to 0 for the */
/*               next call, to prevent the solver from repeating the */
/*               initialization (and to avoid an infinite loop). */
/*          ****   Do you want to proceed to the integration after */
/*                 the initial condition calculation is done ... */
/*                 yes - set INFO(14) = 0 */
/*                  no - set INFO(14) = 1                        **** */

/*        INFO(15) - used when INFO(12) = 1 (Krylov methods). */
/*               When using preconditioning in the Krylov method, */
/*               you must supply a subroutine, PSOL, which solves the */
/*               associated linear systems using P. */
/*               The usage of DDASPK is simpler if PSOL can carry out */
/*               the solution without any prior calculation of data. */
/*               However, if some partial derivative data is to be */
/*               calculated in advance and used repeatedly in PSOL, */
/*               then you must supply a JAC routine to do this, */
/*               and set INFO(15) to indicate that JAC is to be called */
/*               for this purpose.  For example, P might be an */
/*               approximation to a part of the matrix A which can be */
/*               calculated and LU-factored for repeated solutions of */
/*               the preconditioner system.  The arrays WP and IWP */
/*               (described under JAC and PSOL) can be used to */
/*               communicate data between JAC and PSOL. */
/*          ****   Does PSOL operate with no prior preparation ... */
/*                 yes - set INFO(15) = 0 (no JAC routine) */
/*                  no - set INFO(15) = 1 */
/*                       and supply a JAC routine to evaluate and */
/*                       preprocess any required Jacobian data.  **** */

/*         INFO(16) - option to exclude algebraic variables from */
/*               the error test. */
/*          ****   Do you wish to control errors locally on */
/*                 all the variables... */
/*                 yes - set INFO(16) = 0 */
/*                  no - set INFO(16) = 1 */
/*                       If you have specified INFO(16) = 1, then you */
/*                       will also need to identify  which are the */
/*                       differential and which are the algebraic */
/*                       components (algebraic components are components */
/*                       whose derivatives do not appear explicitly */
/*                       in the function G(T,Y,YPRIME)).  You must set: */
/*                       IWORK(LID+I) = +1 if Y(I) is a differential */
/*                                      variable, and */
/*                       IWORK(LID+I) = -1 if Y(I) is an algebraic */
/*                                      variable, */
/*                       where LID = 40 if INFO(10) = 0 or 2 and */
/*                       LID = 40 + NEQ if INFO(10) = 1 or 3. */

/*       INFO(17) - used when INFO(11) > 0 (DDASPK is to do an */
/*              initial condition calculation). */
/*              DDASPK uses several heuristic control quantities in the */
/*              initial condition calculation.  They have default values, */
/*              but can  also be set by the user using INFO(17). */
/*              These parameters and their defaults are as follows: */
/*              MXNIT  = maximum number of Newton iterations */
/*                 per Jacobian or preconditioner evaluation. */
/*                 The default is: */
/*                 MXNIT =  5 in the direct case (INFO(12) = 0), and */
/*                 MXNIT = 15 in the Krylov case (INFO(12) = 1). */
/*              MXNJ   = maximum number of Jacobian or preconditioner */
/*                 evaluations.  The default is: */
/*                 MXNJ = 6 in the direct case (INFO(12) = 0), and */
/*                 MXNJ = 2 in the Krylov case (INFO(12) = 1). */
/*              MXNH   = maximum number of values of the artificial */
/*                 stepsize parameter H to be tried if INFO(11) = 1. */
/*                 The default is MXNH = 5. */
/*                 NOTE: the maximum number of Newton iterations */
/*                 allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, */
/*                 and MXNIT*MXNJ if INFO(11) = 2. */
/*              LSOFF  = flag to turn off the linesearch algorithm */
/*                 (LSOFF = 0 means linesearch is on, LSOFF = 1 means */
/*                 it is turned off).  The default is LSOFF = 0. */
/*              STPTOL = minimum scaled step in linesearch algorithm. */
/*                 The default is STPTOL = (unit roundoff)**(2/3). */
/*              EPINIT = swing factor in the Newton iteration convergence */
/*                 test.  The test is applied to the residual vector, */
/*                 premultiplied by the approximate Jacobian (in the */
/*                 direct case) or the preconditioner (in the Krylov */
/*                 case).  For convergence, the weighted RMS norm of */
/*                 this vector (scaled by the error weights) must be */
/*                 less than EPINIT*EPCON, where EPCON = .33 is the */
/*                 analogous test constant used in the time steps. */
/*                 The default is EPINIT = .01. */
/*          ****   Are the initial condition heuristic controls to be */
/*                 given their default values... */
/*                  yes - set INFO(17) = 0 */
/*                   no - set INFO(17) = 1, */
/*                        and set all of the following: */
/*                        IWORK(32) = MXNIT (.GT. 0) */
/*                        IWORK(33) = MXNJ (.GT. 0) */
/*                        IWORK(34) = MXNH (.GT. 0) */
/*                        IWORK(35) = LSOFF ( = 0 or 1) */
/*                        RWORK(14) = STPTOL (.GT. 0.0) */
/*                        RWORK(15) = EPINIT (.GT. 0.0)  **** */

/*         INFO(18) - option to get extra printing in initial condition */
/*                calculation. */
/*          ****   Do you wish to have extra printing... */
/*                 no  - set INFO(18) = 0 */
/*                 yes - set INFO(18) = 1 for minimal printing, or */
/*                       set INFO(18) = 2 for full printing. */
/*                       If you have specified INFO(18) .ge. 1, data */
/*                       will be printed with the error handler routines. */
/*                       To print to a non-default unit number L, include */
/*                       the line  CALL XSETUN(L)  in your program.  **** */

/*   RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) */
/*               error tolerances to tell the code how accurately you */
/*               want the solution to be computed.  They must be defined */
/*               as variables because the code may change them. */
/*               you have two choices -- */
/*                     Both RTOL and ATOL are scalars (INFO(2) = 0), or */
/*                     both RTOL and ATOL are vectors (INFO(2) = 1). */
/*               In either case all components must be non-negative. */

/*               The tolerances are used by the code in a local error */
/*               test at each step which requires roughly that */
/*                        abs(local error in Y(i)) .le. EWT(i) , */
/*               where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight */
/*               quantity, for each vector component. */
/*               (More specifically, a root-mean-square norm is used to */
/*               measure the size of vectors, and the error test uses the */
/*               magnitude of the solution at the beginning of the step.) */

/*               The true (global) error is the difference between the */
/*               true solution of the initial value problem and the */
/*               computed approximation.  Practically all present day */
/*               codes, including this one, control the local error at */
/*               each step and do not even attempt to control the global */
/*               error directly. */

/*               Usually, but not always, the true accuracy of */
/*               the computed Y is comparable to the error tolerances. */
/*               This code will usually, but not always, deliver a more */
/*               accurate solution if you reduce the tolerances and */
/*               integrate again.  By comparing two such solutions you */
/*               can get a fairly reliable idea of the true error in the */
/*               solution at the larger tolerances. */

/*               Setting ATOL = 0. results in a pure relative error test */
/*               on that component.  Setting RTOL = 0. results in a pure */
/*               absolute error test on that component.  A mixed test */
/*               with non-zero RTOL and ATOL corresponds roughly to a */
/*               relative error test when the solution component is */
/*               much bigger than ATOL and to an absolute error test */
/*               when the solution component is smaller than the */
/*               threshold ATOL. */

/*               The code will not attempt to compute a solution at an */
/*               accuracy unreasonable for the machine being used.  It */
/*               will advise you if you ask for too much accuracy and */
/*               inform you as to the maximum accuracy it believes */
/*               possible. */

/*  RWORK(*) -- a real work array, which should be dimensioned in your */
/*               calling program with a length equal to the value of */
/*               LRW (or greater). */

/*  LRW -- Set it to the declared length of the RWORK array.  The */
/*               minimum length depends on the options you have selected, */
/*               given by a base value plus additional storage as described */
/*               below. */

/*               If INFO(12) = 0 (standard direct method), the base value is */
/*               base = 50 + max(MAXORD+4,7)*NEQ. */
/*               The default value is MAXORD = 5 (see INFO(9)).  With the */
/*               default MAXORD, base = 50 + 9*NEQ. */
/*               Additional storage must be added to the base value for */
/*               any or all of the following options: */
/*                 if INFO(6) = 0 (dense matrix), add NEQ**2 */
/*                 if INFO(6) = 1 (banded matrix), then */
/*                    if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), */
/*                    if INFO(5) = 1, add (2*ML+MU+1)*NEQ, */
/*                 if INFO(16) = 1, add NEQ. */

/*              If INFO(12) = 1 (Krylov method), the base value is */
/*              base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + */
/*                      + (MAXL+3)*MAXL + 1 + LENWP. */
/*              See PSOL for description of LENWP.  The default values are: */
/*              MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL */
/*              (see INFO(13)). */
/*              With the default values for MAXORD, MAXL and KMP, */
/*              base = 91 + 18*NEQ + LENWP. */
/*              Additional storage must be added to the base value for */
/*              any or all of the following options: */
/*                if INFO(16) = 1, add NEQ. */


/*  IWORK(*) -- an integer work array, which should be dimensioned in */
/*              your calling program with a length equal to the value */
/*              of LIW (or greater). */

/*  LIW -- Set it to the declared length of the IWORK array.  The */
/*             minimum length depends on the options you have selected, */
/*             given by a base value plus additional storage as described */
/*             below. */

/*             If INFO(12) = 0 (standard direct method), the base value is */
/*             base = 40 + NEQ. */
/*             IF INFO(10) = 1 or 3, add NEQ to the base value. */
/*             If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. */

/*             If INFO(12) = 1 (Krylov method), the base value is */
/*             base = 40 + LENIWP. */
/*             See PSOL for description of LENIWP. */
/*             IF INFO(10) = 1 or 3, add NEQ to the base value. */
/*             If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. */


/*  RPAR, IPAR -- These are arrays of double precision and integer type, */
/*             respectively, which are available for you to use */
/*             for communication between your program that calls */
/*             DDASPK and the RES subroutine (and the JAC and PSOL */
/*             subroutines).  They are not altered by DDASPK. */
/*             If you do not need RPAR or IPAR, ignore these */
/*             parameters by treating them as dummy arguments. */
/*             If you do choose to use them, dimension them in */
/*             your calling program and in RES (and in JAC and PSOL) */
/*             as arrays of appropriate length. */

/*  JAC -- This is the name of a routine that you may supply */
/*         (optionally) that relates to the Jacobian matrix of the */
/*         nonlinear system that the code must solve at each T step. */
/*         The role of JAC (and its call sequence) depends on whether */
/*         a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method */
/*         is selected. */

/*         **** INFO(12) = 0 (direct methods): */
/*           If you are letting the code generate partial derivatives */
/*           numerically (INFO(5) = 0), then JAC can be absent */
/*           (or perhaps a dummy routine to satisfy the loader). */
/*           Otherwise you must supply a JAC routine to compute */
/*           the matrix A = dG/dY + CJ*dG/dYPRIME.  It must have */
/*           the form */

/*           SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) */

/*           The JAC routine must dimension Y, YPRIME, and PD (and RPAR */
/*           and IPAR if used).  CJ is a scalar which is input to JAC. */
/*           For the given values of T, Y, and YPRIME, the JAC routine */
/*           must evaluate the nonzero elements of the matrix A, and */
/*           store these values in the array PD.  The elements of PD are */
/*           set to zero before each call to JAC, so that only nonzero */
/*           elements need to be defined. */
/*           The way you store the elements into the PD array depends */
/*           on the structure of the matrix indicated by INFO(6). */
/*           *** INFO(6) = 0 (full or dense matrix) *** */
/*               Give PD a first dimension of NEQ.  When you evaluate the */
/*               nonzero partial derivatives of equation i (i.e. of G(i)) */
/*               with respect to component j (of Y and YPRIME), you must */
/*               store the element in PD according to */
/*                  PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). */
/*           *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU */
/*                            as described under INFO(6)) *** */
/*               Give PD a first dimension of 2*ML+MU+1.  When you */
/*               evaluate the nonzero partial derivatives of equation i */
/*               (i.e. of G(i)) with respect to component j (of Y and */
/*               YPRIME), you must store the element in PD according to */
/*                  IROW = i - j + ML + MU + 1 */
/*                  PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). */

/*          **** INFO(12) = 1 (Krylov method): */
/*            If you are not calculating Jacobian data in advance for use */
/*            in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a */
/*            dummy routine to satisfy the loader).  Otherwise, you may */
/*            supply a JAC routine to compute and preprocess any parts of */
/*            of the Jacobian matrix  A = dG/dY + CJ*dG/dYPRIME that are */
/*            involved in the preconditioner matrix P. */
/*            It is to have the form */

/*            SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, */
/*                            WK, H, CJ, WP, IWP, IER, RPAR, IPAR) */

/*           The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, */
/*           and (if used) WP, IWP, RPAR, and IPAR. */
/*           The Y, YPRIME, and SAVR arrays contain the current values */
/*           of Y, YPRIME, and the residual G, respectively. */
/*           The array WK is work space of length NEQ. */
/*           H is the step size.  CJ is a scalar, input to JAC, that is */
/*           normally proportional to 1/H.  REWT is an array of */
/*           reciprocal error weights, 1/EWT(i), where EWT(i) is */
/*           RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS */
/*           instead), for use in JAC if needed.  For example, if JAC */
/*           computes difference quotient approximations to partial */
/*           derivatives, the REWT array may be useful in setting the */
/*           increments used.  The JAC routine should do any */
/*           factorization operations called for, in preparation for */
/*           solving linear systems in PSOL.  The matrix P should */
/*           be an approximation to the Jacobian, */
/*           A = dG/dY + CJ*dG/dYPRIME. */

/*           WP and IWP are real and integer work arrays which you may */
/*           use for communication between your JAC routine and your */
/*           PSOL routine.  These may be used to store elements of the */
/*           preconditioner P, or related matrix data (such as factored */
/*           forms).  They are not altered by DDASPK. */
/*           If you do not need WP or IWP, ignore these parameters by */
/*           treating them as dummy arguments.  If you do use them, */
/*           dimension them appropriately in your JAC and PSOL routines. */
/*           See the PSOL description for instructions on setting */
/*           the lengths of WP and IWP. */

/*           On return, JAC should set the error flag IER as follows.. */
/*             IER = 0    if JAC was successful, */
/*             IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME */
/*                        was illegal, or a singular matrix is found). */
/*           (If IER .ne. 0, a smaller stepsize will be tried.) */
/*           IER = 0 on entry to JAC, so need be reset only on a failure. */
/*           If RES is used within JAC, then a nonzero value of IRES will */
/*           override any nonzero value of IER (see the RES description). */

/*         Regardless of the method type, subroutine JAC must not */
/*         alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). */
/*         You must declare the name JAC in an EXTERNAL statement in */
/*         your program that calls DDASPK. */

/* PSOL --  This is the name of a routine you must supply if you have */
/*         selected a Krylov method (INFO(12) = 1) with preconditioning. */
/*         In the direct case (INFO(12) = 0), PSOL can be absent */
/*         (a dummy routine may have to be supplied to satisfy the */
/*         loader).  Otherwise, you must provide a PSOL routine to */
/*         solve linear systems arising from preconditioning. */
/*         When supplied with INFO(12) = 1, the PSOL routine is to */
/*         have the form */

/*         SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, */
/*                          WP, IWP, B, EPLIN, IER, RPAR, IPAR) */

/*         The PSOL routine must solve linear systems of the form */
/*         P*x = b where P is the left preconditioner matrix. */

/*         The right-hand side vector b is in the B array on input, and */
/*         PSOL must return the solution vector x in B. */
/*         The Y, YPRIME, and SAVR arrays contain the current values */
/*         of Y, YPRIME, and the residual G, respectively. */

/*         Work space required by JAC and/or PSOL, and space for data to */
/*         be communicated from JAC to PSOL is made available in the form */
/*         of arrays WP and IWP, which are parts of the RWORK and IWORK */
/*         arrays, respectively.  The lengths of these real and integer */
/*         work spaces WP and IWP must be supplied in LENWP and LENIWP, */
/*         respectively, as follows.. */
/*           IWORK(27) = LENWP = length of real work space WP */
/*           IWORK(28) = LENIWP = length of integer work space IWP. */

/*         WK is a work array of length NEQ for use by PSOL. */
/*         CJ is a scalar, input to PSOL, that is normally proportional */
/*         to 1/H (H = stepsize).  If the old value of CJ */
/*         (at the time of the last JAC call) is needed, it must have */
/*         been saved by JAC in WP. */

/*         WGHT is an array of weights, to be used if PSOL uses an */
/*         iterative method and performs a convergence test.  (In terms */
/*         of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) */
/*         If PSOL uses an iterative method, it should use EPLIN */
/*         (a heuristic parameter) as the bound on the weighted norm of */
/*         the residual for the computed solution.  Specifically, the */
/*         residual vector R should satisfy */
/*              SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN */

/*         PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. */

/*         On return, PSOL should set the error flag IER as follows.. */
/*           IER = 0 if PSOL was successful, */
/*           IER .lt. 0 if an unrecoverable error occurred, meaning */
/*                 control will be passed to the calling routine, */
/*           IER .gt. 0 if a recoverable error occurred, meaning that */
/*                 the step will be retried with the same step size */
/*                 but with a call to JAC to update necessary data, */
/*                 unless the Jacobian data is current, in which case */
/*                 the step will be retried with a smaller step size. */
/*           IER = 0 on entry to PSOL so need be reset only on a failure. */

/*         You must declare the name PSOL in an EXTERNAL statement in */
/*         your program that calls DDASPK. */


/*  OPTIONALLY REPLACEABLE SUBROUTINE: */

/*  DDASPK uses a weighted root-mean-square norm to measure the */
/*  size of various error vectors.  The weights used in this norm */
/*  are set in the following subroutine: */

/*    SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) */
/*    DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) */

/*  A DDAWTS routine has been included with DDASPK which sets the */
/*  weights according to */
/*    EWT(I) = RTOL*ABS(Y(I)) + ATOL */
/*  in the case of scalar tolerances (IWT = 0) or */
/*    EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) */
/*  in the case of array tolerances (IWT = 1).  (IWT is INFO(2).) */
/*  In some special cases, it may be appropriate for you to define */
/*  your own error weights by writing a subroutine DDAWTS to be */
/*  called instead of the version supplied.  However, this should */
/*  be attempted only after careful thought and consideration. */
/*  If you supply this routine, you may use the tolerances and Y */
/*  as appropriate, but do not overwrite these variables.  You */
/*  may also use RPAR and IPAR to communicate data as appropriate. */
/*  ***Note: Aside from the values of the weights, the choice of */
/*  norm used in DDASPK (weighted root-mean-square) is not subject */
/*  to replacement by the user.  In this respect, DDASPK is not */
/*  downward-compatible with the original DDASSL solver (in which */
/*  the norm routine was optionally user-replaceable). */


/* ------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- */

/*  The principal aim of the code is to return a computed solution at */
/*  T = TOUT, although it is also possible to obtain intermediate */
/*  results along the way.  To find out whether the code achieved its */
/*  goal or if the integration process was interrupted before the task */
/*  was completed, you must check the IDID parameter. */


/*   T -- The output value of T is the point to which the solution */
/*        was successfully advanced. */

/*   Y(*) -- contains the computed solution approximation at T. */

/*   YPRIME(*) -- contains the computed derivative approximation at T. */

/*   IDID -- reports what the code did, described as follows: */

/*                     *** TASK COMPLETED *** */
/*                Reported by positive values of IDID */

/*           IDID = 1 -- a step was successfully taken in the */
/*                   intermediate-output mode.  The code has not */
/*                   yet reached TOUT. */

/*           IDID = 2 -- the integration to TSTOP was successfully */
/*                   completed (T = TSTOP) by stepping exactly to TSTOP. */

/*           IDID = 3 -- the integration to TOUT was successfully */
/*                   completed (T = TOUT) by stepping past TOUT. */
/*                   Y(*) and YPRIME(*) are obtained by interpolation. */

/*           IDID = 4 -- the initial condition calculation, with */
/*                   INFO(11) > 0, was successful, and INFO(14) = 1. */
/*                   No integration steps were taken, and the solution */
/*                   is not considered to have been started. */

/*                    *** TASK INTERRUPTED *** */
/*                Reported by negative values of IDID */

/*           IDID = -1 -- a large amount of work has been expended */
/*                     (about 500 steps). */

/*           IDID = -2 -- the error tolerances are too stringent. */

/*           IDID = -3 -- the local error test cannot be satisfied */
/*                     because you specified a zero component in ATOL */
/*                     and the corresponding computed solution component */
/*                     is zero.  Thus, a pure relative error test is */
/*                     impossible for this component. */

/*           IDID = -5 -- there were repeated failures in the evaluation */
/*                     or processing of the preconditioner (in JAC). */

/*           IDID = -6 -- DDASPK had repeated error test failures on the */
/*                     last attempted step. */

/*           IDID = -7 -- the nonlinear system solver in the time integration */
/*                     could not converge. */

/*           IDID = -8 -- the matrix of partial derivatives appears */
/*                     to be singular (direct method). */

/*           IDID = -9 -- the nonlinear system solver in the time integration */
/*                     failed to achieve convergence, and there were repeated */
/*                     error test failures in this step. */

/*           IDID =-10 -- the nonlinear system solver in the time integration */
/*                     failed to achieve convergence because IRES was equal */
/*                     to -1. */

/*           IDID =-11 -- IRES = -2 was encountered and control is */
/*                     being returned to the calling program. */

/*           IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. */

/*           IDID =-13 -- unrecoverable error encountered inside user's */
/*                     PSOL routine, and control is being returned to */
/*                     the calling program. */

/*           IDID =-14 -- the Krylov linear system solver could not */
/*                     achieve convergence. */

/*           IDID =-15,..,-32 -- Not applicable for this code. */

/*                    *** TASK TERMINATED *** */
/*                reported by the value of IDID=-33 */

/*           IDID = -33 -- the code has encountered trouble from which */
/*                   it cannot recover.  A message is printed */
/*                   explaining the trouble and control is returned */
/*                   to the calling program.  For example, this occurs */
/*                   when invalid input is detected. */

/*   RTOL, ATOL -- these quantities remain unchanged except when */
/*               IDID = -2.  In this case, the error tolerances have been */
/*               increased by the code to values which are estimated to */
/*               be appropriate for continuing the integration.  However, */
/*               the reported solution at T was obtained using the input */
/*               values of RTOL and ATOL. */

/*   RWORK, IWORK -- contain information which is usually of no interest */
/*               to the user but necessary for subsequent calls. */
/*               However, you may be interested in the performance data */
/*               listed below.  These quantities are accessed in RWORK */
/*               and IWORK but have internal mnemonic names, as follows.. */

/*               RWORK(3)--contains H, the step size h to be attempted */
/*                        on the next step. */

/*               RWORK(4)--contains TN, the current value of the */
/*                        independent variable, i.e. the farthest point */
/*                        integration has reached.  This will differ */
/*                        from T if interpolation has been performed */
/*                        (IDID = 3). */

/*               RWORK(7)--contains HOLD, the stepsize used on the last */
/*                        successful step.  If INFO(11) = INFO(14) = 1, */
/*                        this contains the value of H used in the */
/*                        initial condition calculation. */

/*               IWORK(7)--contains K, the order of the method to be */
/*                        attempted on the next step. */

/*               IWORK(8)--contains KOLD, the order of the method used */
/*                        on the last step. */

/*               IWORK(11)--contains NST, the number of steps (in T) */
/*                        taken so far. */

/*               IWORK(12)--contains NRE, the number of calls to RES */
/*                        so far. */

/*               IWORK(13)--contains NJE, the number of calls to JAC so */
/*                        far (Jacobian or preconditioner evaluations). */

/*               IWORK(14)--contains NETF, the total number of error test */
/*                        failures so far. */

/*               IWORK(15)--contains NCFN, the total number of nonlinear */
/*                        convergence failures so far (includes counts */
/*                        of singular iteration matrix or singular */
/*                        preconditioners). */

/*               IWORK(16)--contains NCFL, the number of convergence */
/*                        failures of the linear iteration so far. */

/*               IWORK(17)--contains LENIW, the length of IWORK actually */
/*                        required.  This is defined on normal returns */
/*                        and on an illegal input return for */
/*                        insufficient storage. */

/*               IWORK(18)--contains LENRW, the length of RWORK actually */
/*                        required.  This is defined on normal returns */
/*                        and on an illegal input return for */
/*                        insufficient storage. */

/*               IWORK(19)--contains NNI, the total number of nonlinear */
/*                        iterations so far (each of which calls a */
/*                        linear solver). */

/*               IWORK(20)--contains NLI, the total number of linear */
/*                        (Krylov) iterations so far. */

/*               IWORK(21)--contains NPS, the number of PSOL calls so */
/*                        far, for preconditioning solve operations or */
/*                        for solutions with the user-supplied method. */

/*               Note: The various counters in IWORK do not include */
/*               counts during a call made with INFO(11) > 0 and */
/*               INFO(14) = 1. */


/* ------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION  ----------------- */
/*              (CALLS AFTER THE FIRST) */

/*     This code is organized so that subsequent calls to continue the */
/*     integration involve little (if any) additional effort on your */
/*     part.  You must monitor the IDID parameter in order to determine */
/*     what to do next. */

/*     Recalling that the principal task of the code is to integrate */
/*     from T to TOUT (the interval mode), usually all you will need */
/*     to do is specify a new TOUT upon reaching the current TOUT. */

/*     Do not alter any quantity not specifically permitted below.  In */
/*     particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), */
/*     IWORK(*), or the differential equation in subroutine RES.  Any */
/*     such alteration constitutes a new problem and must be treated */
/*     as such, i.e. you must start afresh. */

/*     You cannot change from array to scalar error control or vice */
/*     versa (INFO(2)), but you can change the size of the entries of */
/*     RTOL or ATOL.  Increasing a tolerance makes the equation easier */
/*     to integrate.  Decreasing a tolerance will make the equation */
/*     harder to integrate and should generally be avoided. */

/*     You can switch from the intermediate-output mode to the */
/*     interval mode (INFO(3)) or vice versa at any time. */

/*     If it has been necessary to prevent the integration from going */
/*     past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the */
/*     code will not integrate to any TOUT beyond the currently */
/*     specified TSTOP.  Once TSTOP has been reached, you must change */
/*     the value of TSTOP or set INFO(4) = 0.  You may change INFO(4) */
/*     or TSTOP at any time but you must supply the value of TSTOP in */
/*     RWORK(1) whenever you set INFO(4) = 1. */

/*     Do not change INFO(5), INFO(6), INFO(12-17) or their associated */
/*     IWORK/RWORK locations unless you are going to restart the code. */

/*                    *** FOLLOWING A COMPLETED TASK *** */

/*     If.. */
/*     IDID = 1, call the code again to continue the integration */
/*                  another step in the direction of TOUT. */

/*     IDID = 2 or 3, define a new TOUT and call the code again. */
/*                  TOUT must be different from T.  You cannot change */
/*                  the direction of integration without restarting. */

/*     IDID = 4, reset INFO(11) = 0 and call the code again to begin */
/*                  the integration.  (If you leave INFO(11) > 0 and */
/*                  INFO(14) = 1, you may generate an infinite loop.) */
/*                  In this situation, the next call to DASPK is */
/*                  considered to be the first call for the problem, */
/*                  in that all initializations are done. */

/*                    *** FOLLOWING AN INTERRUPTED TASK *** */

/*     To show the code that you realize the task was interrupted and */
/*     that you want to continue, you must take appropriate action and */
/*     set INFO(1) = 1. */

/*     If.. */
/*     IDID = -1, the code has taken about 500 steps.  If you want to */
/*                  continue, set INFO(1) = 1 and call the code again. */
/*                  An additional 500 steps will be allowed. */


/*     IDID = -2, the error tolerances RTOL, ATOL have been increased */
/*                  to values the code estimates appropriate for */
/*                  continuing.  You may want to change them yourself. */
/*                  If you are sure you want to continue with relaxed */
/*                  error tolerances, set INFO(1) = 1 and call the code */
/*                  again. */

/*     IDID = -3, a solution component is zero and you set the */
/*                  corresponding component of ATOL to zero.  If you */
/*                  are sure you want to continue, you must first alter */
/*                  the error criterion to use positive values of ATOL */
/*                  for those components corresponding to zero solution */
/*                  components, then set INFO(1) = 1 and call the code */
/*                  again. */

/*     IDID = -4  --- cannot occur with this code. */

/*     IDID = -5, your JAC routine failed with the Krylov method.  Check */
/*                  for errors in JAC and restart the integration. */

/*     IDID = -6, repeated error test failures occurred on the last */
/*                  attempted step in DDASPK.  A singularity in the */
/*                  solution may be present.  If you are absolutely */
/*                  certain you want to continue, you should restart */
/*                  the integration.  (Provide initial values of Y and */
/*                  YPRIME which are consistent.) */

/*     IDID = -7, repeated convergence test failures occurred on the last */
/*                  attempted step in DDASPK.  An inaccurate or ill- */
/*                  conditioned Jacobian or preconditioner may be the */
/*                  problem.  If you are absolutely certain you want */
/*                  to continue, you should restart the integration. */


/*     IDID = -8, the matrix of partial derivatives is singular, with */
/*                  the use of direct methods.  Some of your equations */
/*                  may be redundant.  DDASPK cannot solve the problem */
/*                  as stated.  It is possible that the redundant */
/*                  equations could be removed, and then DDASPK could */
/*                  solve the problem.  It is also possible that a */
/*                  solution to your problem either does not exist */
/*                  or is not unique. */

/*     IDID = -9, DDASPK had multiple convergence test failures, preceded */
/*                  by multiple error test failures, on the last */
/*                  attempted step.  It is possible that your problem is */
/*                  ill-posed and cannot be solved using this code.  Or, */
/*                  there may be a discontinuity or a singularity in the */
/*                  solution.  If you are absolutely certain you want to */
/*                  continue, you should restart the integration. */

/*     IDID = -10, DDASPK had multiple convergence test failures */
/*                  because IRES was equal to -1.  If you are */
/*                  absolutely certain you want to continue, you */
/*                  should restart the integration. */

/*     IDID = -11, there was an unrecoverable error (IRES = -2) from RES */
/*                  inside the nonlinear system solver.  Determine the */
/*                  cause before trying again. */

/*     IDID = -12, DDASPK failed to compute the initial Y and YPRIME */
/*                  vectors.  This could happen because the initial */
/*                  approximation to Y or YPRIME was not very good, or */
/*                  because no consistent values of these vectors exist. */
/*                  The problem could also be caused by an inaccurate or */
/*                  singular iteration matrix, or a poor preconditioner. */

/*     IDID = -13, there was an unrecoverable error encountered inside */
/*                  your PSOL routine.  Determine the cause before */
/*                  trying again. */

/*     IDID = -14, the Krylov linear system solver failed to achieve */
/*                  convergence.  This may be due to ill-conditioning */
/*                  in the iteration matrix, or a singularity in the */
/*                  preconditioner (if one is being used). */
/*                  Another possibility is that there is a better */
/*                  choice of Krylov parameters (see INFO(13)). */
/*                  Possibly the failure is caused by redundant equations */
/*                  in the system, or by inconsistent equations. */
/*                  In that case, reformulate the system to make it */
/*                  consistent and non-redundant. */

/*     IDID = -15,..,-32 --- Cannot occur with this code. */

/*                       *** FOLLOWING A TERMINATED TASK *** */

/*     If IDID = -33, you cannot continue the solution of this problem. */
/*                  An attempt to do so will result in your run being */
/*                  terminated. */

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

/* ***REFERENCES */
/*  1.  L. R. Petzold, A Description of DASSL: A Differential/Algebraic */
/*      System Solver, in Scientific Computing, R. S. Stepleman et al. */
/*      (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. */
/*  2.  K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical */
/*      Solution of Initial-Value Problems in Differential-Algebraic */
/*      Equations, Elsevier, New York, 1989. */
/*  3.  P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods */
/*      in Stiff ODE Systems, J. Applied Mathematics and Computation, */
/*      31 (1989), pp. 40-91. */
/*  4.  P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov */
/*      Methods in the Solution of Large-Scale Differential-Algebraic */
/*      Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. */
/*  5.  P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent */
/*      Initial Condition Calculation for Differential-Algebraic */
/*      Systems, SIAM J. Sci. Comp. 19 (1998), pp. 1495-1512. */

/* ***ROUTINES CALLED */

/*   The following are all the subordinate routines used by DDASPK. */

/*   DDASIC computes consistent initial conditions. */
/*   DYYPNW updates Y and YPRIME in linesearch for initial condition */
/*          calculation. */
/*   DDSTP  carries out one step of the integration. */
/*   DCNSTR/DCNST0 check the current solution for constraint violations. */
/*   DDAWTS sets error weight quantities. */
/*   DINVWT tests and inverts the error weights. */
/*   DDATRP performs interpolation to get an output solution. */
/*   DDWNRM computes the weighted root-mean-square norm of a vector. */
/*   D1MACH provides the unit roundoff of the computer. */
/*   XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. */
/*   DDASID nonlinear equation driver to initialize Y and YPRIME using */
/*          direct linear system solver methods.  Interfaces to Newton */
/*          solver (direct case). */
/*   DNSID  solves the nonlinear system for unknown initial values by */
/*          modified Newton iteration and direct linear system methods. */
/*   DLINSD carries out linesearch algorithm for initial condition */
/*          calculation (direct case). */
/*   DFNRMD calculates weighted norm of preconditioned residual in */
/*          initial condition calculation (direct case). */
/*   DNEDD  nonlinear equation driver for direct linear system solver */
/*          methods.  Interfaces to Newton solver (direct case). */
/*   DMATD  assembles the iteration matrix (direct case). */
/*   DNSD   solves the associated nonlinear system by modified */
/*          Newton iteration and direct linear system methods. */
/*   DSLVD  interfaces to linear system solver (direct case). */
/*   DDASIK nonlinear equation driver to initialize Y and YPRIME using */
/*          Krylov iterative linear system methods.  Interfaces to */
/*          Newton solver (Krylov case). */
/*   DNSIK  solves the nonlinear system for unknown initial values by */
/*          Newton iteration and Krylov iterative linear system methods. */
/*   DLINSK carries out linesearch algorithm for initial condition */
/*          calculation (Krylov case). */
/*   DFNRMK calculates weighted norm of preconditioned residual in */
/*          initial condition calculation (Krylov case). */
/*   DNEDK  nonlinear equation driver for iterative linear system solver */
/*          methods.  Interfaces to Newton solver (Krylov case). */
/*   DNSK   solves the associated nonlinear system by Inexact Newton */
/*          iteration and (linear) Krylov iteration. */
/*   DSLVK  interfaces to linear system solver (Krylov case). */
/*   DSPIGM solves a linear system by SPIGMR algorithm. */
/*   DATV   computes matrix-vector product in Krylov algorithm. */
/*   DORTH  performs orthogonalization of Krylov basis vectors. */
/*   DHEQR  performs QR factorization of Hessenberg matrix. */
/*   DHELS  finds least-squares solution of Hessenberg linear system. */
/*   DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving */
/*          linear systems (dense or band direct methods). */
/*   DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) */
/*          routines. */

/* The routines called directly by DDASPK are: */
/*   DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, */
/*   XERRWD */

/* ***END PROLOGUE DDASPK */



/*     Set pointers into IWORK. */


/*     Set pointers into RWORK. */




/* ***FIRST EXECUTABLE STATEMENT  DDASPK */


    /* Parameter adjustments */
    --y;
    --yprime;
    --info;
    --rtol;
    --atol;
    --rwork;
    --iwork;
    --rpar;
    --ipar;

    /* Function Body */
    if (info[1] != 0) {
	goto L100;
    }

/* ----------------------------------------------------------------------- */
/*     This block is executed for the initial call only. */
/*     It contains checking of inputs and initializations. */
/* ----------------------------------------------------------------------- */

/*     First check INFO array to make sure all elements of INFO */
/*     Are within the proper range.  (INFO(1) is checked later, because */
/*     it must be tested on every call.) ITEMP holds the location */
/*     within INFO which may be out of range. */

    for (i__ = 2; i__ <= 9; ++i__) {
	itemp = i__;
	if (info[i__] != 0 && info[i__] != 1) {
	    goto L701;
	}
/* L10: */
    }
    itemp = 10;
    if (info[10] < 0 || info[10] > 3) {
	goto L701;
    }
    itemp = 11;
    if (info[11] < 0 || info[11] > 2) {
	goto L701;
    }
    for (i__ = 12; i__ <= 17; ++i__) {
	itemp = i__;
	if (info[i__] != 0 && info[i__] != 1) {
	    goto L701;
	}
/* L15: */
    }
    itemp = 18;
    if (info[18] < 0 || info[18] > 2) {
	goto L701;
    }

/*     Check NEQ to see if it is positive. */

    if (*neq <= 0) {
	goto L702;
    }

/*     Check and compute maximum order. */

    mxord = 5;
    if (info[9] != 0) {
	mxord = iwork[3];
	if (mxord < 1 || mxord > 5) {
	    goto L703;
	}
    }
    iwork[3] = mxord;

/*     Set and/or check inputs for constraint checking (INFO(10) .NE. 0). */
/*     Set values for ICNFLG, NONNEG, and pointer LID. */

    icnflg = 0;
    nonneg = 0;
    lid = 41;
    if (info[10] == 0) {
	goto L20;
    }
    if (info[10] == 1) {
	icnflg = 1;
	nonneg = 0;
	lid = *neq + 41;
    } else if (info[10] == 2) {
	icnflg = 0;
	nonneg = 1;
    } else {
	icnflg = 1;
	nonneg = 1;
	lid = *neq + 41;
    }

L20:

/*     Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). */
/*     If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. */
/*     Otherwise, verify inputs required for iterative solver. */

    if (info[12] == 0) {
	goto L25;
    }

    iwork[23] = info[12];
    if (info[13] == 0) {
	iwork[24] = min(5,*neq);
	iwork[25] = iwork[24];
	iwork[26] = 5;
	rwork[10] = .05;
    } else {
	if (iwork[24] < 1 || iwork[24] > *neq) {
	    goto L720;
	}
	if (iwork[25] < 1 || iwork[25] > iwork[24]) {
	    goto L721;
	}
	if (iwork[26] < 0) {
	    goto L722;
	}
	if (rwork[10] <= 0. || rwork[10] >= 1.) {
	    goto L723;
	}
    }

L25:

/*     Set and/or check controls for the initial condition calculation */
/*     (INFO(11) .GT. 0).  If indicated, set default values. */
/*     Otherwise, verify inputs required for iterative solver. */

    if (info[11] == 0) {
	goto L30;
    }
    if (info[17] == 0) {
	iwork[32] = 5;
	if (info[12] > 0) {
	    iwork[32] = 15;
	}
	iwork[33] = 6;
	if (info[12] > 0) {
	    iwork[33] = 2;
	}
	iwork[34] = 5;
	iwork[35] = 0;
	rwork[15] = .01;
    } else {
	if (iwork[32] <= 0) {
	    goto L725;
	}
	if (iwork[33] <= 0) {
	    goto L725;
	}
	if (iwork[34] <= 0) {
	    goto L725;
	}
	lsoff = iwork[35];
	if (lsoff < 0 || lsoff > 1) {
	    goto L725;
	}
	if (rwork[15] <= 0.) {
	    goto L725;
	}
    }

L30:

/*     Below is the computation and checking of the work array lengths */
/*     LENIW and LENRW, using direct methods (INFO(12) = 0) or */
/*     the Krylov methods (INFO(12) = 1). */

    lenic = 0;
    if (info[10] == 1 || info[10] == 3) {
	lenic = *neq;
    }
    lenid = 0;
    if (info[11] == 1 || info[16] == 1) {
	lenid = *neq;
    }
    if (info[12] == 0) {

/*        Compute MTYPE, etc.  Check ML and MU. */

/* Computing MAX */
	i__1 = mxord + 1;
	ncphi = max(i__1,4);
	if (info[6] == 0) {
/* Computing 2nd power */
	    i__1 = *neq;
	    lenpd = i__1 * i__1;
	    lenrw = (ncphi + 3) * *neq + 50 + lenpd;
	    if (info[5] == 0) {
		iwork[4] = 2;
	    } else {
		iwork[4] = 1;
	    }
	} else {
	    if (iwork[1] < 0 || iwork[1] >= *neq) {
		goto L717;
	    }
	    if (iwork[2] < 0 || iwork[2] >= *neq) {
		goto L718;
	    }
	    lenpd = ((iwork[1] << 1) + iwork[2] + 1) * *neq;
	    if (info[5] == 0) {
		iwork[4] = 5;
		mband = iwork[1] + iwork[2] + 1;
		msave = *neq / mband + 1;
		lenrw = (ncphi + 3) * *neq + 50 + lenpd + (msave << 1);
	    } else {
		iwork[4] = 4;
		lenrw = (ncphi + 3) * *neq + 50 + lenpd;
	    }
	}

/*        Compute LENIW, LENWP, LENIWP. */

	leniw = lenic + 40 + lenid + *neq;
	lenwp = 0;
	leniwp = 0;

    } else if (info[12] == 1) {
	ncphi = mxord + 1;
	maxl = iwork[24];
	lenwp = iwork[27];
	leniwp = iwork[28];
/* Computing MIN */
	i__1 = 1, i__2 = maxl - iwork[25];
	lenpd = (maxl + 3 + min(i__1,i__2)) * *neq + (maxl + 3) * maxl + 1 + 
		lenwp;
	lenrw = (mxord + 5) * *neq + 50 + lenpd;
	leniw = lenic + 40 + lenid + leniwp;

    }
    if (info[16] != 0) {
	lenrw += *neq;
    }

/*     Check lengths of RWORK and IWORK. */

    iwork[17] = leniw;
    iwork[18] = lenrw;
    iwork[22] = lenpd;
    iwork[29] = lenpd - lenwp + 1;
    if (*lrw < lenrw) {
	goto L704;
    }
    if (*liw < leniw) {
	goto L705;
    }

/*     Check ICNSTR for legality. */

    if (lenic > 0) {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ici = iwork[i__ + 40];
	    if (ici < -2 || ici > 2) {
		goto L726;
	    }
/* L40: */
	}
    }

/*     Check Y for consistency with constraints. */

    if (lenic > 0) {
	dcnst0_(neq, &y[1], &iwork[41], &iret);
	if (iret != 0) {
	    goto L727;
	}
    }

/*     Check ID for legality and set INDEX = 0 or 1. */

    index = 1;
    if (lenid > 0) {
	index = 0;
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    idi = iwork[lid - 1 + i__];
	    if (idi != 1 && idi != -1) {
		goto L724;
	    }
	    if (idi == -1) {
		index = 1;
	    }
/* L50: */
	}
    }

/*     Check to see that TOUT is different from T. */

    if (*tout == *t) {
	goto L719;
    }

/*     Check HMAX. */

    if (info[7] != 0) {
	hmax = rwork[2];
	if (hmax <= 0.) {
	    goto L710;
	}
    }

/*     Initialize counters and other flags. */

    iwork[11] = 0;
    iwork[12] = 0;
    iwork[13] = 0;
    iwork[14] = 0;
    iwork[15] = 0;
    iwork[19] = 0;
    iwork[20] = 0;
    iwork[21] = 0;
    iwork[16] = 0;
    iwork[31] = info[18];
    *idid = 1;
    goto L200;

/* ----------------------------------------------------------------------- */
/*     This block is for continuation calls only. */
/*     Here we check INFO(1), and if the last step was interrupted, */
/*     we check whether appropriate action was taken. */
/* ----------------------------------------------------------------------- */

L100:
    if (info[1] == 1) {
	goto L110;
    }
    itemp = 1;
    if (info[1] != -1) {
	goto L701;
    }

/*     If we are here, the last step was interrupted by an error */
/*     condition from DDSTP, and appropriate action was not taken. */
/*     This is a fatal error. */

    s_copy(msg, "DASPK--  THE LAST STEP TERMINATED WITH A NEGATIVE", (ftnlen)
	    80, (ftnlen)49);
    xerrwd_(msg, &c__49, &c__201, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  VALUE (=I1) OF IDID AND NO APPROPRIATE", (ftnlen)80,
	     (ftnlen)47);
    xerrwd_(msg, &c__47, &c__202, &c__0, &c__1, idid, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  ACTION WAS TAKEN. RUN TERMINATED", (ftnlen)80, (
	    ftnlen)41);
    xerrwd_(msg, &c__41, &c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    return 0;
L110:

/* ----------------------------------------------------------------------- */
/*     This block is executed on all calls. */

/*     Counters are saved for later checks of performance. */
/*     Then the error tolerance parameters are checked, and the */
/*     work array pointers are set. */
/* ----------------------------------------------------------------------- */

L200:

/*     Save counters for use later. */

    iwork[10] = iwork[11];
    nli0 = iwork[20];
    nni0 = iwork[19];
    ncfn0 = iwork[15];
    ncfl0 = iwork[16];
    nwarn = 0;

/*     Check RTOL and ATOL. */

    nzflg = 0;
    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (info[2] == 1) {
	    rtoli = rtol[i__];
	}
	if (info[2] == 1) {
	    atoli = atol[i__];
	}
	if (rtoli > 0. || atoli > 0.) {
	    nzflg = 1;
	}
	if (rtoli < 0.) {
	    goto L706;
	}
	if (atoli < 0.) {
	    goto L707;
	}
/* L210: */
    }
    if (nzflg == 0) {
	goto L708;
    }

/*     Set pointers to RWORK and IWORK segments. */
/*     For direct methods, SAVR is not used. */

    iwork[30] = lid + lenid;
    lsavr = 51;
    if (info[12] != 0) {
	lsavr = *neq + 51;
    }
    le = lsavr + *neq;
    lwt = le + *neq;
    lvt = lwt;
    if (info[16] != 0) {
	lvt = lwt + *neq;
    }
    lphi = lvt + *neq;
    lwm = lphi + ncphi * *neq;
    if (info[1] == 1) {
	goto L400;
    }

/* ----------------------------------------------------------------------- */
/*     This block is executed on the initial call only. */
/*     Set the initial step size, the error weight vector, and PHI. */
/*     Compute unknown initial components of Y and YPRIME, if requested. */
/* ----------------------------------------------------------------------- */

/* L300: */
    tn = *t;
    *idid = 1;

/*     Set error weight array WT and altered weight array VT. */

    ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], &
	    ipar[1]);
    dinvwt_(neq, &rwork[lwt], &ier);
    if (ier != 0) {
	goto L713;
    }
    if (info[16] != 0) {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L305: */
/* Computing MAX */
	    i__2 = iwork[lid + i__ - 1];
	    rwork[lvt + i__ - 1] = max(i__2,0) * rwork[lwt + i__ - 1];
	}
    }

/*     Compute unit roundoff and HMIN. */

    uround = d1mach_(&c__4);
    rwork[9] = uround;
/* Computing MAX */
    d__1 = abs(*t), d__2 = abs(*tout);
    hmin = uround * 4. * max(d__1,d__2);

/*     Set/check STPTOL control for initial condition calculation. */

    if (info[11] != 0) {
	if (info[17] == 0) {
	    rwork[14] = pow_dd(&uround, &c_b67);
	} else {
	    if (rwork[14] <= 0.) {
		goto L725;
	    }
	}
    }

/*     Compute EPCON and square root of NEQ and its reciprocal, used */
/*     inside iterative solver. */

    rwork[13] = .33;
    floatn = (doublereal) (*neq);
    rwork[11] = sqrt(floatn);
    rwork[12] = 1. / rwork[11];

/*     Check initial interval to see that it is long enough. */

    tdist = (d__1 = *tout - *t, abs(d__1));
    if (tdist < hmin) {
	goto L714;
    }

/*     Check H0, if this was input. */

    if (info[8] == 0) {
	goto L310;
    }
    h0 = rwork[3];
    if ((*tout - *t) * h0 < 0.) {
	goto L711;
    }
    if (h0 == 0.) {
	goto L712;
    }
    goto L320;
L310:

/*     Compute initial stepsize, to be used by either */
/*     DDSTP or DDASIC, depending on INFO(11). */

    h0 = tdist * .001;
    ypnorm = ddwnrm_(neq, &yprime[1], &rwork[lvt], &rpar[1], &ipar[1]);
    if (ypnorm > .5 / h0) {
	h0 = .5 / ypnorm;
    }
    d__1 = *tout - *t;
    h0 = d_sign(&h0, &d__1);

/*     Adjust H0 if necessary to meet HMAX bound. */

L320:
    if (info[7] == 0) {
	goto L330;
    }
    rh = abs(h0) / rwork[2];
    if (rh > 1.) {
	h0 /= rh;
    }

/*     Check against TSTOP, if applicable. */

L330:
    if (info[4] == 0) {
	goto L340;
    }
    tstop = rwork[1];
    s_wsle(&io___49);
    do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8);
    do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal));
    e_wsle();
    if ((tstop - *t) * h0 < 0.) {
	goto L715;
    }
    if ((*t + h0 - tstop) * h0 > 0.) {
	h0 = tstop - *t;
    }
    if ((tstop - *tout) * h0 < 0.) {
	goto L709;
    }

L340:
    if (info[11] == 0) {
	goto L370;
    }

/*     Compute unknown components of initial Y and YPRIME, depending */
/*     on INFO(11) and INFO(12).  INFO(12) represents the nonlinear */
/*     solver type (direct/Krylov).  Pass the name of the specific */
/*     nonlinear solver, depending on INFO(12).  The location of the work */
/*     arrays SAVR, YIC, YPIC, PWK also differ in the two cases. */
/*     For use in stopping tests, pass TSCALE = TDIST if INDEX = 0. */

    nwt = 1;
    epconi = rwork[15] * rwork[13];
    tscale = 0.;
    if (index == 0) {
	tscale = tdist;
    }
L350:
    if (info[12] == 0) {
	lyic = lphi + (*neq << 1);
	lypic = lyic + *neq;
	lpwk = lypic;
	ddasic_(&tn, &y[1], &yprime[1], neq, &info[11], &iwork[lid], (U_fp)
		res, (U_fp)jac, (U_fp)psol, &h0, &tscale, &rwork[lwt], &nwt, 
		idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[
		51], &rwork[le], &rwork[lyic], &rwork[lypic], &rwork[lpwk], &
		rwork[lwm], &iwork[1], &rwork[9], &rwork[10], &rwork[11], &
		rwork[12], &epconi, &rwork[14], &info[15], &icnflg, &iwork[41]
		, (U_fp)ddasid_);
    } else if (info[12] == 1) {
	lyic = lwm;
	lypic = lyic + *neq;
	lpwk = lypic + *neq;
	ddasic_(&tn, &y[1], &yprime[1], neq, &info[11], &iwork[lid], (U_fp)
		res, (U_fp)jac, (U_fp)psol, &h0, &tscale, &rwork[lwt], &nwt, 
		idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[
		51], &rwork[le], &rwork[lyic], &rwork[lypic], &rwork[lpwk], &
		rwork[lwm], &iwork[1], &rwork[9], &rwork[10], &rwork[11], &
		rwork[12], &epconi, &rwork[14], &info[15], &icnflg, &iwork[41]
		, (U_fp)ddasik_);
    }

    if (*idid < 0) {
	goto L600;
    }

/*     DDASIC was successful.  If this was the first call to DDASIC, */
/*     update the WT array (with the current Y) and call it again. */

    if (nwt == 2) {
	goto L355;
    }
    nwt = 2;
    ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], &
	    ipar[1]);
    dinvwt_(neq, &rwork[lwt], &ier);
    if (ier != 0) {
	goto L713;
    }
    goto L350;

/*     If INFO(14) = 1, return now with IDID = 4. */

L355:
    if (info[14] == 1) {
	*idid = 4;
	h__ = h0;
	if (info[11] == 1) {
	    rwork[7] = h0;
	}
	goto L590;
    }

/*     Update the WT and VT arrays one more time, with the new Y. */

    ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], &
	    ipar[1]);
    dinvwt_(neq, &rwork[lwt], &ier);
    if (ier != 0) {
	goto L713;
    }
    if (info[16] != 0) {
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* L357: */
/* Computing MAX */
	    i__1 = iwork[lid + i__ - 1];
	    rwork[lvt + i__ - 1] = max(i__1,0) * rwork[lwt + i__ - 1];
	}
    }

/*     Reset the initial stepsize to be used by DDSTP. */
/*     Use H0, if this was input.  Otherwise, recompute H0, */
/*     and adjust it if necessary to meet HMAX bound. */

    if (info[8] != 0) {
	h0 = rwork[3];
	goto L360;
    }

    h0 = tdist * .001;
    ypnorm = ddwnrm_(neq, &yprime[1], &rwork[lvt], &rpar[1], &ipar[1]);
    if (ypnorm > .5 / h0) {
	h0 = .5 / ypnorm;
    }
    d__1 = *tout - *t;
    h0 = d_sign(&h0, &d__1);

L360:
    if (info[7] != 0) {
	rh = abs(h0) / rwork[2];
	if (rh > 1.) {
	    h0 /= rh;
	}
    }

/*     Check against TSTOP, if applicable. */

    if (info[4] != 0) {
	tstop = rwork[1];
	s_wsle(&io___57);
	do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8);
	do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal));
	e_wsle();
	if ((*t + h0 - tstop) * h0 > 0.) {
	    h0 = tstop - *t;
	}
    }

/*     Load H and RWORK(LH) with H0. */

L370:
    h__ = h0;
    rwork[3] = h__;

/*     Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). */

    itemp = lphi + *neq;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	rwork[lphi + i__ - 1] = y[i__];
/* L380: */
	rwork[itemp + i__ - 1] = h__ * yprime[i__];
    }

    goto L500;

/* ----------------------------------------------------------------------- */
/*     This block is for continuation calls only. */
/*     Its purpose is to check stop conditions before taking a step. */
/*     Adjust H if necessary to meet HMAX bound. */
/* ----------------------------------------------------------------------- */

L400:
    uround = rwork[9];
    done = FALSE_;
    tn = rwork[4];
    h__ = rwork[3];
    if (info[7] == 0) {
	goto L410;
    }
    rh = abs(h__) / rwork[2];
    if (rh > 1.) {
	h__ /= rh;
    }
L410:
    if (*t == *tout) {
	goto L719;
    }
    if ((*t - *tout) * h__ > 0.) {
	goto L711;
    }
    if (info[4] == 1) {
	goto L430;
    }
    if (info[3] == 1) {
	goto L420;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L490;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *t = *tout;
    *idid = 3;
    done = TRUE_;
    goto L490;
L420:
    if ((tn - *t) * h__ <= 0.) {
	goto L490;
    }
    if ((tn - *tout) * h__ >= 0.) {
	goto L425;
    }
    ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[
	    39]);
    *t = tn;
    *idid = 1;
    done = TRUE_;
    goto L490;
L425:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *t = *tout;
    *idid = 3;
    done = TRUE_;
    goto L490;
L430:
    if (info[3] == 1) {
	goto L440;
    }
    tstop = rwork[1];
    s_wsle(&io___59);
    do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8);
    do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal));
    e_wsle();
    if ((tn - tstop) * h__ > 0.) {
	goto L715;
    }
    if ((tstop - *tout) * h__ < 0.) {
	goto L709;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L450;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *t = *tout;
    *idid = 3;
    done = TRUE_;
    goto L490;
L440:
    tstop = rwork[1];
    s_wsle(&io___60);
    do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8);
    do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal));
    e_wsle();
    if ((tn - tstop) * h__ > 0.) {
	goto L715;
    }
    if ((tstop - *tout) * h__ < 0.) {
	goto L709;
    }
    if ((tn - *t) * h__ <= 0.) {
	goto L450;
    }
    if ((tn - *tout) * h__ >= 0.) {
	goto L445;
    }
    ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[
	    39]);
    *t = tn;
    *idid = 1;
    done = TRUE_;
    goto L490;
L445:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *t = *tout;
    *idid = 3;
    done = TRUE_;
    goto L490;
L450:

/*     Check whether we are within roundoff of TSTOP. */

    if ((d__1 = tn - tstop, abs(d__1)) > uround * 100. * (abs(tn) + abs(h__)))
	     {
	goto L460;
    }
    ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *idid = 2;
    *t = tstop;
    done = TRUE_;
    goto L490;
L460:
    tnext = tn + h__;
    if ((tnext - tstop) * h__ <= 0.) {
	goto L490;
    }
    h__ = tstop - tn;
    rwork[3] = h__;

L490:
    if (done) {
	goto L590;
    }

/* ----------------------------------------------------------------------- */
/*     The next block contains the call to the one-step integrator DDSTP. */
/*     This is a looping point for the integration steps. */
/*     Check for too many steps. */
/*     Check for poor Newton/Krylov performance. */
/*     Update WT.  Check for too much accuracy requested. */
/*     Compute minimum stepsize. */
/* ----------------------------------------------------------------------- */

L500:

/*     Check for too many steps. */

    if (iwork[11] - iwork[10] < 500) {
	goto L505;
    }
    *idid = -1;
    goto L527;

/* Check for poor Newton/Krylov performance. */

L505:
    if (info[12] == 0) {
	goto L510;
    }
    nstd = iwork[11] - iwork[10];
    nnid = iwork[19] - nni0;
    if (nstd < 10 || nnid == 0) {
	goto L510;
    }
    avlin = (real) (iwork[20] - nli0) / (real) nnid;
    rcfn = (real) (iwork[15] - ncfn0) / (real) nstd;
    rcfl = (real) (iwork[16] - ncfl0) / (real) nnid;
    fmaxl = (doublereal) iwork[24];
    lavl = avlin > fmaxl;
    lcfn = rcfn > .9;
    lcfl = rcfl > .9;
    lwarn = lavl || lcfn || lcfl;
    if (! lwarn) {
	goto L510;
    }
    ++nwarn;
    if (nwarn > 10) {
	goto L510;
    }
    if (lavl) {
	s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance   "
		, (ftnlen)80, (ftnlen)56);
	xerrwd_(msg, &c__56, &c__501, &c__0, &c__0, &c__0, &c__0, &c__0, &
		c_b37, &c_b37, (ftnlen)80);
	s_copy(msg, "      at T = R1. Average no. of linear iterations = R2  "
		, (ftnlen)80, (ftnlen)56);
	xerrwd_(msg, &c__56, &c__501, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, 
		&avlin, (ftnlen)80);
    }
    if (lcfn) {
	s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance   "
		, (ftnlen)80, (ftnlen)56);
	xerrwd_(msg, &c__56, &c__502, &c__0, &c__0, &c__0, &c__0, &c__0, &
		c_b37, &c_b37, (ftnlen)80);
	s_copy(msg, "      at T = R1. Nonlinear convergence failure rate = R2"
		, (ftnlen)80, (ftnlen)56);
	xerrwd_(msg, &c__56, &c__502, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, 
		&rcfn, (ftnlen)80);
    }
    if (lcfl) {
	s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance   "
		, (ftnlen)80, (ftnlen)56);
	xerrwd_(msg, &c__56, &c__503, &c__0, &c__0, &c__0, &c__0, &c__0, &
		c_b37, &c_b37, (ftnlen)80);
	s_copy(msg, "      at T = R1. Linear convergence failure rate = R2   "
		, (ftnlen)80, (ftnlen)56);
	xerrwd_(msg, &c__56, &c__503, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, 
		&rcfl, (ftnlen)80);
    }

/*     Update WT and VT, if this is not the first call. */

L510:
    ddawts_(neq, &info[2], &rtol[1], &atol[1], &rwork[lphi], &rwork[lwt], &
	    rpar[1], &ipar[1]);
    dinvwt_(neq, &rwork[lwt], &ier);
    if (ier != 0) {
	*idid = -3;
	goto L527;
    }
    if (info[16] != 0) {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L515: */
/* Computing MAX */
	    i__2 = iwork[lid + i__ - 1];
	    rwork[lvt + i__ - 1] = max(i__2,0) * rwork[lwt + i__ - 1];
	}
    }

/*     Test for too much accuracy requested. */

    r__ = ddwnrm_(neq, &rwork[lphi], &rwork[lwt], &rpar[1], &ipar[1]) * 100. *
	     uround;
    if (r__ <= 1.) {
	goto L525;
    }

/*     Multiply RTOL and ATOL by R and return. */

    if (info[2] == 1) {
	goto L523;
    }
    rtol[1] = r__ * rtol[1];
    atol[1] = r__ * atol[1];
    *idid = -2;
    goto L527;
L523:
    i__2 = *neq;
    for (i__ = 1; i__ <= i__2; ++i__) {
	rtol[i__] = r__ * rtol[i__];
/* L524: */
	atol[i__] = r__ * atol[i__];
    }
    *idid = -2;
    goto L527;
L525:

/*     Compute minimum stepsize. */

/* Computing MAX */
    d__1 = abs(tn), d__2 = abs(*tout);
    hmin = uround * 4. * max(d__1,d__2);

/*     Test H vs. HMAX */
    if (info[7] != 0) {
	rh = abs(h__) / rwork[2];
	if (rh > 1.) {
	    h__ /= rh;
	}
    }

/*     Call the one-step integrator. */
/*     Note that INFO(12) represents the nonlinear solver type. */
/*     Pass the required nonlinear solver, depending upon INFO(12). */

    if (info[12] == 0) {
	ddstp_(&tn, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, 
		&h__, &rwork[lwt], &rwork[lvt], &info[1], idid, &rpar[1], &
		ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[51], &rwork[le], 
		&rwork[lwm], &iwork[1], &rwork[21], &rwork[27], &rwork[33], &
		rwork[39], &rwork[45], &rwork[5], &rwork[6], &rwork[7], &
		rwork[8], &hmin, &rwork[9], &rwork[10], &rwork[11], &rwork[12]
		, &rwork[13], &iwork[6], &iwork[5], &info[15], &iwork[7], &
		iwork[8], &iwork[9], &nonneg, &info[12], (U_fp)dnedd_);
    } else if (info[12] == 1) {
	ddstp_(&tn, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, 
		&h__, &rwork[lwt], &rwork[lvt], &info[1], idid, &rpar[1], &
		ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[51], &rwork[le], 
		&rwork[lwm], &iwork[1], &rwork[21], &rwork[27], &rwork[33], &
		rwork[39], &rwork[45], &rwork[5], &rwork[6], &rwork[7], &
		rwork[8], &hmin, &rwork[9], &rwork[10], &rwork[11], &rwork[12]
		, &rwork[13], &iwork[6], &iwork[5], &info[15], &iwork[7], &
		iwork[8], &iwork[9], &nonneg, &info[12], (U_fp)dnedk_);
    }

L527:
    if (*idid < 0) {
	goto L600;
    }

/* ----------------------------------------------------------------------- */
/*     This block handles the case of a successful return from DDSTP */
/*     (IDID=1).  Test for stop conditions. */
/* ----------------------------------------------------------------------- */

    if (info[4] != 0) {
	goto L540;
    }
    if (info[3] != 0) {
	goto L530;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L500;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *idid = 3;
    *t = *tout;
    goto L580;
L530:
    if ((tn - *tout) * h__ >= 0.) {
	goto L535;
    }
    *t = tn;
    *idid = 1;
    goto L580;
L535:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *idid = 3;
    *t = *tout;
    goto L580;
L540:
    if (info[3] != 0) {
	goto L550;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L542;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *t = *tout;
    *idid = 3;
    goto L580;
L542:
    if ((d__1 = tn - tstop, abs(d__1)) <= uround * 100. * (abs(tn) + abs(h__))
	    ) {
	goto L545;
    }
    tnext = tn + h__;
    if ((tnext - tstop) * h__ <= 0.) {
	goto L500;
    }
    h__ = tstop - tn;
    goto L500;
L545:
    ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *idid = 2;
    *t = tstop;
    goto L580;
L550:
    if ((tn - *tout) * h__ >= 0.) {
	goto L555;
    }
    if ((d__1 = tn - tstop, abs(d__1)) <= uround * 100. * (abs(tn) + abs(h__))
	    ) {
	goto L552;
    }
    *t = tn;
    *idid = 1;
    goto L580;
L552:
    ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *idid = 2;
    *t = tstop;
    goto L580;
L555:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[39]);
    *t = *tout;
    *idid = 3;
L580:

/* ----------------------------------------------------------------------- */
/*     All successful returns from DDASPK are made from this block. */
/* ----------------------------------------------------------------------- */

L590:
    rwork[4] = tn;
    rwork[3] = h__;
    return 0;

/* ----------------------------------------------------------------------- */
/*     This block handles all unsuccessful returns other than for */
/*     illegal input. */
/* ----------------------------------------------------------------------- */

L600:
    itemp = -(*idid);
    switch (itemp) {
	case 1:  goto L610;
	case 2:  goto L620;
	case 3:  goto L630;
	case 4:  goto L700;
	case 5:  goto L655;
	case 6:  goto L640;
	case 7:  goto L650;
	case 8:  goto L660;
	case 9:  goto L670;
	case 10:  goto L675;
	case 11:  goto L680;
	case 12:  goto L685;
	case 13:  goto L690;
	case 14:  goto L695;
    }

/*     The maximum number of steps was taken before */
/*     reaching tout. */

L610:
    s_copy(msg, "DASPK--  AT CURRENT T (=R1)  500 STEPS", (ftnlen)80, (ftnlen)
	    38);
    xerrwd_(msg, &c__38, &c__610, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  TAKEN ON THIS CALL BEFORE REACHING TOUT", (ftnlen)
	    80, (ftnlen)48);
    xerrwd_(msg, &c__48, &c__611, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Too much accuracy for machine precision. */

L620:
    s_copy(msg, "DASPK--  AT T (=R1) TOO MUCH ACCURACY REQUESTED", (ftnlen)80,
	     (ftnlen)47);
    xerrwd_(msg, &c__47, &c__620, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  FOR PRECISION OF MACHINE. RTOL AND ATOL", (ftnlen)
	    80, (ftnlen)48);
    xerrwd_(msg, &c__48, &c__621, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  WERE INCREASED TO APPROPRIATE VALUES", (ftnlen)80, (
	    ftnlen)45);
    xerrwd_(msg, &c__45, &c__622, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     WT(I) .LE. 0.0D0 for some I (not at start of problem). */

L630:
    s_copy(msg, "DASPK--  AT T (=R1) SOME ELEMENT OF WT", (ftnlen)80, (ftnlen)
	    38);
    xerrwd_(msg, &c__38, &c__630, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  HAS BECOME .LE. 0.0", (ftnlen)80, (ftnlen)28);
    xerrwd_(msg, &c__28, &c__631, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Error test failed repeatedly or with H=HMIN. */

L640:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__640, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN", (
	    ftnlen)80, (ftnlen)57);
    xerrwd_(msg, &c__57, &c__641, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Nonlinear solver failed to converge repeatedly or with H=HMIN. */

L650:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__650, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  NONLINEAR SOLVER FAILED TO CONVERGE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__651, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  REPEATEDLY OR WITH ABS(H)=HMIN", (ftnlen)80, (
	    ftnlen)39);
    xerrwd_(msg, &c__40, &c__652, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     The preconditioner had repeated failures. */

L655:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__655, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  PRECONDITIONER HAD REPEATED FAILURES.", (ftnlen)80, 
	    (ftnlen)46);
    xerrwd_(msg, &c__46, &c__656, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     The iteration matrix is singular. */

L660:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__660, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  ITERATION MATRIX IS SINGULAR.", (ftnlen)80, (ftnlen)
	    38);
    xerrwd_(msg, &c__38, &c__661, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Nonlinear system failure preceded by error test failures. */

L670:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__670, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  NONLINEAR SOLVER COULD NOT CONVERGE.", (ftnlen)80, (
	    ftnlen)45);
    xerrwd_(msg, &c__45, &c__671, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  ALSO, THE ERROR TEST FAILED REPEATEDLY.", (ftnlen)
	    80, (ftnlen)48);
    xerrwd_(msg, &c__49, &c__672, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Nonlinear system failure because IRES = -1. */

L675:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__675, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE", (
	    ftnlen)80, (ftnlen)51);
    xerrwd_(msg, &c__51, &c__676, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  BECAUSE IRES WAS EQUAL TO MINUS ONE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__677, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Failure because IRES = -2. */

L680:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2)", (ftnlen)80, (
	    ftnlen)40);
    xerrwd_(msg, &c__40, &c__680, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  IRES WAS EQUAL TO MINUS TWO", (ftnlen)80, (ftnlen)
	    36);
    xerrwd_(msg, &c__36, &c__681, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Failed to compute initial YPRIME. */

L685:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__685, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    s_copy(msg, "DASPK--  INITIAL (Y,YPRIME) COULD NOT BE COMPUTED", (ftnlen)
	    80, (ftnlen)49);
    xerrwd_(msg, &c__49, &c__686, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &h0,
	     (ftnlen)80);
    goto L700;

/*     Failure because IER was negative from PSOL. */

L690:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2)", (ftnlen)80, (
	    ftnlen)40);
    xerrwd_(msg, &c__40, &c__690, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  IER WAS NEGATIVE FROM PSOL", (ftnlen)80, (ftnlen)35)
	    ;
    xerrwd_(msg, &c__35, &c__691, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;

/*     Failure because the linear system solver could not converge. */

L695:
    s_copy(msg, "DASPK--  AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, (
	    ftnlen)44);
    xerrwd_(msg, &c__44, &c__695, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &
	    h__, (ftnlen)80);
    s_copy(msg, "DASPK--  LINEAR SYSTEM SOLVER COULD NOT CONVERGE.", (ftnlen)
	    80, (ftnlen)49);
    xerrwd_(msg, &c__50, &c__696, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L700;


L700:
    info[1] = -1;
    *t = tn;
    rwork[4] = tn;
    rwork[3] = h__;
    return 0;

/* ----------------------------------------------------------------------- */
/*     This block handles all error returns due to illegal input, */
/*     as detected before calling DDSTP. */
/*     First the error message routine is called.  If this happens */
/*     twice in succession, execution is terminated. */
/* ----------------------------------------------------------------------- */

L701:
    s_copy(msg, "DASPK--  ELEMENT (=I1) OF INFO VECTOR IS NOT VALID", (ftnlen)
	    80, (ftnlen)50);
    xerrwd_(msg, &c__50, &c__1, &c__0, &c__1, &itemp, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L702:
    s_copy(msg, "DASPK--  NEQ (=I1) .LE. 0", (ftnlen)80, (ftnlen)25);
    xerrwd_(msg, &c__25, &c__2, &c__0, &c__1, neq, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L703:
    s_copy(msg, "DASPK--  MAXORD (=I1) NOT IN RANGE", (ftnlen)80, (ftnlen)34);
    xerrwd_(msg, &c__34, &c__3, &c__0, &c__1, &mxord, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L704:
    s_copy(msg, "DASPK--  RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)"
	    , (ftnlen)80, (ftnlen)60);
    xerrwd_(msg, &c__60, &c__4, &c__0, &c__2, &lenrw, lrw, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L705:
    s_copy(msg, "DASPK--  IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)"
	    , (ftnlen)80, (ftnlen)60);
    xerrwd_(msg, &c__60, &c__5, &c__0, &c__2, &leniw, liw, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L706:
    s_copy(msg, "DASPK--  SOME ELEMENT OF RTOL IS .LT. 0", (ftnlen)80, (
	    ftnlen)39);
    xerrwd_(msg, &c__39, &c__6, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L707:
    s_copy(msg, "DASPK--  SOME ELEMENT OF ATOL IS .LT. 0", (ftnlen)80, (
	    ftnlen)39);
    xerrwd_(msg, &c__39, &c__7, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L708:
    s_copy(msg, "DASPK--  ALL ELEMENTS OF RTOL AND ATOL ARE ZERO", (ftnlen)80,
	     (ftnlen)47);
    xerrwd_(msg, &c__47, &c__8, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L709:
    s_copy(msg, "DASPK--  INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)", (
	    ftnlen)80, (ftnlen)54);
    xerrwd_(msg, &c__54, &c__9, &c__0, &c__0, &c__0, &c__0, &c__2, &tstop, 
	    tout, (ftnlen)80);
    goto L750;
L710:
    s_copy(msg, "DASPK--  HMAX (=R1) .LT. 0.0", (ftnlen)80, (ftnlen)28);
    xerrwd_(msg, &c__28, &c__10, &c__0, &c__0, &c__0, &c__0, &c__1, &hmax, &
	    c_b37, (ftnlen)80);
    goto L750;
L711:
    s_copy(msg, "DASPK--  TOUT (=R1) BEHIND T (=R2)", (ftnlen)80, (ftnlen)34);
    xerrwd_(msg, &c__34, &c__11, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, (
	    ftnlen)80);
    goto L750;
L712:
    s_copy(msg, "DASPK--  INFO(8)=1 AND H0=0.0", (ftnlen)80, (ftnlen)29);
    xerrwd_(msg, &c__29, &c__12, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L713:
    s_copy(msg, "DASPK--  SOME ELEMENT OF WT IS .LE. 0.0", (ftnlen)80, (
	    ftnlen)39);
    xerrwd_(msg, &c__39, &c__13, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L714:
    s_copy(msg, "DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION"
	    , (ftnlen)80, (ftnlen)60);
    xerrwd_(msg, &c__60, &c__14, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, (
	    ftnlen)80);
    goto L750;
L715:
    s_copy(msg, "DASPK--  INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)", (ftnlen)
	    80, (ftnlen)49);
    xerrwd_(msg, &c__49, &c__15, &c__0, &c__0, &c__0, &c__0, &c__2, &tstop, t,
	     (ftnlen)80);
    goto L750;
L717:
    s_copy(msg, "DASPK--  ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ", (
	    ftnlen)80, (ftnlen)52);
    xerrwd_(msg, &c__52, &c__17, &c__0, &c__1, &iwork[1], &c__0, &c__0, &
	    c_b37, &c_b37, (ftnlen)80);
    goto L750;
L718:
    s_copy(msg, "DASPK--  MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ", (
	    ftnlen)80, (ftnlen)52);
    xerrwd_(msg, &c__52, &c__18, &c__0, &c__1, &iwork[2], &c__0, &c__0, &
	    c_b37, &c_b37, (ftnlen)80);
    goto L750;
L719:
    s_copy(msg, "DASPK--  TOUT (=R1) IS EQUAL TO T (=R2)", (ftnlen)80, (
	    ftnlen)39);
    xerrwd_(msg, &c__39, &c__19, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, (
	    ftnlen)80);
    goto L750;
L720:
    s_copy(msg, "DASPK--  MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ", (
	    ftnlen)80, (ftnlen)54);
    xerrwd_(msg, &c__54, &c__20, &c__0, &c__1, &iwork[24], &c__0, &c__0, &
	    c_b37, &c_b37, (ftnlen)80);
    goto L750;
L721:
    s_copy(msg, "DASPK--  KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL", (
	    ftnlen)80, (ftnlen)54);
    xerrwd_(msg, &c__54, &c__21, &c__0, &c__1, &iwork[25], &c__0, &c__0, &
	    c_b37, &c_b37, (ftnlen)80);
    goto L750;
L722:
    s_copy(msg, "DASPK--  NRMAX (=I1) ILLEGAL. .LT. 0", (ftnlen)80, (ftnlen)
	    36);
    xerrwd_(msg, &c__36, &c__22, &c__0, &c__1, &iwork[26], &c__0, &c__0, &
	    c_b37, &c_b37, (ftnlen)80);
    goto L750;
L723:
    s_copy(msg, "DASPK--  EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0", 
	    (ftnlen)80, (ftnlen)58);
    xerrwd_(msg, &c__58, &c__23, &c__0, &c__0, &c__0, &c__0, &c__1, &rwork[10]
	    , &c_b37, (ftnlen)80);
    goto L750;
L724:
    s_copy(msg, "DASPK--  ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0", (ftnlen)
	    80, (ftnlen)48);
    xerrwd_(msg, &c__48, &c__24, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L725:
    s_copy(msg, "DASPK--  ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL", (
	    ftnlen)80, (ftnlen)54);
    xerrwd_(msg, &c__54, &c__25, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L726:
    s_copy(msg, "DASPK--  ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0", (ftnlen)
	    80, (ftnlen)48);
    xerrwd_(msg, &c__48, &c__26, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L727:
    s_copy(msg, "DASPK--  Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT", (ftnlen)
	    80, (ftnlen)49);
    xerrwd_(msg, &c__49, &c__27, &c__0, &c__1, &iret, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    goto L750;
L750:
    if (info[1] == -1) {
	goto L760;
    }
    info[1] = -1;
    *idid = -33;
    return 0;
L760:
    s_copy(msg, "DASPK--  REPEATED OCCURRENCES OF ILLEGAL INPUT", (ftnlen)80, 
	    (ftnlen)46);
    xerrwd_(msg, &c__46, &c__701, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
/* L770: */
    s_copy(msg, "DASPK--  RUN TERMINATED. APPARENT INFINITE LOOP", (ftnlen)80,
	     (ftnlen)47);
    xerrwd_(msg, &c__47, &c__702, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b37, &
	    c_b37, (ftnlen)80);
    return 0;

/* ------END OF SUBROUTINE DDASPK----------------------------------------- */
} /* ddaspk_ */

/* Subroutine */ int ddasic_(doublereal *x, doublereal *y, doublereal *yprime,
	 integer *neq, integer *icopt, integer *id, U_fp res, U_fp jac, U_fp 
	psol, doublereal *h__, doublereal *tscale, doublereal *wt, integer *
	nic, integer *idid, doublereal *rpar, integer *ipar, doublereal *phi, 
	doublereal *savr, doublereal *delta, doublereal *e, doublereal *yic, 
	doublereal *ypic, doublereal *pwk, doublereal *wm, integer *iwm, 
	doublereal *uround, doublereal *epli, doublereal *sqrtn, doublereal *
	rsqrtn, doublereal *epconi, doublereal *stptol, integer *jflg, 
	integer *icnflg, integer *icnstr, S_fp nlsic)
{
    /* Initialized data */

    static doublereal rhcut = .1;
    static doublereal ratemx = .8;

    /* System generated locals */
    integer phi_dim1, phi_offset;

    /* Local variables */
    doublereal cj;
    integer nh, mxnh;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    integer jskip, iernls;


/* ***BEGIN PROLOGUE  DDASIC */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   940628   (YYMMDD) */
/* ***REVISION DATE  941206   (YYMMDD) */
/* ***REVISION DATE  950714   (YYMMDD) */
/* ***REVISION DATE  000628   TSCALE argument added. */

/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DDASIC is a driver routine to compute consistent initial values */
/*     for Y and YPRIME.  There are two different options: */
/*     Denoting the differential variables in Y by Y_d, and */
/*     the algebraic variables by Y_a, the problem solved is either: */
/*     1.  Given Y_d, calculate Y_a and Y_d', or */
/*     2.  Given Y', calculate Y. */
/*     In either case, initial values for the given components */
/*     are input, and initial guesses for the unknown components */
/*     must also be provided as input. */

/*     The external routine NLSIC solves the resulting nonlinear system. */

/*     The parameters represent */

/*     X  --        Independent variable. */
/*     Y  --        Solution vector at X. */
/*     YPRIME --    Derivative of solution vector. */
/*     NEQ --       Number of equations to be integrated. */
/*     ICOPT     -- Flag indicating initial condition option chosen. */
/*                    ICOPT = 1 for option 1 above. */
/*                    ICOPT = 2 for option 2. */
/*     ID        -- Array of dimension NEQ, which must be initialized */
/*                  if option 1 is chosen. */
/*                    ID(i) = +1 if Y_i is a differential variable, */
/*                    ID(i) = -1 if Y_i is an algebraic variable. */
/*     RES --       External user-supplied subroutine to evaluate the */
/*                  residual.  See RES description in DDASPK prologue. */
/*     JAC --       External user-supplied routine to update Jacobian */
/*                  or preconditioner information in the nonlinear solver */
/*                  (optional).  See JAC description in DDASPK prologue. */
/*     PSOL --      External user-supplied routine to solve */
/*                  a linear system using preconditioning. */
/*                  See PSOL in DDASPK prologue. */
/*     H --         Scaling factor in iteration matrix.  DDASIC may */
/*                  reduce H to achieve convergence. */
/*     TSCALE --    Scale factor in T, used for stopping tests if nonzero. */
/*     WT --        Vector of weights for error criterion. */
/*     NIC --       Input number of initial condition calculation call */
/*                  (= 1 or 2). */
/*     IDID --      Completion code.  See IDID in DDASPK prologue. */
/*     RPAR,IPAR -- Real and integer parameter arrays that */
/*                  are used for communication between the */
/*                  calling program and external user routines. */
/*                  They are not altered by DNSK */
/*     PHI --       Work space for DDASIC of length at least 2*NEQ. */
/*     SAVR --      Work vector for DDASIC of length NEQ. */
/*     DELTA --     Work vector for DDASIC of length NEQ. */
/*     E --         Work vector for DDASIC of length NEQ. */
/*     YIC,YPIC --  Work vectors for DDASIC, each of length NEQ. */
/*     PWK --       Work vector for DDASIC of length NEQ. */
/*     WM,IWM --    Real and integer arrays storing */
/*                  information required by the linear solver. */
/*     EPCONI --    Test constant for Newton iteration convergence. */
/*     ICNFLG --    Flag showing whether constraints on Y are to apply. */
/*     ICNSTR --    Integer array of length NEQ with constraint types. */

/*     The other parameters are for use internally by DDASIC. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   DCOPY, NLSIC */

/* ***END PROLOGUE  DDASIC */




/* The following parameters are data-loaded here: */
/*     RHCUT  = factor by which H is reduced on retry of Newton solve. */
/*     RATEMX = maximum convergence rate for which Newton iteration */
/*              is considered converging. */

    /* Parameter adjustments */
    --y;
    --yprime;
    phi_dim1 = *neq;
    phi_offset = 1 + phi_dim1;
    phi -= phi_offset;
    --id;
    --wt;
    --rpar;
    --ipar;
    --savr;
    --delta;
    --e;
    --yic;
    --ypic;
    --pwk;
    --wm;
    --iwm;
    --icnstr;

    /* Function Body */


/* ----------------------------------------------------------------------- */
/*     BLOCK 1. */
/*     Initializations. */
/*     JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that */
/*     the initial call to the JAC routine is to be skipped then. */
/*     Save Y and YPRIME in PHI.  Initialize IDID, NH, and CJ. */
/* ----------------------------------------------------------------------- */

    mxnh = iwm[34];
    *idid = 1;
    nh = 1;
    jskip = 0;
    if (*nic == 2) {
	jskip = 1;
    }
    dcopy_(neq, &y[1], &c__1, &phi[phi_dim1 + 1], &c__1);
    dcopy_(neq, &yprime[1], &c__1, &phi[(phi_dim1 << 1) + 1], &c__1);

    if (*icopt == 2) {
	cj = 0.;
    } else {
	cj = 1. / *h__;
    }

/* ----------------------------------------------------------------------- */
/*     BLOCK 2 */
/*     Call the nonlinear system solver to obtain */
/*     consistent initial values for Y and YPRIME. */
/* ----------------------------------------------------------------------- */

L200:
    (*nlsic)(x, &y[1], &yprime[1], neq, icopt, &id[1], (U_fp)res, (U_fp)jac, (
	    U_fp)psol, h__, tscale, &wt[1], &jskip, &rpar[1], &ipar[1], &savr[
	    1], &delta[1], &e[1], &yic[1], &ypic[1], &pwk[1], &wm[1], &iwm[1],
	     &cj, uround, epli, sqrtn, rsqrtn, epconi, &ratemx, stptol, jflg, 
	    icnflg, &icnstr[1], &iernls);

    if (iernls == 0) {
	return 0;
    }

/* ----------------------------------------------------------------------- */
/*     BLOCK 3 */
/*     The nonlinear solver was unsuccessful.  Increment NCFN. */
/*     Return with IDID = -12 if either */
/*       IERNLS = -1: error is considered unrecoverable, */
/*       ICOPT = 2: we are doing initialization problem type 2, or */
/*       NH = MXNH: the maximum number of H values has been tried. */
/*     Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. */
/*     If IERNLS > 1, restore Y and YPRIME to their original values. */
/* ----------------------------------------------------------------------- */

    ++iwm[15];
    jskip = 0;

    if (iernls == -1) {
	goto L350;
    }
    if (*icopt == 2) {
	goto L350;
    }
    if (nh == mxnh) {
	goto L350;
    }

    ++nh;
    *h__ *= rhcut;
    cj = 1. / *h__;

    if (iernls == 1) {
	goto L200;
    }

    dcopy_(neq, &phi[phi_dim1 + 1], &c__1, &y[1], &c__1);
    dcopy_(neq, &phi[(phi_dim1 << 1) + 1], &c__1, &yprime[1], &c__1);
    goto L200;

L350:
    *idid = -12;
    return 0;

/* ------END OF SUBROUTINE DDASIC----------------------------------------- */
} /* ddasic_ */

/* Subroutine */ int dyypnw_(integer *neq, doublereal *y, doublereal *yprime, 
	doublereal *cj, doublereal *rl, doublereal *p, integer *icopt, 
	integer *id, doublereal *ynew, doublereal *ypnew)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer i__;


/* ***BEGIN PROLOGUE  DYYPNW */
/* ***REFER TO  DLINSK */
/* ***DATE WRITTEN   940830   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DYYPNW calculates the new (Y,YPRIME) pair needed in the */
/*     linesearch algorithm based on the current lambda value.  It is */
/*     called by DLINSK and DLINSD.  Based on the ICOPT and ID values, */
/*     the corresponding entry in Y or YPRIME is updated. */

/*     In addition to the parameters described in the calling programs, */
/*     the parameters represent */

/*     P      -- Array of length NEQ that contains the current */
/*               approximate Newton step. */
/*     RL     -- Scalar containing the current lambda value. */
/*     YNEW   -- Array of length NEQ containing the updated Y vector. */
/*     YPNEW  -- Array of length NEQ containing the updated YPRIME */
/*               vector. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED (NONE) */

/* ***END PROLOGUE  DYYPNW */



    /* Parameter adjustments */
    --ypnew;
    --ynew;
    --id;
    --p;
    --yprime;
    --y;

    /* Function Body */
    if (*icopt == 1) {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (id[i__] < 0) {
		ynew[i__] = y[i__] - *rl * p[i__];
		ypnew[i__] = yprime[i__];
	    } else {
		ynew[i__] = y[i__];
		ypnew[i__] = yprime[i__] - *rl * *cj * p[i__];
	    }
/* L10: */
	}
    } else {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ynew[i__] = y[i__] - *rl * p[i__];
	    ypnew[i__] = yprime[i__];
/* L20: */
	}
    }
    return 0;
/* ----------------------- END OF SUBROUTINE DYYPNW ---------------------- */
} /* dyypnw_ */

/* Subroutine */ int ddstp_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, U_fp res, U_fp jac, U_fp psol, doublereal *h__, 
	doublereal *wt, doublereal *vt, integer *jstart, integer *idid, 
	doublereal *rpar, integer *ipar, doublereal *phi, doublereal *savr, 
	doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, 
	doublereal *alpha, doublereal *beta, doublereal *gamma, doublereal *
	psi, doublereal *sigma, doublereal *cj, doublereal *cjold, doublereal 
	*hold, doublereal *s, doublereal *hmin, doublereal *uround, 
	doublereal *epli, doublereal *sqrtn, doublereal *rsqrtn, doublereal *
	epcon, integer *iphase, integer *jcalc, integer *jflg, integer *k, 
	integer *kold, integer *ns, integer *nonneg, integer *ntype, S_fp nls)
{
    /* System generated locals */
    integer phi_dim1, phi_offset, i__1, i__2;
    doublereal d__1, d__2;

    /* Builtin functions */
    double pow_dd(doublereal *, doublereal *);

    /* Local variables */
    integer i__, j;
    doublereal r__;
    integer j1;
    doublereal ck;
    integer km1, kp1, kp2, ncf, nef;
    doublereal erk, err, est;
    integer nsp1;
    doublereal hnew, terk, xold;
    integer knew;
    doublereal erkm1, erkm2, erkp1, temp1, temp2;
    integer kdiff;
    doublereal enorm, alpha0, terkm1, terkm2, terkp1, alphas;
    extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    doublereal *);
    doublereal cjlast;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    integer iernls;


/* ***BEGIN PROLOGUE  DDSTP */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  940909   (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DDSTP solves a system of differential/algebraic equations of */
/*     the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). */

/*     The methods used are modified divided difference, fixed leading */
/*     coefficient forms of backward differentiation formulas. */
/*     The code adjusts the stepsize and order to control the local error */
/*     per step. */


/*     The parameters represent */
/*     X  --        Independent variable. */
/*     Y  --        Solution vector at X. */
/*     YPRIME --    Derivative of solution vector */
/*                  after successful step. */
/*     NEQ --       Number of equations to be integrated. */
/*     RES --       External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     JAC --       External user-supplied routine to update */
/*                  Jacobian or preconditioner information in the */
/*                  nonlinear solver.  See JAC description in DDASPK */
/*                  prologue. */
/*     PSOL --      External user-supplied routine to solve */
/*                  a linear system using preconditioning. */
/*                  (This is optional).  See PSOL in DDASPK prologue. */
/*     H --         Appropriate step size for next step. */
/*                  Normally determined by the code. */
/*     WT --        Vector of weights for error criterion used in Newton test. */
/*     VT --        Masked vector of weights used in error test. */
/*     JSTART --    Integer variable set 0 for */
/*                  first step, 1 otherwise. */
/*     IDID --      Completion code returned from the nonlinear solver. */
/*                  See IDID description in DDASPK prologue. */
/*     RPAR,IPAR -- Real and integer parameter arrays that */
/*                  are used for communication between the */
/*                  calling program and external user routines. */
/*                  They are not altered by DNSK */
/*     PHI --       Array of divided differences used by */
/*                  DDSTP. The length is NEQ*(K+1), where */
/*                  K is the maximum order. */
/*     SAVR --      Work vector for DDSTP of length NEQ. */
/*     DELTA,E --   Work vectors for DDSTP of length NEQ. */
/*     WM,IWM --    Real and integer arrays storing */
/*                  information required by the linear solver. */

/*     The other parameters are information */
/*     which is needed internally by DDSTP to */
/*     continue from step to step. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   NLS, DDWNRM, DDATRP */

/* ***END PROLOGUE  DDSTP */





/* ----------------------------------------------------------------------- */
/*     BLOCK 1. */
/*     Initialize.  On the first call, set */
/*     the order to 1 and initialize */
/*     other variables. */
/* ----------------------------------------------------------------------- */

/*     Initializations for all calls */

    /* Parameter adjustments */
    --y;
    --yprime;
    phi_dim1 = *neq;
    phi_offset = 1 + phi_dim1;
    phi -= phi_offset;
    --wt;
    --vt;
    --rpar;
    --ipar;
    --savr;
    --delta;
    --e;
    --wm;
    --iwm;
    --alpha;
    --beta;
    --gamma;
    --psi;
    --sigma;

    /* Function Body */
    xold = *x;
    ncf = 0;
    nef = 0;
    if (*jstart != 0) {
	goto L120;
    }

/*     If this is the first step, perform */
/*     other initializations */

    *k = 1;
    *kold = 0;
    *hold = 0.;
    psi[1] = *h__;
    *cj = 1. / *h__;
    *iphase = 0;
    *ns = 0;
L120:





/* ----------------------------------------------------------------------- */
/*     BLOCK 2 */
/*     Compute coefficients of formulas for */
/*     this step. */
/* ----------------------------------------------------------------------- */
L200:
    kp1 = *k + 1;
    kp2 = *k + 2;
    km1 = *k - 1;
    if (*h__ != *hold || *k != *kold) {
	*ns = 0;
    }
/* Computing MIN */
    i__1 = *ns + 1, i__2 = *kold + 2;
    *ns = min(i__1,i__2);
    nsp1 = *ns + 1;
    if (kp1 < *ns) {
	goto L230;
    }

    beta[1] = 1.;
    alpha[1] = 1.;
    temp1 = *h__;
    gamma[1] = 0.;
    sigma[1] = 1.;
    i__1 = kp1;
    for (i__ = 2; i__ <= i__1; ++i__) {
	temp2 = psi[i__ - 1];
	psi[i__ - 1] = temp1;
	beta[i__] = beta[i__ - 1] * psi[i__ - 1] / temp2;
	temp1 = temp2 + *h__;
	alpha[i__] = *h__ / temp1;
	sigma[i__] = (i__ - 1) * sigma[i__ - 1] * alpha[i__];
	gamma[i__] = gamma[i__ - 1] + alpha[i__ - 1] / *h__;
/* L210: */
    }
    psi[kp1] = temp1;
L230:

/*     Compute ALPHAS, ALPHA0 */

    alphas = 0.;
    alpha0 = 0.;
    i__1 = *k;
    for (i__ = 1; i__ <= i__1; ++i__) {
	alphas -= 1. / i__;
	alpha0 -= alpha[i__];
/* L240: */
    }

/*     Compute leading coefficient CJ */

    cjlast = *cj;
    *cj = -alphas / *h__;

/*     Compute variable stepsize error coefficient CK */

    ck = (d__1 = alpha[kp1] + alphas - alpha0, abs(d__1));
/* Computing MAX */
    d__1 = ck, d__2 = alpha[kp1];
    ck = max(d__1,d__2);

/*     Change PHI to PHI STAR */

    if (kp1 < nsp1) {
	goto L280;
    }
    i__1 = kp1;
    for (j = nsp1; j <= i__1; ++j) {
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* L260: */
	    phi[i__ + j * phi_dim1] = beta[j] * phi[i__ + j * phi_dim1];
	}
/* L270: */
    }
L280:

/*     Update time */

    *x += *h__;

/*     Initialize IDID to 1 */

    *idid = 1;





/* ----------------------------------------------------------------------- */
/*     BLOCK 3 */
/*     Call the nonlinear system solver to obtain the solution and */
/*     derivative. */
/* ----------------------------------------------------------------------- */

    (*nls)(x, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, h__, &
	    wt[1], jstart, idid, &rpar[1], &ipar[1], &phi[phi_offset], &gamma[
	    1], &savr[1], &delta[1], &e[1], &wm[1], &iwm[1], cj, cjold, &
	    cjlast, s, uround, epli, sqrtn, rsqrtn, epcon, jcalc, jflg, &kp1, 
	    nonneg, ntype, &iernls);

    if (iernls != 0) {
	goto L600;
    }





/* ----------------------------------------------------------------------- */
/*     BLOCK 4 */
/*     Estimate the errors at orders K,K-1,K-2 */
/*     as if constant stepsize was used. Estimate */
/*     the local error at order K and test */
/*     whether the current step is successful. */
/* ----------------------------------------------------------------------- */

/*     Estimate errors at orders K,K-1,K-2 */

    enorm = ddwnrm_(neq, &e[1], &vt[1], &rpar[1], &ipar[1]);
    erk = sigma[*k + 1] * enorm;
    terk = (*k + 1) * erk;
    est = erk;
    knew = *k;
    if (*k == 1) {
	goto L430;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L405: */
	delta[i__] = phi[i__ + kp1 * phi_dim1] + e[i__];
    }
    erkm1 = sigma[*k] * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1]);
    terkm1 = *k * erkm1;
    if (*k > 2) {
	goto L410;
    }
    if (terkm1 <= terk * .5f) {
	goto L420;
    }
    goto L430;
L410:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L415: */
	delta[i__] = phi[i__ + *k * phi_dim1] + delta[i__];
    }
    erkm2 = sigma[*k - 1] * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1]
	    );
    terkm2 = (*k - 1) * erkm2;
    if (max(terkm1,terkm2) > terk) {
	goto L430;
    }

/*     Lower the order */

L420:
    knew = *k - 1;
    est = erkm1;


/*     Calculate the local error for the current step */
/*     to see if the step was successful */

L430:
    err = ck * enorm;
    if (err > 1.) {
	goto L600;
    }





/* ----------------------------------------------------------------------- */
/*     BLOCK 5 */
/*     The step is successful. Determine */
/*     the best order and stepsize for */
/*     the next step. Update the differences */
/*     for the next step. */
/* ----------------------------------------------------------------------- */
    *idid = 1;
    ++iwm[11];
    kdiff = *k - *kold;
    *kold = *k;
    *hold = *h__;


/*     Estimate the error at order K+1 unless */
/*        already decided to lower order, or */
/*        already using maximum order, or */
/*        stepsize not constant, or */
/*        order raised in previous step */

    if (knew == km1 || *k == iwm[3]) {
	*iphase = 1;
    }
    if (*iphase == 0) {
	goto L545;
    }
    if (knew == km1) {
	goto L540;
    }
    if (*k == iwm[3]) {
	goto L550;
    }
    if (kp1 >= *ns || kdiff == 1) {
	goto L550;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L510: */
	delta[i__] = e[i__] - phi[i__ + kp2 * phi_dim1];
    }
    erkp1 = 1. / (*k + 2) * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1]
	    );
    terkp1 = (*k + 2) * erkp1;
    if (*k > 1) {
	goto L520;
    }
    if (terkp1 >= terk * .5) {
	goto L550;
    }
    goto L530;
L520:
    if (terkm1 <= min(terk,terkp1)) {
	goto L540;
    }
    if (terkp1 >= terk || *k == iwm[3]) {
	goto L550;
    }

/*     Raise order */

L530:
    *k = kp1;
    est = erkp1;
    goto L550;

/*     Lower order */

L540:
    *k = km1;
    est = erkm1;
    goto L550;

/*     If IPHASE = 0, increase order by one and multiply stepsize by */
/*     factor two */

L545:
    *k = kp1;
    hnew = *h__ * 2.;
    *h__ = hnew;
    goto L575;


/*     Determine the appropriate stepsize for */
/*     the next step. */

L550:
    hnew = *h__;
    temp2 = (doublereal) (*k + 1);
    d__1 = est * 2. + 1e-4;
    d__2 = -1. / temp2;
    r__ = pow_dd(&d__1, &d__2);
    if (r__ < 2.) {
	goto L555;
    }
    hnew = *h__ * 2.;
    goto L560;
L555:
    if (r__ > 1.) {
	goto L560;
    }
/* Computing MAX */
    d__1 = .5, d__2 = min(.9,r__);
    r__ = max(d__1,d__2);
    hnew = *h__ * r__;
L560:
    *h__ = hnew;


/*     Update differences for next step */

L575:
    if (*kold == iwm[3]) {
	goto L585;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L580: */
	phi[i__ + kp2 * phi_dim1] = e[i__];
    }
L585:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L590: */
	phi[i__ + kp1 * phi_dim1] += e[i__];
    }
    i__1 = kp1;
    for (j1 = 2; j1 <= i__1; ++j1) {
	j = kp1 - j1 + 1;
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* L595: */
	    phi[i__ + j * phi_dim1] += phi[i__ + (j + 1) * phi_dim1];
	}
    }
    *jstart = 1;
    return 0;





/* ----------------------------------------------------------------------- */
/*     BLOCK 6 */
/*     The step is unsuccessful. Restore X,PSI,PHI */
/*     Determine appropriate stepsize for */
/*     continuing the integration, or exit with */
/*     an error flag if there have been many */
/*     failures. */
/* ----------------------------------------------------------------------- */
L600:
    *iphase = 1;

/*     Restore X,PHI,PSI */

    *x = xold;
    if (kp1 < nsp1) {
	goto L630;
    }
    i__2 = kp1;
    for (j = nsp1; j <= i__2; ++j) {
	temp1 = 1. / beta[j];
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L610: */
	    phi[i__ + j * phi_dim1] = temp1 * phi[i__ + j * phi_dim1];
	}
/* L620: */
    }
L630:
    i__2 = kp1;
    for (i__ = 2; i__ <= i__2; ++i__) {
/* L640: */
	psi[i__ - 1] = psi[i__] - *h__;
    }


/*     Test whether failure is due to nonlinear solver */
/*     or error test */

    if (iernls == 0) {
	goto L660;
    }
    ++iwm[15];


/*     The nonlinear solver failed to converge. */
/*     Determine the cause of the failure and take appropriate action. */
/*     If IERNLS .LT. 0, then return.  Otherwise, reduce the stepsize */
/*     and try again, unless too many failures have occurred. */

    if (iernls < 0) {
	goto L675;
    }
    ++ncf;
    r__ = .25;
    *h__ *= r__;
    if (ncf < 10 && abs(*h__) >= *hmin) {
	goto L690;
    }
    if (*idid == 1) {
	*idid = -7;
    }
    if (nef >= 3) {
	*idid = -9;
    }
    goto L675;


/*     The nonlinear solver converged, and the cause */
/*     of the failure was the error estimate */
/*     exceeding the tolerance. */

L660:
    ++nef;
    ++iwm[14];
    if (nef > 1) {
	goto L665;
    }

/*     On first error test failure, keep current order or lower */
/*     order by one.  Compute new stepsize based on differences */
/*     of the solution. */

    *k = knew;
    temp2 = (doublereal) (*k + 1);
    d__1 = est * 2. + 1e-4;
    d__2 = -1. / temp2;
    r__ = pow_dd(&d__1, &d__2) * .9;
/* Computing MAX */
    d__1 = .25, d__2 = min(.9,r__);
    r__ = max(d__1,d__2);
    *h__ *= r__;
    if (abs(*h__) >= *hmin) {
	goto L690;
    }
    *idid = -6;
    goto L675;

/*     On second error test failure, use the current order or */
/*     decrease order by one.  Reduce the stepsize by a factor of */
/*     one quarter. */

L665:
    if (nef > 2) {
	goto L670;
    }
    *k = knew;
    r__ = .25;
    *h__ = r__ * *h__;
    if (abs(*h__) >= *hmin) {
	goto L690;
    }
    *idid = -6;
    goto L675;

/*     On third and subsequent error test failures, set the order to */
/*     one, and reduce the stepsize by a factor of one quarter. */

L670:
    *k = 1;
    r__ = .25;
    *h__ = r__ * *h__;
    if (abs(*h__) >= *hmin) {
	goto L690;
    }
    *idid = -6;
    goto L675;




/*     For all crashes, restore Y to its last value, */
/*     interpolate to find YPRIME at last X, and return. */

/*     Before returning, verify that the user has not set */
/*     IDID to a nonnegative value.  If the user has set IDID */
/*     to a nonnegative value, then reset IDID to be -7, indicating */
/*     a failure in the nonlinear system solver. */

L675:
    ddatrp_(x, x, &y[1], &yprime[1], neq, k, &phi[phi_offset], &psi[1]);
    *jstart = 1;
    if (*idid >= 0) {
	*idid = -7;
    }
    return 0;


/*     Go back and try this step again. */
/*     If this is the first step, reset PSI(1) and rescale PHI(*,2). */

L690:
    if (*kold == 0) {
	psi[1] = *h__;
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* L695: */
	    phi[i__ + (phi_dim1 << 1)] = r__ * phi[i__ + (phi_dim1 << 1)];
	}
    }
    goto L200;

/* ------END OF SUBROUTINE DDSTP------------------------------------------ */
} /* ddstp_ */

/* Subroutine */ int dcnstr_(integer *neq, doublereal *y, doublereal *ynew, 
	integer *icnstr, doublereal *tau, doublereal *rlx, integer *iret, 
	integer *ivar)
{
    /* Initialized data */

    static doublereal fac = .6;
    static doublereal fac2 = .9;
    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1;
    doublereal d__1;

    /* Local variables */
    integer i__;
    doublereal rdy, rdymx;


/* ***BEGIN PROLOGUE  DCNSTR */
/* ***DATE WRITTEN   950808   (YYMMDD) */
/* ***REVISION DATE  950814   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* This subroutine checks for constraint violations in the proposed */
/* new approximate solution YNEW. */
/* If a constraint violation occurs, then a new step length, TAU, */
/* is calculated, and this value is to be given to the linesearch routine */
/* to calculate a new approximate solution YNEW. */

/* On entry: */

/*   NEQ    -- size of the nonlinear system, and the length of arrays */
/*             Y, YNEW and ICNSTR. */

/*   Y      -- real array containing the current approximate y. */

/*   YNEW   -- real array containing the new approximate y. */

/*   ICNSTR -- INTEGER array of length NEQ containing flags indicating */
/*             which entries in YNEW are to be constrained. */
/*             if ICNSTR(I) =  2, then YNEW(I) must be .GT. 0, */
/*             if ICNSTR(I) =  1, then YNEW(I) must be .GE. 0, */
/*             if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while */
/*             if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while */
/*             if ICNSTR(I) =  0, then YNEW(I) is not constrained. */

/*   RLX    -- real scalar restricting update, if ICNSTR(I) = 2 or -2, */
/*             to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. */

/*   TAU    -- the current size of the step length for the linesearch. */

/* On return */

/*   TAU    -- the adjusted size of the step length if a constraint */
/*             violation occurred (otherwise, it is unchanged).  it is */
/*             the step length to give to the linesearch routine. */

/*   IRET   -- output flag. */
/*             IRET=0 means that YNEW satisfied all constraints. */
/*             IRET=1 means that YNEW failed to satisfy all the */
/*                    constraints, and a new linesearch step */
/*                    must be computed. */

/*   IVAR   -- index of variable causing constraint to be violated. */

/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --icnstr;
    --ynew;
    --y;

    /* Function Body */
/* ----------------------------------------------------------------------- */
/* Check constraints for proposed new step YNEW.  If a constraint has */
/* been violated, then calculate a new step length, TAU, to be */
/* used in the linesearch routine. */
/* ----------------------------------------------------------------------- */
    *iret = 0;
    rdymx = zero;
    *ivar = 0;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {

	if (icnstr[i__] == 2) {
	    rdy = (d__1 = (ynew[i__] - y[i__]) / y[i__], abs(d__1));
	    if (rdy > rdymx) {
		rdymx = rdy;
		*ivar = i__;
	    }
	    if (ynew[i__] <= zero) {
		*tau = fac * *tau;
		*ivar = i__;
		*iret = 1;
		return 0;
	    }

	} else if (icnstr[i__] == 1) {
	    if (ynew[i__] < zero) {
		*tau = fac * *tau;
		*ivar = i__;
		*iret = 1;
		return 0;
	    }

	} else if (icnstr[i__] == -1) {
	    if (ynew[i__] > zero) {
		*tau = fac * *tau;
		*ivar = i__;
		*iret = 1;
		return 0;
	    }

	} else if (icnstr[i__] == -2) {
	    rdy = (d__1 = (ynew[i__] - y[i__]) / y[i__], abs(d__1));
	    if (rdy > rdymx) {
		rdymx = rdy;
		*ivar = i__;
	    }
	    if (ynew[i__] >= zero) {
		*tau = fac * *tau;
		*ivar = i__;
		*iret = 1;
		return 0;
	    }

	}
/* L100: */
    }
    if (rdymx >= *rlx) {
	*tau = fac2 * *tau * *rlx / rdymx;
	*iret = 1;
    }

    return 0;
/* ----------------------- END OF SUBROUTINE DCNSTR ---------------------- */
} /* dcnstr_ */

/* Subroutine */ int dcnst0_(integer *neq, doublereal *y, integer *icnstr, 
	integer *iret)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer i__;


/* ***BEGIN PROLOGUE  DCNST0 */
/* ***DATE WRITTEN   950808   (YYMMDD) */
/* ***REVISION DATE  950808   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* This subroutine checks for constraint violations in the initial */
/* approximate solution u. */

/* On entry */

/*   NEQ    -- size of the nonlinear system, and the length of arrays */
/*             Y and ICNSTR. */

/*   Y      -- real array containing the initial approximate root. */

/*   ICNSTR -- INTEGER array of length NEQ containing flags indicating */
/*             which entries in Y are to be constrained. */
/*             if ICNSTR(I) =  2, then Y(I) must be .GT. 0, */
/*             if ICNSTR(I) =  1, then Y(I) must be .GE. 0, */
/*             if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while */
/*             if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while */
/*             if ICNSTR(I) =  0, then Y(I) is not constrained. */

/* On return */

/*   IRET   -- output flag. */
/*             IRET=0    means that u satisfied all constraints. */
/*             IRET.NE.0 means that Y(IRET) failed to satisfy its */
/*                       constraint. */

/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --icnstr;
    --y;

    /* Function Body */
/* ----------------------------------------------------------------------- */
/* Check constraints for initial Y.  If a constraint has been violated, */
/* set IRET = I to signal an error return to calling routine. */
/* ----------------------------------------------------------------------- */
    *iret = 0;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (icnstr[i__] == 2) {
	    if (y[i__] <= zero) {
		*iret = i__;
		return 0;
	    }
	} else if (icnstr[i__] == 1) {
	    if (y[i__] < zero) {
		*iret = i__;
		return 0;
	    }
	} else if (icnstr[i__] == -1) {
	    if (y[i__] > zero) {
		*iret = i__;
		return 0;
	    }
	} else if (icnstr[i__] == -2) {
	    if (y[i__] >= zero) {
		*iret = i__;
		return 0;
	    }
	}
/* L100: */
    }
    return 0;
/* ----------------------- END OF SUBROUTINE DCNST0 ---------------------- */
} /* dcnst0_ */

/* Subroutine */ int ddawts_(integer *neq, integer *iwt, doublereal *rtol, 
	doublereal *atol, doublereal *y, doublereal *wt, doublereal *rpar, 
	integer *ipar)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1;

    /* Local variables */
    integer i__;
    doublereal atoli, rtoli;


/* ***BEGIN PROLOGUE  DDAWTS */
/* ***REFER TO  DDASPK */
/* ***ROUTINES CALLED  (NONE) */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***END PROLOGUE  DDAWTS */
/* ----------------------------------------------------------------------- */
/*     This subroutine sets the error weight vector, */
/*     WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), */
/*     I = 1 to NEQ. */
/*     RTOL and ATOL are scalars if IWT = 0, */
/*     and vectors if IWT = 1. */
/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    --ipar;
    --rpar;
    --wt;
    --y;
    --atol;
    --rtol;

    /* Function Body */
    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*iwt == 0) {
	    goto L10;
	}
	rtoli = rtol[i__];
	atoli = atol[i__];
L10:
	wt[i__] = rtoli * (d__1 = y[i__], abs(d__1)) + atoli;
/* L20: */
    }
    return 0;

/* ------END OF SUBROUTINE DDAWTS----------------------------------------- */
} /* ddawts_ */

/* Subroutine */ int dinvwt_(integer *neq, doublereal *wt, integer *ier)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer i__;


/* ***BEGIN PROLOGUE  DINVWT */
/* ***REFER TO  DDASPK */
/* ***ROUTINES CALLED  (NONE) */
/* ***DATE WRITTEN   950125   (YYMMDD) */
/* ***END PROLOGUE  DINVWT */
/* ----------------------------------------------------------------------- */
/*     This subroutine checks the error weight vector WT, of length NEQ, */
/*     for components that are .le. 0, and if none are found, it */
/*     inverts the WT(I) in place.  This replaces division operations */
/*     with multiplications in all norm evaluations. */
/*     IER is returned as 0 if all WT(I) were found positive, */
/*     and the first I with WT(I) .le. 0.0 otherwise. */
/* ----------------------------------------------------------------------- */


    /* Parameter adjustments */
    --wt;

    /* Function Body */
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (wt[i__] <= 0.) {
	    goto L30;
	}
/* L10: */
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
	wt[i__] = 1. / wt[i__];
    }
    *ier = 0;
    return 0;

L30:
    *ier = i__;
    return 0;

/* ------END OF SUBROUTINE DINVWT----------------------------------------- */
} /* dinvwt_ */

/* Subroutine */ int ddatrp_(doublereal *x, doublereal *xout, doublereal *
	yout, doublereal *ypout, integer *neq, integer *kold, doublereal *phi,
	 doublereal *psi)
{
    /* System generated locals */
    integer phi_dim1, phi_offset, i__1, i__2;

    /* Local variables */
    doublereal c__, d__;
    integer i__, j;
    doublereal temp1, gamma;
    integer koldp1;


/* ***BEGIN PROLOGUE  DDATRP */
/* ***REFER TO  DDASPK */
/* ***ROUTINES CALLED  (NONE) */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***END PROLOGUE  DDATRP */

/* ----------------------------------------------------------------------- */
/*     The methods in subroutine DDSTP use polynomials */
/*     to approximate the solution.  DDATRP approximates the */
/*     solution and its derivative at time XOUT by evaluating */
/*     one of these polynomials, and its derivative, there. */
/*     Information defining this polynomial is passed from */
/*     DDSTP, so DDATRP cannot be used alone. */

/*     The parameters are */

/*     X     The current time in the integration. */
/*     XOUT  The time at which the solution is desired. */
/*     YOUT  The interpolated approximation to Y at XOUT. */
/*           (This is output.) */
/*     YPOUT The interpolated approximation to YPRIME at XOUT. */
/*           (This is output.) */
/*     NEQ   Number of equations. */
/*     KOLD  Order used on last successful step. */
/*     PHI   Array of scaled divided differences of Y. */
/*     PSI   Array of past stepsize history. */
/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    --yout;
    --ypout;
    phi_dim1 = *neq;
    phi_offset = 1 + phi_dim1;
    phi -= phi_offset;
    --psi;

    /* Function Body */
    koldp1 = *kold + 1;
    temp1 = *xout - *x;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yout[i__] = phi[i__ + phi_dim1];
/* L10: */
	ypout[i__] = 0.;
    }
    c__ = 1.;
    d__ = 0.;
    gamma = temp1 / psi[1];
    i__1 = koldp1;
    for (j = 2; j <= i__1; ++j) {
	d__ = d__ * gamma + c__ / psi[j - 1];
	c__ *= gamma;
	gamma = (temp1 + psi[j - 1]) / psi[j];
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    yout[i__] += c__ * phi[i__ + j * phi_dim1];
/* L20: */
	    ypout[i__] += d__ * phi[i__ + j * phi_dim1];
	}
/* L30: */
    }
    return 0;

/* ------END OF SUBROUTINE DDATRP----------------------------------------- */
} /* ddatrp_ */

doublereal ddwnrm_(integer *neq, doublereal *v, doublereal *rwt, doublereal *
	rpar, integer *ipar)
{
    /* System generated locals */
    integer i__1;
    doublereal ret_val, d__1, d__2;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    integer i__;
    doublereal sum, vmax;


/* ***BEGIN PROLOGUE  DDWNRM */
/* ***ROUTINES CALLED  (NONE) */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***END PROLOGUE  DDWNRM */
/* ----------------------------------------------------------------------- */
/*     This function routine computes the weighted */
/*     root-mean-square norm of the vector of length */
/*     NEQ contained in the array V, with reciprocal weights */
/*     contained in the array RWT of length NEQ. */
/*        DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) */
/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    --ipar;
    --rpar;
    --rwt;
    --v;

    /* Function Body */
    ret_val = 0.;
    vmax = 0.;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = v[i__] * rwt[i__], abs(d__1)) > vmax) {
	    vmax = (d__2 = v[i__] * rwt[i__], abs(d__2));
	}
/* L10: */
    }
    if (vmax <= 0.) {
	goto L30;
    }
    sum = 0.;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
/* Computing 2nd power */
	d__1 = v[i__] * rwt[i__] / vmax;
	sum += d__1 * d__1;
    }
    ret_val = vmax * sqrt(sum / *neq);
L30:
    return ret_val;

/* ------END OF FUNCTION DDWNRM------------------------------------------- */
} /* ddwnrm_ */

/* Subroutine */ int ddasid_(doublereal *x, doublereal *y, doublereal *yprime,
	 integer *neq, integer *icopt, integer *id, S_fp res, U_fp jacd, 
	doublereal *pdum, doublereal *h__, doublereal *tscale, doublereal *wt,
	 integer *jsdum, doublereal *rpar, integer *ipar, doublereal *dumsvr, 
	doublereal *delta, doublereal *r__, doublereal *yic, doublereal *ypic,
	 doublereal *dumpwk, doublereal *wm, integer *iwm, doublereal *cj, 
	doublereal *uround, doublereal *dume, doublereal *dums, doublereal *
	dumr, doublereal *epcon, doublereal *ratemx, doublereal *stptol, 
	integer *jfdum, integer *icnflg, integer *icnstr, integer *iernls)
{
    integer nj, ierj, ires, mxnj;
    extern /* Subroutine */ int dmatd_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     doublereal *, doublereal *, doublereal *, integer *, S_fp, 
	    integer *, doublereal *, U_fp, doublereal *, integer *), dnsid_(
	    doublereal *, doublereal *, doublereal *, integer *, integer *, 
	    integer *, S_fp, doublereal *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     doublereal *, integer *, doublereal *, integer *, integer *, 
	    integer *);
    integer mxnit, iernew;


/* ***BEGIN PROLOGUE  DDASID */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   940701   (YYMMDD) */
/* ***REVISION DATE  950808   (YYMMDD) */
/* ***REVISION DATE  951110   Removed unreachable block 390. */
/* ***REVISION DATE  000628   TSCALE argument added. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */


/*     DDASID solves a nonlinear system of algebraic equations of the */
/*     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */
/*     the initial conditions. */

/*     The method used is a modified Newton scheme. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of unknowns. */
/*     ICOPT     -- Initial condition option chosen (1 or 2). */
/*     ID        -- Array of dimension NEQ, which must be initialized */
/*                  if ICOPT = 1.  See DDASIC. */
/*     RES       -- External user-supplied subroutine to evaluate the */
/*                  residual.  See RES description in DDASPK prologue. */
/*     JACD      -- External user-supplied routine to evaluate the */
/*                  Jacobian.  See JAC description for the case */
/*                  INFO(12) = 0 in the DDASPK prologue. */
/*     PDUM      -- Dummy argument. */
/*     H         -- Scaling factor for this initial condition calc. */
/*     TSCALE    -- Scale factor in T, used for stopping tests if nonzero. */
/*     WT        -- Vector of weights for error criterion. */
/*     JSDUM     -- Dummy argument. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     DUMSVR    -- Dummy argument. */
/*     DELTA     -- Work vector for NLS of length NEQ. */
/*     R         -- Work vector for NLS of length NEQ. */
/*     YIC,YPIC  -- Work vectors for NLS, each of length NEQ. */
/*     DUMPWK    -- Dummy argument. */
/*     WM,IWM    -- Real and integer arrays storing matrix information */
/*                  such as the matrix of partial derivatives, */
/*                  permutation vector, and various other information. */
/*     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */
/*     UROUND    -- Unit roundoff. */
/*     DUME      -- Dummy argument. */
/*     DUMS      -- Dummy argument. */
/*     DUMR      -- Dummy argument. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     RATEMX    -- Maximum convergence rate for which Newton iteration */
/*                  is considered converging. */
/*     JFDUM     -- Dummy argument. */
/*     STPTOL    -- Tolerance used in calculating the minimum lambda */
/*                  value allowed. */
/*     ICNFLG    -- Integer scalar.  If nonzero, then constraint */
/*                  violations in the proposed new approximate solution */
/*                  will be checked for, and the maximum step length */
/*                  will be adjusted accordingly. */
/*     ICNSTR    -- Integer array of length NEQ containing flags for */
/*                  checking constraints. */
/*     IERNLS    -- Error flag for nonlinear solver. */
/*                   0   ==> nonlinear solver converged. */
/*                   1,2 ==> recoverable error inside nonlinear solver. */
/*                           1 => retry with current Y, YPRIME */
/*                           2 => retry with original Y, YPRIME */
/*                  -1   ==> unrecoverable error in nonlinear solver. */

/*     All variables with "DUM" in their names are dummy variables */
/*     which are not used in this routine. */

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

/* ***ROUTINES CALLED */
/*   RES, DMATD, DNSID */

/* ***END PROLOGUE  DDASID */





/*     Perform initializations. */

    /* Parameter adjustments */
    --icnstr;
    --iwm;
    --wm;
    --ypic;
    --yic;
    --r__;
    --delta;
    --ipar;
    --rpar;
    --wt;
    --id;
    --yprime;
    --y;

    /* Function Body */
    mxnit = iwm[32];
    mxnj = iwm[33];
    *iernls = 0;
    nj = 0;

/*     Call RES to initialize DELTA. */

    ires = 0;
    ++iwm[12];
    (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ires < 0) {
	goto L370;
    }

/*     Looping point for updating the Jacobian. */

L300:

/*     Initialize all error flags to zero. */

    ierj = 0;
    ires = 0;
    iernew = 0;

/*     Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, */
/*     where G(X,Y,YPRIME) = 0. */

    ++nj;
    ++iwm[13];
    dmatd_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ierj, &wt[1], &r__[
	    1], &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jacd, &rpar[
	    1], &ipar[1]);
    if (ires < 0 || ierj != 0) {
	goto L370;
    }

/*     Call the nonlinear Newton solver for up to MXNIT iterations. */

    dnsid_(x, &y[1], &yprime[1], neq, icopt, &id[1], (S_fp)res, &wt[1], &rpar[
	    1], &ipar[1], &delta[1], &r__[1], &yic[1], &ypic[1], &wm[1], &iwm[
	    1], cj, tscale, epcon, ratemx, &mxnit, stptol, icnflg, &icnstr[1],
	     &iernew);

    if (iernew == 1 && nj < mxnj) {

/*        MXNIT iterations were done, the convergence rate is < 1, */
/*        and the number of Jacobian evaluations is less than MXNJ. */
/*        Call RES, reevaluate the Jacobian, and try again. */

	++iwm[12];
	(*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1])
		;
	if (ires < 0) {
	    goto L370;
	}
	goto L300;
    }

    if (iernew != 0) {
	goto L380;
    }
    return 0;


/*     Unsuccessful exits from nonlinear solver. */
/*     Compute IERNLS accordingly. */

L370:
    *iernls = 2;
    if (ires <= -2) {
	*iernls = -1;
    }
    return 0;

L380:
    *iernls = min(iernew,2);
    return 0;

/* ------END OF SUBROUTINE DDASID----------------------------------------- */
} /* ddasid_ */

/* Subroutine */ int dnsid_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, integer *icopt, integer *id, S_fp res, doublereal *wt, 
	doublereal *rpar, integer *ipar, doublereal *delta, doublereal *r__, 
	doublereal *yic, doublereal *ypic, doublereal *wm, integer *iwm, 
	doublereal *cj, doublereal *tscale, doublereal *epcon, doublereal *
	ratemx, integer *maxit, doublereal *stptol, integer *icnflg, integer *
	icnstr, integer *iernew)
{
    integer m;
    doublereal rlx, rate, fnrm;
    integer iret, ires, lsoff;
    extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, 
	    integer *), dcopy_(integer *, doublereal *, integer *, doublereal 
	    *, integer *), dlinsd_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    S_fp, integer *, doublereal *, integer *, doublereal *, integer *,
	     integer *, doublereal *, doublereal *, doublereal *, integer *, 
	    integer *, doublereal *, doublereal *, integer *);
    doublereal oldfnm, delnrm;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);


/* ***BEGIN PROLOGUE  DNSID */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   940701   (YYMMDD) */
/* ***REVISION DATE  950713   (YYMMDD) */
/* ***REVISION DATE  000628   TSCALE argument added. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DNSID solves a nonlinear system of algebraic equations of the */
/*     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME */
/*     in the initial conditions. */

/*     The method used is a modified Newton scheme. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of unknowns. */
/*     ICOPT     -- Initial condition option chosen (1 or 2). */
/*     ID        -- Array of dimension NEQ, which must be initialized */
/*                  if ICOPT = 1.  See DDASIC. */
/*     RES       -- External user-supplied subroutine to evaluate the */
/*                  residual.  See RES description in DDASPK prologue. */
/*     WT        -- Vector of weights for error criterion. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     DELTA     -- Residual vector on entry, and work vector of */
/*                  length NEQ for DNSID. */
/*     WM,IWM    -- Real and integer arrays storing matrix information */
/*                  such as the matrix of partial derivatives, */
/*                  permutation vector, and various other information. */
/*     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */
/*     TSCALE    -- Scale factor in T, used for stopping tests if nonzero. */
/*     R         -- Array of length NEQ used as workspace by the */
/*                  linesearch routine DLINSD. */
/*     YIC,YPIC  -- Work vectors for DLINSD, each of length NEQ. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     RATEMX    -- Maximum convergence rate for which Newton iteration */
/*                  is considered converging. */
/*     MAXIT     -- Maximum allowed number of Newton iterations. */
/*     STPTOL    -- Tolerance used in calculating the minimum lambda */
/*                  value allowed. */
/*     ICNFLG    -- Integer scalar.  If nonzero, then constraint */
/*                  violations in the proposed new approximate solution */
/*                  will be checked for, and the maximum step length */
/*                  will be adjusted accordingly. */
/*     ICNSTR    -- Integer array of length NEQ containing flags for */
/*                  checking constraints. */
/*     IERNEW    -- Error flag for Newton iteration. */
/*                   0  ==> Newton iteration converged. */
/*                   1  ==> failed to converge, but RATE .le. RATEMX. */
/*                   2  ==> failed to converge, RATE .gt. RATEMX. */
/*                   3  ==> other recoverable error (IRES = -1, or */
/*                          linesearch failed). */
/*                  -1  ==> unrecoverable error (IRES = -2). */

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

/* ***ROUTINES CALLED */
/*   DSLVD, DDWNRM, DLINSD, DCOPY */

/* ***END PROLOGUE  DNSID */





/*     Initializations.  M is the Newton iteration counter. */

    /* Parameter adjustments */
    --icnstr;
    --iwm;
    --wm;
    --ypic;
    --yic;
    --r__;
    --delta;
    --ipar;
    --rpar;
    --wt;
    --id;
    --yprime;
    --y;

    /* Function Body */
    lsoff = iwm[35];
    m = 0;
    rate = 1.;
    rlx = .4;

/*     Compute a new step vector DELTA by back-substitution. */

    dslvd_(neq, &delta[1], &wm[1], &iwm[1]);

/*     Get norm of DELTA.  Return now if norm(DELTA) .le. EPCON. */

    delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    fnrm = delnrm;
    if (*tscale > 0.) {
	fnrm = fnrm * *tscale * abs(*cj);
    }
    if (fnrm <= *epcon) {
	return 0;
    }

/*     Newton iteration loop. */

L300:
    ++iwm[19];

/*     Call linesearch routine for global strategy and set RATE */

    oldfnm = fnrm;

    dlinsd_(neq, &y[1], x, &yprime[1], cj, tscale, &delta[1], &delnrm, &wt[1],
	     &lsoff, stptol, &iret, (S_fp)res, &ires, &wm[1], &iwm[1], &fnrm, 
	    icopt, &id[1], &r__[1], &yic[1], &ypic[1], icnflg, &icnstr[1], &
	    rlx, &rpar[1], &ipar[1]);

    rate = fnrm / oldfnm;

/*     Check for error condition from linesearch. */
    if (iret != 0) {
	goto L390;
    }

/*     Test for convergence of the iteration, and return or loop. */

    if (fnrm <= *epcon) {
	return 0;
    }

/*     The iteration has not yet converged.  Update M. */
/*     Test whether the maximum number of iterations have been tried. */

    ++m;
    if (m >= *maxit) {
	goto L380;
    }

/*     Copy the residual to DELTA and its norm to DELNRM, and loop for */
/*     another iteration. */

    dcopy_(neq, &r__[1], &c__1, &delta[1], &c__1);
    delnrm = fnrm;
    goto L300;

/*     The maximum number of iterations was done.  Set IERNEW and return. */

L380:
    if (rate <= *ratemx) {
	*iernew = 1;
    } else {
	*iernew = 2;
    }
    return 0;

L390:
    if (ires <= -2) {
	*iernew = -1;
    } else {
	*iernew = 3;
    }
    return 0;


/* ------END OF SUBROUTINE DNSID------------------------------------------ */
} /* dnsid_ */

/* Subroutine */ int dlinsd_(integer *neq, doublereal *y, doublereal *t, 
	doublereal *yprime, doublereal *cj, doublereal *tscale, doublereal *p,
	 doublereal *pnrm, doublereal *wt, integer *lsoff, doublereal *stptol,
	 integer *iret, S_fp res, integer *ires, doublereal *wm, integer *iwm,
	 doublereal *fnrm, integer *icopt, integer *id, doublereal *r__, 
	doublereal *ynew, doublereal *ypnew, integer *icnflg, integer *icnstr,
	 doublereal *rlx, doublereal *rpar, integer *ipar)
{
    /* Initialized data */

    static doublereal alpha = 1e-4;
    static doublereal one = 1.;
    static doublereal two = 2.;

    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    integer i__;
    doublereal rl;
    char msg[80];
    doublereal tau;
    integer ivar;
    doublereal slpi, f1nrm, ratio;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    doublereal rlmin, fnrmp;
    integer kprin;
    doublereal ratio1, f1nrmp;
    extern /* Subroutine */ int dfnrmd_(integer *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, S_fp, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *), dcnstr_(integer *, 
	    doublereal *, doublereal *, integer *, doublereal *, doublereal *,
	     integer *, integer *), xerrwd_(char *, integer *, integer *, 
	    integer *, integer *, integer *, integer *, integer *, doublereal 
	    *, doublereal *, ftnlen), dyypnw_(integer *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     integer *, doublereal *, doublereal *);


/* ***BEGIN PROLOGUE  DLINSD */
/* ***REFER TO  DNSID */
/* ***DATE WRITTEN   941025   (YYMMDD) */
/* ***REVISION DATE  941215   (YYMMDD) */
/* ***REVISION DATE  960129   Moved line RL = ONE to top block. */
/* ***REVISION DATE  000628   TSCALE argument added. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) */
/*     pair (YNEW,YPNEW) such that */

/*     f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , */

/*     where 0 < RL <= 1.  Here, f(y,y') is defined as */

/*      f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , */

/*     where norm() is the weighted RMS vector norm, G is the DAE */
/*     system residual function, and J is the system iteration matrix */
/*     (Jacobian). */

/*     In addition to the parameters defined elsewhere, we have */

/*     TSCALE  --  Scale factor in T, used for stopping tests if nonzero. */
/*     P       -- Approximate Newton step used in backtracking. */
/*     PNRM    -- Weighted RMS norm of P. */
/*     LSOFF   -- Flag showing whether the linesearch algorithm is */
/*                to be invoked.  0 means do the linesearch, and */
/*                1 means turn off linesearch. */
/*     STPTOL  -- Tolerance used in calculating the minimum lambda */
/*                value allowed. */
/*     ICNFLG  -- Integer scalar.  If nonzero, then constraint violations */
/*                in the proposed new approximate solution will be */
/*                checked for, and the maximum step length will be */
/*                adjusted accordingly. */
/*     ICNSTR  -- Integer array of length NEQ containing flags for */
/*                checking constraints. */
/*     RLX     -- Real scalar restricting update size in DCNSTR. */
/*     YNEW    -- Array of length NEQ used to hold the new Y in */
/*                performing the linesearch. */
/*     YPNEW   -- Array of length NEQ used to hold the new YPRIME in */
/*                performing the linesearch. */
/*     Y       -- Array of length NEQ containing the new Y (i.e.,=YNEW). */
/*     YPRIME  -- Array of length NEQ containing the new YPRIME */
/*                (i.e.,=YPNEW). */
/*     FNRM    -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the */
/*                current (Y,YPRIME) on input and output. */
/*     R       -- Work array of length NEQ, containing the scaled */
/*                residual (J-inverse)*G(t,y,y') on return. */
/*     IRET    -- Return flag. */
/*                IRET=0 means that a satisfactory (Y,YPRIME) was found. */
/*                IRET=1 means that the routine failed to find a new */
/*                       (Y,YPRIME) that was sufficiently distinct from */
/*                       the current (Y,YPRIME) pair. */
/*                IRET=2 means IRES .ne. 0 from RES. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD */

/* ***END PROLOGUE  DLINSD */



    /* Parameter adjustments */
    --ipar;
    --rpar;
    --icnstr;
    --ypnew;
    --ynew;
    --r__;
    --id;
    --iwm;
    --wm;
    --wt;
    --p;
    --yprime;
    --y;

    /* Function Body */

    kprin = iwm[31];

    f1nrm = *fnrm * *fnrm / two;
    ratio = one;
    if (kprin >= 2) {
	s_copy(msg, "------ IN ROUTINE DLINSD-- PNRM = (R1)", (ftnlen)80, (
		ftnlen)38);
	xerrwd_(msg, &c__38, &c__901, &c__0, &c__0, &c__0, &c__0, &c__1, pnrm,
		 &c_b37, (ftnlen)80);
    }
    tau = *pnrm;
    rl = one;
/* ----------------------------------------------------------------------- */
/* Check for violations of the constraints, if any are imposed. */
/* If any violations are found, the step vector P is rescaled, and the */
/* constraint check is repeated, until no violations are found. */
/* ----------------------------------------------------------------------- */
    if (*icnflg != 0) {
L10:
	dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[
		1], &ypnew[1]);
	dcnstr_(neq, &y[1], &ynew[1], &icnstr[1], &tau, rlx, iret, &ivar);
	if (*iret == 1) {
	    ratio1 = tau / *pnrm;
	    ratio *= ratio1;
	    i__1 = *neq;
	    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
		p[i__] *= ratio1;
	    }
	    *pnrm = tau;
	    if (kprin >= 2) {
		s_copy(msg, "------ CONSTRAINT VIOL., PNRM = (R1), INDEX = ("
			"I1)", (ftnlen)80, (ftnlen)50);
		xerrwd_(msg, &c__50, &c__902, &c__0, &c__1, &ivar, &c__0, &
			c__1, pnrm, &c_b37, (ftnlen)80);
	    }
	    if (*pnrm <= *stptol) {
		*iret = 1;
		return 0;
	    }
	    goto L10;
	}
    }

    slpi = -two * f1nrm * ratio;
    rlmin = *stptol / *pnrm;
    if (*lsoff == 0 && kprin >= 2) {
	s_copy(msg, "------ MIN. LAMBDA = (R1)", (ftnlen)80, (ftnlen)25);
	xerrwd_(msg, &c__25, &c__903, &c__0, &c__0, &c__0, &c__0, &c__1, &
		rlmin, &c_b37, (ftnlen)80);
    }
/* ----------------------------------------------------------------------- */
/* Begin iteration to find RL value satisfying alpha-condition. */
/* If RL becomes less than RLMIN, then terminate with IRET = 1. */
/* ----------------------------------------------------------------------- */
L100:
    dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[1], &
	    ypnew[1]);
    dfnrmd_(neq, &ynew[1], t, &ypnew[1], &r__[1], cj, tscale, &wt[1], (S_fp)
	    res, ires, &fnrmp, &wm[1], &iwm[1], &rpar[1], &ipar[1]);
    ++iwm[12];
    if (*ires != 0) {
	*iret = 2;
	return 0;
    }
    if (*lsoff == 1) {
	goto L150;
    }

    f1nrmp = fnrmp * fnrmp / two;
    if (kprin >= 2) {
	s_copy(msg, "------ LAMBDA = (R1)", (ftnlen)80, (ftnlen)20);
	xerrwd_(msg, &c__20, &c__904, &c__0, &c__0, &c__0, &c__0, &c__1, &rl, 
		&c_b37, (ftnlen)80);
	s_copy(msg, "------ NORM(F1) = (R1),  NORM(F1NEW) = (R2)", (ftnlen)80,
		 (ftnlen)43);
	xerrwd_(msg, &c__43, &c__905, &c__0, &c__0, &c__0, &c__0, &c__2, &
		f1nrm, &f1nrmp, (ftnlen)80);
    }
    if (f1nrmp > f1nrm + alpha * slpi * rl) {
	goto L200;
    }
/* ----------------------------------------------------------------------- */
/* Alpha-condition is satisfied, or linesearch is turned off. */
/* Copy YNEW,YPNEW to Y,YPRIME and return. */
/* ----------------------------------------------------------------------- */
L150:
    *iret = 0;
    dcopy_(neq, &ynew[1], &c__1, &y[1], &c__1);
    dcopy_(neq, &ypnew[1], &c__1, &yprime[1], &c__1);
    *fnrm = fnrmp;
    if (kprin >= 1) {
	s_copy(msg, "------ LEAVING ROUTINE DLINSD, FNRM = (R1)", (ftnlen)80, 
		(ftnlen)42);
	xerrwd_(msg, &c__42, &c__906, &c__0, &c__0, &c__0, &c__0, &c__1, fnrm,
		 &c_b37, (ftnlen)80);
    }
    return 0;
/* ----------------------------------------------------------------------- */
/* Alpha-condition not satisfied.  Perform backtrack to compute new RL */
/* value.  If no satisfactory YNEW,YPNEW can be found sufficiently */
/* distinct from Y,YPRIME, then return IRET = 1. */
/* ----------------------------------------------------------------------- */
L200:
    if (rl < rlmin) {
	*iret = 1;
	return 0;
    }

    rl /= two;
    goto L100;

/* ----------------------- END OF SUBROUTINE DLINSD ---------------------- */
} /* dlinsd_ */

/* Subroutine */ int dfnrmd_(integer *neq, doublereal *y, doublereal *t, 
	doublereal *yprime, doublereal *r__, doublereal *cj, doublereal *
	tscale, doublereal *wt, S_fp res, integer *ires, doublereal *fnorm, 
	doublereal *wm, integer *iwm, doublereal *rpar, integer *ipar)
{
    extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, 
	    integer *);
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);


/* ***BEGIN PROLOGUE  DFNRMD */
/* ***REFER TO  DLINSD */
/* ***DATE WRITTEN   941025   (YYMMDD) */
/* ***REVISION DATE  000628   TSCALE argument added. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DFNRMD calculates the scaled preconditioned norm of the nonlinear */
/*     function used in the nonlinear iteration for obtaining consistent */
/*     initial conditions.  Specifically, DFNRMD calculates the weighted */
/*     root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), */
/*     where J is the Jacobian matrix. */

/*     In addition to the parameters described in the calling program */
/*     DLINSD, the parameters represent */

/*     R      -- Array of length NEQ that contains */
/*               (J-inverse)*G(T,Y,YPRIME) on return. */
/*     TSCALE -- Scale factor in T, used for stopping tests if nonzero. */
/*     FNORM  -- Scalar containing the weighted norm of R on return. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   RES, DSLVD, DDWNRM */

/* ***END PROLOGUE  DFNRMD */


/* ----------------------------------------------------------------------- */
/*     Call RES routine. */
/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --ipar;
    --rpar;
    --iwm;
    --wm;
    --wt;
    --r__;
    --yprime;
    --y;

    /* Function Body */
    *ires = 0;
    (*res)(t, &y[1], &yprime[1], cj, &r__[1], ires, &rpar[1], &ipar[1]);
    if (*ires < 0) {
	return 0;
    }
/* ----------------------------------------------------------------------- */
/*     Apply inverse of Jacobian to vector R. */
/* ----------------------------------------------------------------------- */
    dslvd_(neq, &r__[1], &wm[1], &iwm[1]);
/* ----------------------------------------------------------------------- */
/*     Calculate norm of R. */
/* ----------------------------------------------------------------------- */
    *fnorm = ddwnrm_(neq, &r__[1], &wt[1], &rpar[1], &ipar[1]);
    if (*tscale > 0.) {
	*fnorm = *fnorm * *tscale * abs(*cj);
    }

    return 0;
/* ----------------------- END OF SUBROUTINE DFNRMD ---------------------- */
} /* dfnrmd_ */

/* Subroutine */ int dnedd_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, S_fp res, U_fp jacd, doublereal *pdum, doublereal *h__, 
	doublereal *wt, integer *jstart, integer *idid, doublereal *rpar, 
	integer *ipar, doublereal *phi, doublereal *gamma, doublereal *dumsvr,
	 doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, 
	doublereal *cj, doublereal *cjold, doublereal *cjlast, doublereal *s, 
	doublereal *uround, doublereal *dume, doublereal *dums, doublereal *
	dumr, doublereal *epcon, integer *jcalc, integer *jfdum, integer *kp1,
	 integer *nonneg, integer *ntype, integer *iernls)
{
    /* Initialized data */

    static integer muldel = 1;
    static integer maxit = 4;
    static doublereal xrate = .25;

    /* System generated locals */
    integer phi_dim1, phi_offset, i__1, i__2;
    doublereal d__1;

    /* Local variables */
    integer i__, j, ierj;
    extern /* Subroutine */ int dnsd_(doublereal *, doublereal *, doublereal *
	    , integer *, S_fp, doublereal *, doublereal *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, doublereal *,
	     integer *, doublereal *, doublereal *, doublereal *, doublereal *
	    , doublereal *, doublereal *, doublereal *, doublereal *, integer 
	    *, integer *, integer *, integer *, integer *);
    integer idum, ires;
    doublereal temp1, temp2;
    extern /* Subroutine */ int dmatd_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     doublereal *, doublereal *, doublereal *, integer *, S_fp, 
	    integer *, doublereal *, U_fp, doublereal *, integer *);
    doublereal pnorm, delnrm;
    integer iernew;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    doublereal tolnew;
    integer iertyp;


/* ***BEGIN PROLOGUE  DNEDD */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   891219   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DNEDD solves a nonlinear system of */
/*     algebraic equations of the form */
/*     G(X,Y,YPRIME) = 0 for the unknown Y. */

/*     The method used is a modified Newton scheme. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of unknowns. */
/*     RES       -- External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     JACD      -- External user-supplied routine to evaluate the */
/*                  Jacobian.  See JAC description for the case */
/*                  INFO(12) = 0 in the DDASPK prologue. */
/*     PDUM      -- Dummy argument. */
/*     H         -- Appropriate step size for next step. */
/*     WT        -- Vector of weights for error criterion. */
/*     JSTART    -- Indicates first call to this routine. */
/*                  If JSTART = 0, then this is the first call, */
/*                  otherwise it is not. */
/*     IDID      -- Completion flag, output by DNEDD. */
/*                  See IDID description in DDASPK prologue. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     PHI       -- Array of divided differences used by */
/*                  DNEDD.  The length is NEQ*(K+1),where */
/*                  K is the maximum order. */
/*     GAMMA     -- Array used to predict Y and YPRIME.  The length */
/*                  is MAXORD+1 where MAXORD is the maximum order. */
/*     DUMSVR    -- Dummy argument. */
/*     DELTA     -- Work vector for NLS of length NEQ. */
/*     E         -- Error accumulation vector for NLS of length NEQ. */
/*     WM,IWM    -- Real and integer arrays storing */
/*                  matrix information such as the matrix */
/*                  of partial derivatives, permutation */
/*                  vector, and various other information. */
/*     CJ        -- Parameter always proportional to 1/H. */
/*     CJOLD     -- Saves the value of CJ as of the last call to DMATD. */
/*                  Accounts for changes in CJ needed to */
/*                  decide whether to call DMATD. */
/*     CJLAST    -- Previous value of CJ. */
/*     S         -- A scalar determined by the approximate rate */
/*                  of convergence of the Newton iteration and used */
/*                  in the convergence test for the Newton iteration. */

/*                  If RATE is defined to be an estimate of the */
/*                  rate of convergence of the Newton iteration, */
/*                  then S = RATE/(1.D0-RATE). */

/*                  The closer RATE is to 0., the faster the Newton */
/*                  iteration is converging; the closer RATE is to 1., */
/*                  the slower the Newton iteration is converging. */

/*                  On the first Newton iteration with an up-dated */
/*                  preconditioner S = 100.D0, Thus the initial */
/*                  RATE of convergence is approximately 1. */

/*                  S is preserved from call to call so that the rate */
/*                  estimate from a previous step can be applied to */
/*                  the current step. */
/*     UROUND    -- Unit roundoff. */
/*     DUME      -- Dummy argument. */
/*     DUMS      -- Dummy argument. */
/*     DUMR      -- Dummy argument. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     JCALC     -- Flag used to determine when to update */
/*                  the Jacobian matrix.  In general: */

/*                  JCALC = -1 ==> Call the DMATD routine to update */
/*                                 the Jacobian matrix. */
/*                  JCALC =  0 ==> Jacobian matrix is up-to-date. */
/*                  JCALC =  1 ==> Jacobian matrix is out-dated, */
/*                                 but DMATD will not be called unless */
/*                                 JCALC is set to -1. */
/*     JFDUM     -- Dummy argument. */
/*     KP1       -- The current order(K) + 1;  updated across calls. */
/*     NONNEG    -- Flag to determine nonnegativity constraints. */
/*     NTYPE     -- Identification code for the NLS routine. */
/*                   0  ==> modified Newton; direct solver. */
/*     IERNLS    -- Error flag for nonlinear solver. */
/*                   0  ==> nonlinear solver converged. */
/*                   1  ==> recoverable error inside nonlinear solver. */
/*                  -1  ==> unrecoverable error inside nonlinear solver. */

/*     All variables with "DUM" in their names are dummy variables */
/*     which are not used in this routine. */

/*     Following is a list and description of local variables which */
/*     may not have an obvious usage.  They are listed in roughly the */
/*     order they occur in this subroutine. */

/*     The following group of variables are passed as arguments to */
/*     the Newton iteration solver.  They are explained in greater detail */
/*     in DNSD: */
/*        TOLNEW, MULDEL, MAXIT, IERNEW */

/*     IERTYP -- Flag which tells whether this subroutine is correct. */
/*               0 ==> correct subroutine. */
/*               1 ==> incorrect subroutine. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   DDWNRM, RES, DMATD, DNSD */

/* ***END PROLOGUE  DNEDD */




    /* Parameter adjustments */
    --y;
    --yprime;
    phi_dim1 = *neq;
    phi_offset = 1 + phi_dim1;
    phi -= phi_offset;
    --wt;
    --rpar;
    --ipar;
    --gamma;
    --delta;
    --e;
    --wm;
    --iwm;

    /* Function Body */

/*     Verify that this is the correct subroutine. */

    iertyp = 0;
    if (*ntype != 0) {
	iertyp = 1;
	goto L380;
    }

/*     If this is the first step, perform initializations. */

    if (*jstart == 0) {
	*cjold = *cj;
	*jcalc = -1;
    }

/*     Perform all other initializations. */

    *iernls = 0;

/*     Decide whether new Jacobian is needed. */

    temp1 = (1. - xrate) / (xrate + 1.);
    temp2 = 1. / temp1;
    if (*cj / *cjold < temp1 || *cj / *cjold > temp2) {
	*jcalc = -1;
    }
    if (*cj != *cjlast) {
	*s = 100.;
    }

/* ----------------------------------------------------------------------- */
/*     Entry point for updating the Jacobian with current */
/*     stepsize. */
/* ----------------------------------------------------------------------- */
L300:

/*     Initialize all error flags to zero. */

    ierj = 0;
    ires = 0;
    iernew = 0;

/*     Predict the solution and derivative and compute the tolerance */
/*     for the Newton iteration. */

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] = phi[i__ + phi_dim1];
/* L310: */
	yprime[i__] = 0.;
    }
    i__1 = *kp1;
    for (j = 2; j <= i__1; ++j) {
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    y[i__] += phi[i__ + j * phi_dim1];
/* L320: */
	    yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1];
	}
/* L330: */
    }
    pnorm = ddwnrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]);
    tolnew = *uround * 100. * pnorm;

/*     Call RES to initialize DELTA. */

    ++iwm[12];
    (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ires < 0) {
	goto L380;
    }

/*     If indicated, reevaluate the iteration matrix */
/*     J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). */
/*     Set JCALC to 0 as an indicator that this has been done. */

    if (*jcalc == -1) {
	++iwm[13];
	*jcalc = 0;
	dmatd_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ierj, &wt[1], &
		e[1], &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jacd, &
		rpar[1], &ipar[1]);
	*cjold = *cj;
	*s = 100.;
	if (ires < 0) {
	    goto L380;
	}
	if (ierj != 0) {
	    goto L380;
	}
    }

/*     Call the nonlinear Newton solver. */

    temp1 = 2. / (*cj / *cjold + 1.);
    dnsd_(x, &y[1], &yprime[1], neq, (S_fp)res, pdum, &wt[1], &rpar[1], &ipar[
	    1], dumsvr, &delta[1], &e[1], &wm[1], &iwm[1], cj, dums, dumr, 
	    dume, epcon, s, &temp1, &tolnew, &muldel, &maxit, &ires, &idum, &
	    iernew);

    if (iernew > 0 && *jcalc != 0) {

/*        The Newton iteration had a recoverable failure with an old */
/*        iteration matrix.  Retry the step with a new iteration matrix. */

	*jcalc = -1;
	goto L300;
    }

    if (iernew != 0) {
	goto L380;
    }

/*     The Newton iteration has converged.  If nonnegativity of */
/*     solution is required, set the solution nonnegative, if the */
/*     perturbation to do it is small enough.  If the change is too */
/*     large, then consider the corrector iteration to have failed. */

/* L375: */
    if (*nonneg == 0) {
	goto L390;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L377: */
/* Computing MIN */
	d__1 = y[i__];
	delta[i__] = min(d__1,0.);
    }
    delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm > *epcon) {
	goto L380;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L378: */
	e[i__] -= delta[i__];
    }
    goto L390;


/*     Exits from nonlinear solver. */
/*     No convergence with current iteration */
/*     matrix, or singular iteration matrix. */
/*     Compute IERNLS and IDID accordingly. */

L380:
    if (ires <= -2 || iertyp != 0) {
	*iernls = -1;
	if (ires <= -2) {
	    *idid = -11;
	}
	if (iertyp != 0) {
	    *idid = -15;
	}
    } else {
	*iernls = 1;
	if (ires < 0) {
	    *idid = -10;
	}
	if (ierj != 0) {
	    *idid = -8;
	}
    }

L390:
    *jcalc = 1;
    return 0;

/* ------END OF SUBROUTINE DNEDD------------------------------------------ */
} /* dnedd_ */

/* Subroutine */ int dnsd_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, S_fp res, doublereal *pdum, doublereal *wt, doublereal *
	rpar, integer *ipar, doublereal *dumsvr, doublereal *delta, 
	doublereal *e, doublereal *wm, integer *iwm, doublereal *cj, 
	doublereal *dums, doublereal *dumr, doublereal *dume, doublereal *
	epcon, doublereal *s, doublereal *confac, doublereal *tolnew, integer 
	*muldel, integer *maxit, integer *ires, integer *idum, integer *
	iernew)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2;

    /* Builtin functions */
    double pow_dd(doublereal *, doublereal *);

    /* Local variables */
    integer i__, m;
    doublereal rate;
    extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, 
	    integer *);
    doublereal delnrm;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    doublereal oldnrm;


/* ***BEGIN PROLOGUE  DNSD */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   891219   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  950126   (YYMMDD) */
/* ***REVISION DATE  000711   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DNSD solves a nonlinear system of */
/*     algebraic equations of the form */
/*     G(X,Y,YPRIME) = 0 for the unknown Y. */

/*     The method used is a modified Newton scheme. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of unknowns. */
/*     RES       -- External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     PDUM      -- Dummy argument. */
/*     WT        -- Vector of weights for error criterion. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     DUMSVR    -- Dummy argument. */
/*     DELTA     -- Work vector for DNSD of length NEQ. */
/*     E         -- Error accumulation vector for DNSD of length NEQ. */
/*     WM,IWM    -- Real and integer arrays storing */
/*                  matrix information such as the matrix */
/*                  of partial derivatives, permutation */
/*                  vector, and various other information. */
/*     CJ        -- Parameter always proportional to 1/H (step size). */
/*     DUMS      -- Dummy argument. */
/*     DUMR      -- Dummy argument. */
/*     DUME      -- Dummy argument. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     S         -- Used for error convergence tests. */
/*                  In the Newton iteration: S = RATE/(1 - RATE), */
/*                  where RATE is the estimated rate of convergence */
/*                  of the Newton iteration. */
/*                  The calling routine passes the initial value */
/*                  of S to the Newton iteration. */
/*     CONFAC    -- A residual scale factor to improve convergence. */
/*     TOLNEW    -- Tolerance on the norm of Newton correction in */
/*                  alternative Newton convergence test. */
/*     MULDEL    -- A flag indicating whether or not to multiply */
/*                  DELTA by CONFAC. */
/*                  0  ==> do not scale DELTA by CONFAC. */
/*                  1  ==> scale DELTA by CONFAC. */
/*     MAXIT     -- Maximum allowed number of Newton iterations. */
/*     IRES      -- Error flag returned from RES.  See RES description */
/*                  in DDASPK prologue.  If IRES = -1, then IERNEW */
/*                  will be set to 1. */
/*                  If IRES < -1, then IERNEW will be set to -1. */
/*     IDUM      -- Dummy argument. */
/*     IERNEW    -- Error flag for Newton iteration. */
/*                   0  ==> Newton iteration converged. */
/*                   1  ==> recoverable error inside Newton iteration. */
/*                  -1  ==> unrecoverable error inside Newton iteration. */

/*     All arguments with "DUM" in their names are dummy arguments */
/*     which are not used in this routine. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   DSLVD, DDWNRM, RES */

/* ***END PROLOGUE  DNSD */




/*     Initialize Newton counter M and accumulation vector E. */

    /* Parameter adjustments */
    --iwm;
    --wm;
    --e;
    --delta;
    --ipar;
    --rpar;
    --wt;
    --yprime;
    --y;

    /* Function Body */
    m = 0;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
	e[i__] = 0.;
    }

/*     Corrector loop. */

L300:
    ++iwm[19];

/*     If necessary, multiply residual by convergence factor. */

    if (*muldel == 1) {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L320: */
	    delta[i__] *= *confac;
	}
    }

/*     Compute a new iterate (back-substitution). */
/*     Store the correction in DELTA. */

    dslvd_(neq, &delta[1], &wm[1], &iwm[1]);

/*     Update Y, E, and YPRIME. */

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] -= delta[i__];
	e[i__] -= delta[i__];
/* L340: */
	yprime[i__] -= *cj * delta[i__];
    }

/*     Test for convergence of the iteration. */

    delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (m == 0) {
	oldnrm = delnrm;
	if (delnrm <= *tolnew) {
	    goto L370;
	}
    } else {
	d__1 = delnrm / oldnrm;
	d__2 = 1. / m;
	rate = pow_dd(&d__1, &d__2);
	if (rate > .9) {
	    goto L380;
	}
	*s = rate / (1. - rate);
    }
    if (*s * delnrm <= *epcon) {
	goto L370;
    }

/*     The corrector has not yet converged. */
/*     Update M and test whether the */
/*     maximum number of iterations have */
/*     been tried. */

    ++m;
    if (m >= *maxit) {
	goto L380;
    }

/*     Evaluate the residual, */
/*     and go back to do another iteration. */

    ++iwm[12];
    (*res)(x, &y[1], &yprime[1], cj, &delta[1], ires, &rpar[1], &ipar[1]);
    if (*ires < 0) {
	goto L380;
    }
    goto L300;

/*     The iteration has converged. */

L370:
    return 0;

/*     The iteration has not converged.  Set IERNEW appropriately. */

L380:
    if (*ires <= -2) {
	*iernew = -1;
    } else {
	*iernew = 1;
    }
    return 0;


/* ------END OF SUBROUTINE DNSD------------------------------------------- */
} /* dnsd_ */

/* Subroutine */ int dmatd_(integer *neq, doublereal *x, doublereal *y, 
	doublereal *yprime, doublereal *delta, doublereal *cj, doublereal *
	h__, integer *ier, doublereal *ewt, doublereal *e, doublereal *wm, 
	integer *iwm, S_fp res, integer *ires, doublereal *uround, S_fp jacd, 
	doublereal *rpar, integer *ipar)
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2, d__3, d__4, d__5;

    /* Builtin functions */
    double sqrt(doublereal), d_sign(doublereal *, doublereal *);

    /* Local variables */
    integer i__, j, k, l, n, i1, i2, ii, mba;
    doublereal del;
    integer meb1, nrow;
    doublereal squr;
    extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *, 
	    integer *, integer *, integer *, integer *), dgefa_(doublereal *, 
	    integer *, integer *, integer *, integer *);
    integer mband, lenpd, isave, msave;
    doublereal ysave;
    integer lipvt, mtype, meband;
    doublereal delinv;
    integer ipsave;
    doublereal ypsave;


/* ***BEGIN PROLOGUE  DMATD */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  940701   (YYMMDD) (new LIPVT) */

/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     This routine computes the iteration matrix */
/*     J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). */
/*     Here J is computed by: */
/*       the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or */
/*       by numerical difference quotients if IWM(MTYPE) is 2 or 5. */

/*     The parameters have the following meanings. */
/*     X        = Independent variable. */
/*     Y        = Array containing predicted values. */
/*     YPRIME   = Array containing predicted derivatives. */
/*     DELTA    = Residual evaluated at (X,Y,YPRIME). */
/*                (Used only if IWM(MTYPE)=2 or 5). */
/*     CJ       = Scalar parameter defining iteration matrix. */
/*     H        = Current stepsize in integration. */
/*     IER      = Variable which is .NE. 0 if iteration matrix */
/*                is singular, and 0 otherwise. */
/*     EWT      = Vector of error weights for computing norms. */
/*     E        = Work space (temporary) of length NEQ. */
/*     WM       = Real work space for matrices.  On output */
/*                it contains the LU decomposition */
/*                of the iteration matrix. */
/*     IWM      = Integer work space containing */
/*                matrix information. */
/*     RES      = External user-supplied subroutine */
/*                to evaluate the residual.  See RES description */
/*                in DDASPK prologue. */
/*     IRES     = Flag which is equal to zero if no illegal values */
/*                in RES, and less than zero otherwise.  (If IRES */
/*                is less than zero, the matrix was not completed). */
/*                In this case (if IRES .LT. 0), then IER = 0. */
/*     UROUND   = The unit roundoff error of the machine being used. */
/*     JACD     = Name of the external user-supplied routine */
/*                to evaluate the iteration matrix.  (This routine */
/*                is only used if IWM(MTYPE) is 1 or 4) */
/*                See JAC description for the case INFO(12) = 0 */
/*                in DDASPK prologue. */
/*     RPAR,IPAR= Real and integer parameter arrays that */
/*                are used for communication between the */
/*                calling program and external user routines. */
/*                They are not altered by DMATD. */
/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   JACD, RES, DGEFA, DGBFA */

/* ***END PROLOGUE  DMATD */




    /* Parameter adjustments */
    --ipar;
    --rpar;
    --iwm;
    --wm;
    --e;
    --ewt;
    --delta;
    --yprime;
    --y;

    /* Function Body */
    lipvt = iwm[30];
    *ier = 0;
    mtype = iwm[4];
    switch (mtype) {
	case 1:  goto L100;
	case 2:  goto L200;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L500;
    }


/*     Dense user-supplied matrix. */

L100:
    lenpd = iwm[22];
    i__1 = lenpd;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L110: */
	wm[i__] = 0.;
    }
    (*jacd)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]);
    goto L230;


/*     Dense finite-difference-generated matrix. */

L200:
    *ires = 0;
    nrow = 0;
    squr = sqrt(*uround);
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
	d__4 = (d__1 = y[i__], abs(d__1)), d__5 = (d__2 = *h__ * yprime[i__], 
		abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / ewt[
		i__], abs(d__3));
	del = squr * max(d__4,d__5);
	d__1 = *h__ * yprime[i__];
	del = d_sign(&del, &d__1);
	del = y[i__] + del - y[i__];
	ysave = y[i__];
	ypsave = yprime[i__];
	y[i__] += del;
	yprime[i__] += *cj * del;
	++iwm[12];
	(*res)(x, &y[1], &yprime[1], cj, &e[1], ires, &rpar[1], &ipar[1]);
	if (*ires < 0) {
	    return 0;
	}
	delinv = 1. / del;
	i__2 = *neq;
	for (l = 1; l <= i__2; ++l) {
/* L220: */
	    wm[nrow + l] = (e[l] - delta[l]) * delinv;
	}
	nrow += *neq;
	y[i__] = ysave;
	yprime[i__] = ypsave;
/* L210: */
    }


/*     Do dense-matrix LU decomposition on J. */

L230:
    dgefa_(&wm[1], neq, neq, &iwm[lipvt], ier);
    return 0;


/*     Dummy section for IWM(MTYPE)=3. */

L300:
    return 0;


/*     Banded user-supplied matrix. */

L400:
    lenpd = iwm[22];
    i__1 = lenpd;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L410: */
	wm[i__] = 0.;
    }
    (*jacd)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]);
    meband = (iwm[1] << 1) + iwm[2] + 1;
    goto L550;


/*     Banded finite-difference-generated matrix. */

L500:
    mband = iwm[1] + iwm[2] + 1;
    mba = min(mband,*neq);
    meband = mband + iwm[1];
    meb1 = meband - 1;
    msave = *neq / mband + 1;
    isave = iwm[22];
    ipsave = isave + msave;
    *ires = 0;
    squr = sqrt(*uround);
    i__1 = mba;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *neq;
	i__3 = mband;
	for (n = j; i__3 < 0 ? n >= i__2 : n <= i__2; n += i__3) {
	    k = (n - j) / mband + 1;
	    wm[isave + k] = y[n];
	    wm[ipsave + k] = yprime[n];
/* Computing MAX */
	    d__4 = (d__1 = y[n], abs(d__1)), d__5 = (d__2 = *h__ * yprime[n], 
		    abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / 
		    ewt[n], abs(d__3));
	    del = squr * max(d__4,d__5);
	    d__1 = *h__ * yprime[n];
	    del = d_sign(&del, &d__1);
	    del = y[n] + del - y[n];
	    y[n] += del;
/* L510: */
	    yprime[n] += *cj * del;
	}
	++iwm[12];
	(*res)(x, &y[1], &yprime[1], cj, &e[1], ires, &rpar[1], &ipar[1]);
	if (*ires < 0) {
	    return 0;
	}
	i__3 = *neq;
	i__2 = mband;
	for (n = j; i__2 < 0 ? n >= i__3 : n <= i__3; n += i__2) {
	    k = (n - j) / mband + 1;
	    y[n] = wm[isave + k];
	    yprime[n] = wm[ipsave + k];
/* Computing MAX */
	    d__4 = (d__1 = y[n], abs(d__1)), d__5 = (d__2 = *h__ * yprime[n], 
		    abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / 
		    ewt[n], abs(d__3));
	    del = squr * max(d__4,d__5);
	    d__1 = *h__ * yprime[n];
	    del = d_sign(&del, &d__1);
	    del = y[n] + del - y[n];
	    delinv = 1. / del;
/* Computing MAX */
	    i__4 = 1, i__5 = n - iwm[2];
	    i1 = max(i__4,i__5);
/* Computing MIN */
	    i__4 = *neq, i__5 = n + iwm[1];
	    i2 = min(i__4,i__5);
	    ii = n * meb1 - iwm[1];
	    i__4 = i2;
	    for (i__ = i1; i__ <= i__4; ++i__) {
/* L520: */
		wm[ii + i__] = (e[i__] - delta[i__]) * delinv;
	    }
/* L530: */
	}
/* L540: */
    }


/*     Do LU decomposition of banded J. */

L550:
    dgbfa_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[lipvt], ier);
    return 0;

/* ------END OF SUBROUTINE DMATD------------------------------------------ */
} /* dmatd_ */

/* Subroutine */ int dslvd_(integer *neq, doublereal *delta, doublereal *wm, 
	integer *iwm)
{
    extern /* Subroutine */ int dgbsl_(doublereal *, integer *, integer *, 
	    integer *, integer *, integer *, doublereal *, integer *), dgesl_(
	    doublereal *, integer *, integer *, integer *, doublereal *, 
	    integer *);
    integer lipvt, mtype, meband;


/* ***BEGIN PROLOGUE  DSLVD */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  940701   (YYMMDD) (new LIPVT) */

/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     This routine manages the solution of the linear */
/*     system arising in the Newton iteration. */
/*     Real matrix information and real temporary storage */
/*     is stored in the array WM. */
/*     Integer matrix information is stored in the array IWM. */
/*     For a dense matrix, the LINPACK routine DGESL is called. */
/*     For a banded matrix, the LINPACK routine DGBSL is called. */
/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   DGESL, DGBSL */

/* ***END PROLOGUE  DSLVD */




    /* Parameter adjustments */
    --iwm;
    --wm;
    --delta;

    /* Function Body */
    lipvt = iwm[30];
    mtype = iwm[4];
    switch (mtype) {
	case 1:  goto L100;
	case 2:  goto L100;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L400;
    }

/*     Dense matrix. */

L100:
    dgesl_(&wm[1], neq, neq, &iwm[lipvt], &delta[1], &c__0);
    return 0;

/*     Dummy section for MTYPE=3. */

L300:
    return 0;

/*     Banded matrix. */

L400:
    meband = (iwm[1] << 1) + iwm[2] + 1;
    dgbsl_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[lipvt], &delta[1], &
	    c__0);
    return 0;

/* ------END OF SUBROUTINE DSLVD------------------------------------------ */
} /* dslvd_ */

/* Subroutine */ int ddasik_(doublereal *x, doublereal *y, doublereal *yprime,
	 integer *neq, integer *icopt, integer *id, S_fp res, S_fp jack, U_fp 
	psol, doublereal *h__, doublereal *tscale, doublereal *wt, integer *
	jskip, doublereal *rpar, integer *ipar, doublereal *savr, doublereal *
	delta, doublereal *r__, doublereal *yic, doublereal *ypic, doublereal 
	*pwk, doublereal *wm, integer *iwm, doublereal *cj, doublereal *
	uround, doublereal *epli, doublereal *sqrtn, doublereal *rsqrtn, 
	doublereal *epcon, doublereal *ratemx, doublereal *stptol, integer *
	jflg, integer *icnflg, integer *icnstr, integer *iernls)
{
    integer nj, lwp, ires, liwp, mxnj;
    doublereal eplin;
    extern /* Subroutine */ int dnsik_(doublereal *, doublereal *, doublereal 
	    *, integer *, integer *, integer *, S_fp, U_fp, doublereal *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, integer *
	    , doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, integer *, doublereal *,
	     integer *, integer *, integer *);
    integer ierpj;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    integer mxnit, iernew;


/* ***BEGIN PROLOGUE  DDASIK */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   941026   (YYMMDD) */
/* ***REVISION DATE  950808   (YYMMDD) */
/* ***REVISION DATE  951110   Removed unreachable block 390. */
/* ***REVISION DATE  000628   TSCALE argument added. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */


/*     DDASIK solves a nonlinear system of algebraic equations of the */
/*     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */
/*     the initial conditions. */

/*     An initial value for Y and initial guess for YPRIME are input. */

/*     The method used is a Newton scheme with Krylov iteration and a */
/*     linesearch algorithm. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector at x. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of equations to be integrated. */
/*     ICOPT     -- Initial condition option chosen (1 or 2). */
/*     ID        -- Array of dimension NEQ, which must be initialized */
/*                  if ICOPT = 1.  See DDASIC. */
/*     RES       -- External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     JACK     --  External user-supplied routine to update */
/*                  the preconditioner.  (This is optional). */
/*                  See JAC description for the case */
/*                  INFO(12) = 1 in the DDASPK prologue. */
/*     PSOL      -- External user-supplied routine to solve */
/*                  a linear system using preconditioning. */
/*                  (This is optional).  See explanation inside DDASPK. */
/*     H         -- Scaling factor for this initial condition calc. */
/*     TSCALE    -- Scale factor in T, used for stopping tests if nonzero. */
/*     WT        -- Vector of weights for error criterion. */
/*     JSKIP     -- input flag to signal if initial JAC call is to be */
/*                  skipped.  1 => skip the call, 0 => do not skip call. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     SAVR      -- Work vector for DDASIK of length NEQ. */
/*     DELTA     -- Work vector for DDASIK of length NEQ. */
/*     R         -- Work vector for DDASIK of length NEQ. */
/*     YIC,YPIC  -- Work vectors for DDASIK, each of length NEQ. */
/*     PWK       -- Work vector for DDASIK of length NEQ. */
/*     WM,IWM    -- Real and integer arrays storing */
/*                  matrix information for linear system */
/*                  solvers, and various other information. */
/*     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */
/*     UROUND    -- Unit roundoff.  Not used here. */
/*     EPLI      -- convergence test constant. */
/*                  See DDASPK prologue for more details. */
/*     SQRTN     -- Square root of NEQ. */
/*     RSQRTN    -- reciprical of square root of NEQ. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     RATEMX    -- Maximum convergence rate for which Newton iteration */
/*                  is considered converging. */
/*     JFLG      -- Flag showing whether a Jacobian routine is supplied. */
/*     ICNFLG    -- Integer scalar.  If nonzero, then constraint */
/*                  violations in the proposed new approximate solution */
/*                  will be checked for, and the maximum step length */
/*                  will be adjusted accordingly. */
/*     ICNSTR    -- Integer array of length NEQ containing flags for */
/*                  checking constraints. */
/*     IERNLS    -- Error flag for nonlinear solver. */
/*                   0   ==> nonlinear solver converged. */
/*                   1,2 ==> recoverable error inside nonlinear solver. */
/*                           1 => retry with current Y, YPRIME */
/*                           2 => retry with original Y, YPRIME */
/*                  -1   ==> unrecoverable error in nonlinear solver. */

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

/* ***ROUTINES CALLED */
/*   RES, JACK, DNSIK, DCOPY */

/* ***END PROLOGUE  DDASIK */





/*     Perform initializations. */

    /* Parameter adjustments */
    --icnstr;
    --iwm;
    --wm;
    --pwk;
    --ypic;
    --yic;
    --r__;
    --delta;
    --savr;
    --ipar;
    --rpar;
    --wt;
    --id;
    --yprime;
    --y;

    /* Function Body */
    lwp = iwm[29];
    liwp = iwm[30];
    mxnit = iwm[32];
    mxnj = iwm[33];
    *iernls = 0;
    nj = 0;
    eplin = *epli * *epcon;

/*     Call RES to initialize DELTA. */

    ires = 0;
    ++iwm[12];
    (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ires < 0) {
	goto L370;
    }

/*     Looping point for updating the preconditioner. */

L300:

/*     Initialize all error flags to zero. */

    ierpj = 0;
    ires = 0;
    iernew = 0;

/*     If a Jacobian routine was supplied, call it. */

    if (*jflg == 1 && *jskip == 0) {
	++nj;
	++iwm[13];
	(*jack)((S_fp)res, &ires, neq, x, &y[1], &yprime[1], &wt[1], &delta[1]
		, &r__[1], h__, cj, &wm[lwp], &iwm[liwp], &ierpj, &rpar[1], &
		ipar[1]);
	if (ires < 0 || ierpj != 0) {
	    goto L370;
	}
    }
    *jskip = 0;

/*     Call the nonlinear Newton solver for up to MXNIT iterations. */

    dnsik_(x, &y[1], &yprime[1], neq, icopt, &id[1], (S_fp)res, (U_fp)psol, &
	    wt[1], &rpar[1], &ipar[1], &savr[1], &delta[1], &r__[1], &yic[1], 
	    &ypic[1], &pwk[1], &wm[1], &iwm[1], cj, tscale, sqrtn, rsqrtn, &
	    eplin, epcon, ratemx, &mxnit, stptol, icnflg, &icnstr[1], &iernew)
	    ;

    if (iernew == 1 && nj < mxnj && *jflg == 1) {

/*       Up to MXNIT iterations were done, the convergence rate is < 1, */
/*       a Jacobian routine is supplied, and the number of JACK calls */
/*       is less than MXNJ. */
/*       Copy the residual SAVR to DELTA, call JACK, and try again. */

	dcopy_(neq, &savr[1], &c__1, &delta[1], &c__1);
	goto L300;
    }

    if (iernew != 0) {
	goto L380;
    }
    return 0;


/*     Unsuccessful exits from nonlinear solver. */
/*     Set IERNLS accordingly. */

L370:
    *iernls = 2;
    if (ires <= -2) {
	*iernls = -1;
    }
    return 0;

L380:
    *iernls = min(iernew,2);
    return 0;

/* ----------------------- END OF SUBROUTINE DDASIK----------------------- */
} /* ddasik_ */

/* Subroutine */ int dnsik_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, integer *icopt, integer *id, S_fp res, U_fp psol, 
	doublereal *wt, doublereal *rpar, integer *ipar, doublereal *savr, 
	doublereal *delta, doublereal *r__, doublereal *yic, doublereal *ypic,
	 doublereal *pwk, doublereal *wm, integer *iwm, doublereal *cj, 
	doublereal *tscale, doublereal *sqrtn, doublereal *rsqrtn, doublereal 
	*eplin, doublereal *epcon, doublereal *ratemx, integer *maxit, 
	doublereal *stptol, integer *icnflg, integer *icnstr, integer *iernew)
{
    integer m, ier, lwp;
    doublereal rlx, rate;
    integer ires;
    doublereal fnrm, rhok;
    integer iret, liwp;
    doublereal fnrm0;
    integer lsoff;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    integer iersl;
    extern /* Subroutine */ int dslvk_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, S_fp, integer *, U_fp, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *);
    doublereal oldfnm;
    extern /* Subroutine */ int dfnrmk_(integer *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, S_fp, 
	    integer *, U_fp, integer *, integer *, doublereal *, doublereal *,
	     doublereal *, integer *, doublereal *, doublereal *, integer *);
    doublereal delnrm;
    extern /* Subroutine */ int dlinsk_(integer *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, doublereal *, integer *, S_fp, integer *,
	     U_fp, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     integer *, doublereal *, doublereal *, integer *);
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);


/* ***BEGIN PROLOGUE  DNSIK */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   940701   (YYMMDD) */
/* ***REVISION DATE  950714   (YYMMDD) */
/* ***REVISION DATE  000628   TSCALE argument added. */
/* ***REVISION DATE  000628   Added criterion for IERNEW = 1 return. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DNSIK solves a nonlinear system of algebraic equations of the */
/*     form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */
/*     the initial conditions. */

/*     The method used is a Newton scheme combined with a linesearch */
/*     algorithm, using Krylov iterative linear system methods. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of unknowns. */
/*     ICOPT     -- Initial condition option chosen (1 or 2). */
/*     ID        -- Array of dimension NEQ, which must be initialized */
/*                  if ICOPT = 1.  See DDASIC. */
/*     RES       -- External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     PSOL      -- External user-supplied routine to solve */
/*                  a linear system using preconditioning. */
/*                  See explanation inside DDASPK. */
/*     WT        -- Vector of weights for error criterion. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     SAVR      -- Work vector for DNSIK of length NEQ. */
/*     DELTA     -- Residual vector on entry, and work vector of */
/*                  length NEQ for DNSIK. */
/*     R         -- Work vector for DNSIK of length NEQ. */
/*     YIC,YPIC  -- Work vectors for DNSIK, each of length NEQ. */
/*     PWK       -- Work vector for DNSIK of length NEQ. */
/*     WM,IWM    -- Real and integer arrays storing */
/*                  matrix information such as the matrix */
/*                  of partial derivatives, permutation */
/*                  vector, and various other information. */
/*     CJ        -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */
/*     TSCALE    -- Scale factor in T, used for stopping tests if nonzero. */
/*     SQRTN     -- Square root of NEQ. */
/*     RSQRTN    -- reciprical of square root of NEQ. */
/*     EPLIN     -- Tolerance for linear system solver. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     RATEMX    -- Maximum convergence rate for which Newton iteration */
/*                  is considered converging. */
/*     MAXIT     -- Maximum allowed number of Newton iterations. */
/*     STPTOL    -- Tolerance used in calculating the minimum lambda */
/*                  value allowed. */
/*     ICNFLG    -- Integer scalar.  If nonzero, then constraint */
/*                  violations in the proposed new approximate solution */
/*                  will be checked for, and the maximum step length */
/*                  will be adjusted accordingly. */
/*     ICNSTR    -- Integer array of length NEQ containing flags for */
/*                  checking constraints. */
/*     IERNEW    -- Error flag for Newton iteration. */
/*                   0  ==> Newton iteration converged. */
/*                   1  ==> failed to converge, but RATE .lt. 1, or the */
/*                          residual norm was reduced by a factor of .1. */
/*                   2  ==> failed to converge, RATE .gt. RATEMX. */
/*                   3  ==> other recoverable error. */
/*                  -1  ==> unrecoverable error inside Newton iteration. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY */

/* ***END PROLOGUE  DNSIK */





/*     Initializations.  M is the Newton iteration counter. */

    /* Parameter adjustments */
    --icnstr;
    --iwm;
    --wm;
    --pwk;
    --ypic;
    --yic;
    --r__;
    --delta;
    --savr;
    --ipar;
    --rpar;
    --wt;
    --id;
    --yprime;
    --y;

    /* Function Body */
    lsoff = iwm[35];
    m = 0;
    rate = 1.;
    lwp = iwm[29];
    liwp = iwm[30];
    rlx = .4;

/*     Save residual in SAVR. */

    dcopy_(neq, &delta[1], &c__1, &savr[1], &c__1);

/*     Compute norm of (P-inverse)*(residual). */

    dfnrmk_(neq, &y[1], x, &yprime[1], &savr[1], &r__[1], cj, tscale, &wt[1], 
	    sqrtn, rsqrtn, (S_fp)res, &ires, (U_fp)psol, &c__1, &ier, &fnrm, 
	    eplin, &wm[lwp], &iwm[liwp], &pwk[1], &rpar[1], &ipar[1]);
    ++iwm[21];
    if (ier != 0) {
	*iernew = 3;
	return 0;
    }

/*     Return now if residual norm is .le. EPCON. */

    if (fnrm <= *epcon) {
	return 0;
    }

/*     Newton iteration loop. */

    fnrm0 = fnrm;
L300:
    ++iwm[19];

/*     Compute a new step vector DELTA. */

    dslvk_(neq, &y[1], x, &yprime[1], &savr[1], &delta[1], &wt[1], &wm[1], &
	    iwm[1], (S_fp)res, &ires, (U_fp)psol, &iersl, cj, eplin, sqrtn, 
	    rsqrtn, &rhok, &rpar[1], &ipar[1]);
    if (ires != 0 || iersl != 0) {
	goto L390;
    }

/*     Get norm of DELTA.  Return now if DELTA is zero. */

    delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm == 0.) {
	return 0;
    }

/*     Call linesearch routine for global strategy and set RATE. */

    oldfnm = fnrm;

    dlinsk_(neq, &y[1], x, &yprime[1], &savr[1], cj, tscale, &delta[1], &
	    delnrm, &wt[1], sqrtn, rsqrtn, &lsoff, stptol, &iret, (S_fp)res, &
	    ires, (U_fp)psol, &wm[1], &iwm[1], &rhok, &fnrm, icopt, &id[1], &
	    wm[lwp], &iwm[liwp], &r__[1], eplin, &yic[1], &ypic[1], &pwk[1], 
	    icnflg, &icnstr[1], &rlx, &rpar[1], &ipar[1]);

    rate = fnrm / oldfnm;

/*     Check for error condition from linesearch. */
    if (iret != 0) {
	goto L390;
    }

/*     Test for convergence of the iteration, and return or loop. */

    if (fnrm <= *epcon) {
	return 0;
    }

/*     The iteration has not yet converged.  Update M. */
/*     Test whether the maximum number of iterations have been tried. */

    ++m;
    if (m >= *maxit) {
	goto L380;
    }

/*     Copy the residual SAVR to DELTA and loop for another iteration. */

    dcopy_(neq, &savr[1], &c__1, &delta[1], &c__1);
    goto L300;

/*     The maximum number of iterations was done.  Set IERNEW and return. */

L380:
    if (rate <= *ratemx || fnrm <= fnrm0 * .1) {
	*iernew = 1;
    } else {
	*iernew = 2;
    }
    return 0;

L390:
    if (ires <= -2 || iersl < 0) {
	*iernew = -1;
    } else {
	*iernew = 3;
	if (ires == 0 && iersl == 1 && m >= 2 && rate < 1.) {
	    *iernew = 1;
	}
    }
    return 0;


/* ----------------------- END OF SUBROUTINE DNSIK------------------------ */
} /* dnsik_ */

/* Subroutine */ int dlinsk_(integer *neq, doublereal *y, doublereal *t, 
	doublereal *yprime, doublereal *savr, doublereal *cj, doublereal *
	tscale, doublereal *p, doublereal *pnrm, doublereal *wt, doublereal *
	sqrtn, doublereal *rsqrtn, integer *lsoff, doublereal *stptol, 
	integer *iret, S_fp res, integer *ires, U_fp psol, doublereal *wm, 
	integer *iwm, doublereal *rhok, doublereal *fnrm, integer *icopt, 
	integer *id, doublereal *wp, integer *iwp, doublereal *r__, 
	doublereal *eplin, doublereal *ynew, doublereal *ypnew, doublereal *
	pwk, integer *icnflg, integer *icnstr, doublereal *rlx, doublereal *
	rpar, integer *ipar)
{
    /* Initialized data */

    static doublereal alpha = 1e-4;
    static doublereal one = 1.;
    static doublereal two = 2.;

    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    integer i__;
    doublereal rl;
    integer ier;
    char msg[80];
    doublereal tau;
    integer ivar;
    doublereal slpi, f1nrm, ratio;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    doublereal rlmin, fnrmp;
    integer kprin;
    doublereal ratio1, f1nrmp;
    extern /* Subroutine */ int dfnrmk_(integer *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, S_fp, 
	    integer *, U_fp, integer *, integer *, doublereal *, doublereal *,
	     doublereal *, integer *, doublereal *, doublereal *, integer *), 
	    dcnstr_(integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, doublereal *, integer *, integer *), xerrwd_(char *,
	     integer *, integer *, integer *, integer *, integer *, integer *,
	     integer *, doublereal *, doublereal *, ftnlen), dyypnw_(integer *
	    , doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *, doublereal *, doublereal *);


/* ***BEGIN PROLOGUE  DLINSK */
/* ***REFER TO  DNSIK */
/* ***DATE WRITTEN   940830   (YYMMDD) */
/* ***REVISION DATE  951006   (Arguments SQRTN, RSQRTN added.) */
/* ***REVISION DATE  960129   Moved line RL = ONE to top block. */
/* ***REVISION DATE  000628   TSCALE argument added. */
/* ***REVISION DATE  000628   RHOK*RHOK term removed in alpha test. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) */
/*     pair (YNEW,YPNEW) such that */

/*     f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) */

/*     where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of */
/*     the final residual vector in the Krylov iteration. */
/*     Here, f(y,y') is defined as */

/*      f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , */

/*     where norm() is the weighted RMS vector norm, G is the DAE */
/*     system residual function, and P is the preconditioner used */
/*     in the Krylov iteration. */

/*     In addition to the parameters defined elsewhere, we have */

/*     SAVR    -- Work array of length NEQ, containing the residual */
/*                vector G(t,y,y') on return. */
/*     TSCALE  -- Scale factor in T, used for stopping tests if nonzero. */
/*     P       -- Approximate Newton step used in backtracking. */
/*     PNRM    -- Weighted RMS norm of P. */
/*     LSOFF   -- Flag showing whether the linesearch algorithm is */
/*                to be invoked.  0 means do the linesearch, */
/*                1 means turn off linesearch. */
/*     STPTOL  -- Tolerance used in calculating the minimum lambda */
/*                value allowed. */
/*     ICNFLG  -- Integer scalar.  If nonzero, then constraint violations */
/*                in the proposed new approximate solution will be */
/*                checked for, and the maximum step length will be */
/*                adjusted accordingly. */
/*     ICNSTR  -- Integer array of length NEQ containing flags for */
/*                checking constraints. */
/*     RHOK    -- Weighted norm of preconditioned Krylov residual. */
/*     RLX     -- Real scalar restricting update size in DCNSTR. */
/*     YNEW    -- Array of length NEQ used to hold the new Y in */
/*                performing the linesearch. */
/*     YPNEW   -- Array of length NEQ used to hold the new YPRIME in */
/*                performing the linesearch. */
/*     PWK     -- Work vector of length NEQ for use in PSOL. */
/*     Y       -- Array of length NEQ containing the new Y (i.e.,=YNEW). */
/*     YPRIME  -- Array of length NEQ containing the new YPRIME */
/*                (i.e.,=YPNEW). */
/*     FNRM    -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the */
/*                current (Y,YPRIME) on input and output. */
/*     R       -- Work space length NEQ for residual vector. */
/*     IRET    -- Return flag. */
/*                IRET=0 means that a satisfactory (Y,YPRIME) was found. */
/*                IRET=1 means that the routine failed to find a new */
/*                       (Y,YPRIME) that was sufficiently distinct from */
/*                       the current (Y,YPRIME) pair. */
/*                IRET=2 means a failure in RES or PSOL. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD */

/* ***END PROLOGUE  DLINSK */



    /* Parameter adjustments */
    --ipar;
    --rpar;
    --icnstr;
    --pwk;
    --ypnew;
    --ynew;
    --r__;
    --iwp;
    --wp;
    --id;
    --iwm;
    --wm;
    --wt;
    --p;
    --savr;
    --yprime;
    --y;

    /* Function Body */

    kprin = iwm[31];
    f1nrm = *fnrm * *fnrm / two;
    ratio = one;

    if (kprin >= 2) {
	s_copy(msg, "------ IN ROUTINE DLINSK-- PNRM = (R1)", (ftnlen)80, (
		ftnlen)38);
	xerrwd_(msg, &c__38, &c__921, &c__0, &c__0, &c__0, &c__0, &c__1, pnrm,
		 &c_b37, (ftnlen)80);
    }
    tau = *pnrm;
    rl = one;
/* ----------------------------------------------------------------------- */
/* Check for violations of the constraints, if any are imposed. */
/* If any violations are found, the step vector P is rescaled, and the */
/* constraint check is repeated, until no violations are found. */
/* ----------------------------------------------------------------------- */
    if (*icnflg != 0) {
L10:
	dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[
		1], &ypnew[1]);
	dcnstr_(neq, &y[1], &ynew[1], &icnstr[1], &tau, rlx, iret, &ivar);
	if (*iret == 1) {
	    ratio1 = tau / *pnrm;
	    ratio *= ratio1;
	    i__1 = *neq;
	    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
		p[i__] *= ratio1;
	    }
	    *pnrm = tau;
	    if (kprin >= 2) {
		s_copy(msg, "------ CONSTRAINT VIOL., PNRM = (R1), INDEX = ("
			"I1)", (ftnlen)80, (ftnlen)50);
		xerrwd_(msg, &c__50, &c__922, &c__0, &c__1, &ivar, &c__0, &
			c__1, pnrm, &c_b37, (ftnlen)80);
	    }
	    if (*pnrm <= *stptol) {
		*iret = 1;
		return 0;
	    }
	    goto L10;
	}
    }

    slpi = -two * f1nrm * ratio;
    rlmin = *stptol / *pnrm;
    if (*lsoff == 0 && kprin >= 2) {
	s_copy(msg, "------ MIN. LAMBDA = (R1)", (ftnlen)80, (ftnlen)25);
	xerrwd_(msg, &c__25, &c__923, &c__0, &c__0, &c__0, &c__0, &c__1, &
		rlmin, &c_b37, (ftnlen)80);
    }
/* ----------------------------------------------------------------------- */
/* Begin iteration to find RL value satisfying alpha-condition. */
/* Update YNEW and YPNEW, then compute norm of new scaled residual and */
/* perform alpha condition test. */
/* ----------------------------------------------------------------------- */
L100:
    dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[1], &
	    ypnew[1]);
    dfnrmk_(neq, &ynew[1], t, &ypnew[1], &savr[1], &r__[1], cj, tscale, &wt[1]
	    , sqrtn, rsqrtn, (S_fp)res, ires, (U_fp)psol, &c__0, &ier, &fnrmp,
	     eplin, &wp[1], &iwp[1], &pwk[1], &rpar[1], &ipar[1]);
    ++iwm[12];
    if (*ires >= 0) {
	++iwm[21];
    }
    if (*ires != 0 || ier != 0) {
	*iret = 2;
	return 0;
    }
    if (*lsoff == 1) {
	goto L150;
    }

    f1nrmp = fnrmp * fnrmp / two;
    if (kprin >= 2) {
	s_copy(msg, "------ LAMBDA = (R1)", (ftnlen)80, (ftnlen)20);
	xerrwd_(msg, &c__20, &c__924, &c__0, &c__0, &c__0, &c__0, &c__1, &rl, 
		&c_b37, (ftnlen)80);
	s_copy(msg, "------ NORM(F1) = (R1),  NORM(F1NEW) = (R2)", (ftnlen)80,
		 (ftnlen)43);
	xerrwd_(msg, &c__43, &c__925, &c__0, &c__0, &c__0, &c__0, &c__2, &
		f1nrm, &f1nrmp, (ftnlen)80);
    }
    if (f1nrmp > f1nrm + alpha * slpi * rl) {
	goto L200;
    }
/* ----------------------------------------------------------------------- */
/* Alpha-condition is satisfied, or linesearch is turned off. */
/* Copy YNEW,YPNEW to Y,YPRIME and return. */
/* ----------------------------------------------------------------------- */
L150:
    *iret = 0;
    dcopy_(neq, &ynew[1], &c__1, &y[1], &c__1);
    dcopy_(neq, &ypnew[1], &c__1, &yprime[1], &c__1);
    *fnrm = fnrmp;
    if (kprin >= 1) {
	s_copy(msg, "------ LEAVING ROUTINE DLINSK, FNRM = (R1)", (ftnlen)80, 
		(ftnlen)42);
	xerrwd_(msg, &c__42, &c__926, &c__0, &c__0, &c__0, &c__0, &c__1, fnrm,
		 &c_b37, (ftnlen)80);
    }
    return 0;
/* ----------------------------------------------------------------------- */
/* Alpha-condition not satisfied.  Perform backtrack to compute new RL */
/* value.  If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can */
/* be found sufficiently distinct from Y,YPRIME, then return IRET = 1. */
/* ----------------------------------------------------------------------- */
L200:
    if (rl < rlmin) {
	*iret = 1;
	return 0;
    }

    rl /= two;
    goto L100;

/* ----------------------- END OF SUBROUTINE DLINSK ---------------------- */
} /* dlinsk_ */

/* Subroutine */ int dfnrmk_(integer *neq, doublereal *y, doublereal *t, 
	doublereal *yprime, doublereal *savr, doublereal *r__, doublereal *cj,
	 doublereal *tscale, doublereal *wt, doublereal *sqrtn, doublereal *
	rsqrtn, S_fp res, integer *ires, S_fp psol, integer *irin, integer *
	ier, doublereal *fnorm, doublereal *eplin, doublereal *wp, integer *
	iwp, doublereal *pwk, doublereal *rpar, integer *ipar)
{
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *), dcopy_(integer *, doublereal *, integer *, doublereal 
	    *, integer *);
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);


/* ***BEGIN PROLOGUE  DFNRMK */
/* ***REFER TO  DLINSK */
/* ***DATE WRITTEN   940830   (YYMMDD) */
/* ***REVISION DATE  951006   (SQRTN, RSQRTN, and scaling of WT added.) */
/* ***REVISION DATE  000628   TSCALE argument added. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DFNRMK calculates the scaled preconditioned norm of the nonlinear */
/*     function used in the nonlinear iteration for obtaining consistent */
/*     initial conditions.  Specifically, DFNRMK calculates the weighted */
/*     root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), */
/*     where P is the preconditioner matrix. */

/*     In addition to the parameters described in the calling program */
/*     DLINSK, the parameters represent */

/*     TSCALE -- Scale factor in T, used for stopping tests if nonzero. */
/*     IRIN   -- Flag showing whether the current residual vector is */
/*               input in SAVR.  1 means it is, 0 means it is not. */
/*     R      -- Array of length NEQ that contains */
/*               (P-inverse)*G(T,Y,YPRIME) on return. */
/*     FNORM  -- Scalar containing the weighted norm of R on return. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   RES, DCOPY, DSCAL, PSOL, DDWNRM */

/* ***END PROLOGUE  DFNRMK */


/* ----------------------------------------------------------------------- */
/*     Call RES routine if IRIN = 0. */
/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --ipar;
    --rpar;
    --pwk;
    --iwp;
    --wp;
    --wt;
    --r__;
    --savr;
    --yprime;
    --y;

    /* Function Body */
    if (*irin == 0) {
	*ires = 0;
	(*res)(t, &y[1], &yprime[1], cj, &savr[1], ires, &rpar[1], &ipar[1]);
	if (*ires < 0) {
	    return 0;
	}
    }
/* ----------------------------------------------------------------------- */
/*     Apply inverse of left preconditioner to vector R. */
/*     First scale WT array by 1/sqrt(N), and undo scaling afterward. */
/* ----------------------------------------------------------------------- */
    dcopy_(neq, &savr[1], &c__1, &r__[1], &c__1);
    dscal_(neq, rsqrtn, &wt[1], &c__1);
    *ier = 0;
    (*psol)(neq, t, &y[1], &yprime[1], &savr[1], &pwk[1], cj, &wt[1], &wp[1], 
	    &iwp[1], &r__[1], eplin, ier, &rpar[1], &ipar[1]);
    dscal_(neq, sqrtn, &wt[1], &c__1);
    if (*ier != 0) {
	return 0;
    }
/* ----------------------------------------------------------------------- */
/*     Calculate norm of R. */
/* ----------------------------------------------------------------------- */
    *fnorm = ddwnrm_(neq, &r__[1], &wt[1], &rpar[1], &ipar[1]);
    if (*tscale > 0.) {
	*fnorm = *fnorm * *tscale * abs(*cj);
    }

    return 0;
/* ----------------------- END OF SUBROUTINE DFNRMK ---------------------- */
} /* dfnrmk_ */

/* Subroutine */ int dnedk_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, S_fp res, S_fp jack, U_fp psol, doublereal *h__, 
	doublereal *wt, integer *jstart, integer *idid, doublereal *rpar, 
	integer *ipar, doublereal *phi, doublereal *gamma, doublereal *savr, 
	doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, 
	doublereal *cj, doublereal *cjold, doublereal *cjlast, doublereal *s, 
	doublereal *uround, doublereal *epli, doublereal *sqrtn, doublereal *
	rsqrtn, doublereal *epcon, integer *jcalc, integer *jflg, integer *
	kp1, integer *nonneg, integer *ntype, integer *iernls)
{
    /* Initialized data */

    static integer muldel = 0;
    static integer maxit = 4;
    static doublereal xrate = .25;

    /* System generated locals */
    integer phi_dim1, phi_offset, i__1, i__2;
    doublereal d__1;

    /* Local variables */
    integer i__, j, lwp;
    extern /* Subroutine */ int dnsk_(doublereal *, doublereal *, doublereal *
	    , integer *, S_fp, U_fp, doublereal *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     integer *, integer *, integer *, integer *);
    integer ires, liwp;
    doublereal temp1, temp2, eplin;
    integer ierpj, iersl;
    doublereal delnrm;
    integer iernew;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    doublereal tolnew;
    integer iertyp;


/* ***BEGIN PROLOGUE  DNEDK */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   891219   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  940701   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DNEDK solves a nonlinear system of */
/*     algebraic equations of the form */
/*     G(X,Y,YPRIME) = 0 for the unknown Y. */

/*     The method used is a matrix-free Newton scheme. */

/*     The parameters represent */
/*     X         -- Independent variable. */
/*     Y         -- Solution vector at x. */
/*     YPRIME    -- Derivative of solution vector */
/*                  after successful step. */
/*     NEQ       -- Number of equations to be integrated. */
/*     RES       -- External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     JACK     --  External user-supplied routine to update */
/*                  the preconditioner.  (This is optional). */
/*                  See JAC description for the case */
/*                  INFO(12) = 1 in the DDASPK prologue. */
/*     PSOL      -- External user-supplied routine to solve */
/*                  a linear system using preconditioning. */
/*                  (This is optional).  See explanation inside DDASPK. */
/*     H         -- Appropriate step size for this step. */
/*     WT        -- Vector of weights for error criterion. */
/*     JSTART    -- Indicates first call to this routine. */
/*                  If JSTART = 0, then this is the first call, */
/*                  otherwise it is not. */
/*     IDID      -- Completion flag, output by DNEDK. */
/*                  See IDID description in DDASPK prologue. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     PHI       -- Array of divided differences used by */
/*                  DNEDK.  The length is NEQ*(K+1), where */
/*                  K is the maximum order. */
/*     GAMMA     -- Array used to predict Y and YPRIME.  The length */
/*                  is K+1, where K is the maximum order. */
/*     SAVR      -- Work vector for DNEDK of length NEQ. */
/*     DELTA     -- Work vector for DNEDK of length NEQ. */
/*     E         -- Error accumulation vector for DNEDK of length NEQ. */
/*     WM,IWM    -- Real and integer arrays storing */
/*                  matrix information for linear system */
/*                  solvers, and various other information. */
/*     CJ        -- Parameter always proportional to 1/H. */
/*     CJOLD     -- Saves the value of CJ as of the last call to DITMD. */
/*                  Accounts for changes in CJ needed to */
/*                  decide whether to call DITMD. */
/*     CJLAST    -- Previous value of CJ. */
/*     S         -- A scalar determined by the approximate rate */
/*                  of convergence of the Newton iteration and used */
/*                  in the convergence test for the Newton iteration. */

/*                  If RATE is defined to be an estimate of the */
/*                  rate of convergence of the Newton iteration, */
/*                  then S = RATE/(1.D0-RATE). */

/*                  The closer RATE is to 0., the faster the Newton */
/*                  iteration is converging; the closer RATE is to 1., */
/*                  the slower the Newton iteration is converging. */

/*                  On the first Newton iteration with an up-dated */
/*                  preconditioner S = 100.D0, Thus the initial */
/*                  RATE of convergence is approximately 1. */

/*                  S is preserved from call to call so that the rate */
/*                  estimate from a previous step can be applied to */
/*                  the current step. */
/*     UROUND    -- Unit roundoff.  Not used here. */
/*     EPLI      -- convergence test constant. */
/*                  See DDASPK prologue for more details. */
/*     SQRTN     -- Square root of NEQ. */
/*     RSQRTN    -- reciprical of square root of NEQ. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     JCALC     -- Flag used to determine when to update */
/*                  the Jacobian matrix.  In general: */

/*                  JCALC = -1 ==> Call the DITMD routine to update */
/*                                 the Jacobian matrix. */
/*                  JCALC =  0 ==> Jacobian matrix is up-to-date. */
/*                  JCALC =  1 ==> Jacobian matrix is out-dated, */
/*                                 but DITMD will not be called unless */
/*                                 JCALC is set to -1. */
/*     JFLG      -- Flag showing whether a Jacobian routine is supplied. */
/*     KP1       -- The current order + 1;  updated across calls. */
/*     NONNEG    -- Flag to determine nonnegativity constraints. */
/*     NTYPE     -- Identification code for the DNEDK routine. */
/*                   1 ==> modified Newton; iterative linear solver. */
/*                   2 ==> modified Newton; user-supplied linear solver. */
/*     IERNLS    -- Error flag for nonlinear solver. */
/*                   0 ==> nonlinear solver converged. */
/*                   1 ==> recoverable error inside non-linear solver. */
/*                  -1 ==> unrecoverable error inside non-linear solver. */

/*     The following group of variables are passed as arguments to */
/*     the Newton iteration solver.  They are explained in greater detail */
/*     in DNSK: */
/*        TOLNEW, MULDEL, MAXIT, IERNEW */

/*     IERTYP -- Flag which tells whether this subroutine is correct. */
/*               0 ==> correct subroutine. */
/*               1 ==> incorrect subroutine. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   RES, JACK, DDWNRM, DNSK */

/* ***END PROLOGUE  DNEDK */




    /* Parameter adjustments */
    --y;
    --yprime;
    phi_dim1 = *neq;
    phi_offset = 1 + phi_dim1;
    phi -= phi_offset;
    --wt;
    --rpar;
    --ipar;
    --gamma;
    --savr;
    --delta;
    --e;
    --wm;
    --iwm;

    /* Function Body */

/*     Verify that this is the correct subroutine. */

    iertyp = 0;
    if (*ntype != 1) {
	iertyp = 1;
	goto L380;
    }

/*     If this is the first step, perform initializations. */

    if (*jstart == 0) {
	*cjold = *cj;
	*jcalc = -1;
	*s = 100.;
    }

/*     Perform all other initializations. */

    *iernls = 0;
    lwp = iwm[29];
    liwp = iwm[30];

/*     Decide whether to update the preconditioner. */

    if (*jflg != 0) {
	temp1 = (1. - xrate) / (xrate + 1.);
	temp2 = 1. / temp1;
	if (*cj / *cjold < temp1 || *cj / *cjold > temp2) {
	    *jcalc = -1;
	}
	if (*cj != *cjlast) {
	    *s = 100.;
	}
    } else {
	*jcalc = 0;
    }

/*     Looping point for updating preconditioner with current stepsize. */

L300:

/*     Initialize all error flags to zero. */

    ierpj = 0;
    ires = 0;
    iersl = 0;
    iernew = 0;

/*     Predict the solution and derivative and compute the tolerance */
/*     for the Newton iteration. */

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] = phi[i__ + phi_dim1];
/* L310: */
	yprime[i__] = 0.;
    }
    i__1 = *kp1;
    for (j = 2; j <= i__1; ++j) {
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    y[i__] += phi[i__ + j * phi_dim1];
/* L320: */
	    yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1];
	}
/* L330: */
    }
    eplin = *epli * *epcon;
    tolnew = eplin;

/*     Call RES to initialize DELTA. */

    ++iwm[12];
    (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ires < 0) {
	goto L380;
    }


/*     If indicated, update the preconditioner. */
/*     Set JCALC to 0 as an indicator that this has been done. */

    if (*jcalc == -1) {
	++iwm[13];
	*jcalc = 0;
	(*jack)((S_fp)res, &ires, neq, x, &y[1], &yprime[1], &wt[1], &delta[1]
		, &e[1], h__, cj, &wm[lwp], &iwm[liwp], &ierpj, &rpar[1], &
		ipar[1]);
	*cjold = *cj;
	*s = 100.;
	if (ires < 0) {
	    goto L380;
	}
	if (ierpj != 0) {
	    goto L380;
	}
    }

/*     Call the nonlinear Newton solver. */

    dnsk_(x, &y[1], &yprime[1], neq, (S_fp)res, (U_fp)psol, &wt[1], &rpar[1], 
	    &ipar[1], &savr[1], &delta[1], &e[1], &wm[1], &iwm[1], cj, sqrtn, 
	    rsqrtn, &eplin, epcon, s, &temp1, &tolnew, &muldel, &maxit, &ires,
	     &iersl, &iernew);

    if (iernew > 0 && *jcalc != 0) {

/*     The Newton iteration had a recoverable failure with an old */
/*     preconditioner.  Retry the step with a new preconditioner. */

	*jcalc = -1;
	goto L300;
    }

    if (iernew != 0) {
	goto L380;
    }

/*     The Newton iteration has converged.  If nonnegativity of */
/*     solution is required, set the solution nonnegative, if the */
/*     perturbation to do it is small enough.  If the change is too */
/*     large, then consider the corrector iteration to have failed. */

    if (*nonneg == 0) {
	goto L390;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L360: */
/* Computing MIN */
	d__1 = y[i__];
	delta[i__] = min(d__1,0.);
    }
    delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm > *epcon) {
	goto L380;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L370: */
	e[i__] -= delta[i__];
    }
    goto L390;


/*     Exits from nonlinear solver. */
/*     No convergence with current preconditioner. */
/*     Compute IERNLS and IDID accordingly. */

L380:
    if (ires <= -2 || iersl < 0 || iertyp != 0) {
	*iernls = -1;
	if (ires <= -2) {
	    *idid = -11;
	}
	if (iersl < 0) {
	    *idid = -13;
	}
	if (iertyp != 0) {
	    *idid = -15;
	}
    } else {
	*iernls = 1;
	if (ires == -1) {
	    *idid = -10;
	}
	if (ierpj != 0) {
	    *idid = -5;
	}
	if (iersl > 0) {
	    *idid = -14;
	}
    }


L390:
    *jcalc = 1;
    return 0;

/* ------END OF SUBROUTINE DNEDK------------------------------------------ */
} /* dnedk_ */

/* Subroutine */ int dnsk_(doublereal *x, doublereal *y, doublereal *yprime, 
	integer *neq, S_fp res, U_fp psol, doublereal *wt, doublereal *rpar, 
	integer *ipar, doublereal *savr, doublereal *delta, doublereal *e, 
	doublereal *wm, integer *iwm, doublereal *cj, doublereal *sqrtn, 
	doublereal *rsqrtn, doublereal *eplin, doublereal *epcon, doublereal *
	s, doublereal *confac, doublereal *tolnew, integer *muldel, integer *
	maxit, integer *ires, integer *iersl, integer *iernew)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2;

    /* Builtin functions */
    double pow_dd(doublereal *, doublereal *);

    /* Local variables */
    integer i__, m;
    doublereal rate, rhok;
    extern /* Subroutine */ int dslvk_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, S_fp, integer *, U_fp, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *);
    doublereal delnrm;
    extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    doublereal oldnrm;


/* ***BEGIN PROLOGUE  DNSK */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   891219   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  950126   (YYMMDD) */
/* ***REVISION DATE  000711   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     DNSK solves a nonlinear system of */
/*     algebraic equations of the form */
/*     G(X,Y,YPRIME) = 0 for the unknown Y. */

/*     The method used is a modified Newton scheme. */

/*     The parameters represent */

/*     X         -- Independent variable. */
/*     Y         -- Solution vector. */
/*     YPRIME    -- Derivative of solution vector. */
/*     NEQ       -- Number of unknowns. */
/*     RES       -- External user-supplied subroutine */
/*                  to evaluate the residual.  See RES description */
/*                  in DDASPK prologue. */
/*     PSOL      -- External user-supplied routine to solve */
/*                  a linear system using preconditioning. */
/*                  See explanation inside DDASPK. */
/*     WT        -- Vector of weights for error criterion. */
/*     RPAR,IPAR -- Real and integer arrays used for communication */
/*                  between the calling program and external user */
/*                  routines.  They are not altered within DASPK. */
/*     SAVR      -- Work vector for DNSK of length NEQ. */
/*     DELTA     -- Work vector for DNSK of length NEQ. */
/*     E         -- Error accumulation vector for DNSK of length NEQ. */
/*     WM,IWM    -- Real and integer arrays storing */
/*                  matrix information such as the matrix */
/*                  of partial derivatives, permutation */
/*                  vector, and various other information. */
/*     CJ        -- Parameter always proportional to 1/H (step size). */
/*     SQRTN     -- Square root of NEQ. */
/*     RSQRTN    -- reciprical of square root of NEQ. */
/*     EPLIN     -- Tolerance for linear system solver. */
/*     EPCON     -- Tolerance to test for convergence of the Newton */
/*                  iteration. */
/*     S         -- Used for error convergence tests. */
/*                  In the Newton iteration: S = RATE/(1.D0-RATE), */
/*                  where RATE is the estimated rate of convergence */
/*                  of the Newton iteration. */

/*                  The closer RATE is to 0., the faster the Newton */
/*                  iteration is converging; the closer RATE is to 1., */
/*                  the slower the Newton iteration is converging. */

/*                  The calling routine sends the initial value */
/*                  of S to the Newton iteration. */
/*     CONFAC    -- A residual scale factor to improve convergence. */
/*     TOLNEW    -- Tolerance on the norm of Newton correction in */
/*                  alternative Newton convergence test. */
/*     MULDEL    -- A flag indicating whether or not to multiply */
/*                  DELTA by CONFAC. */
/*                  0  ==> do not scale DELTA by CONFAC. */
/*                  1  ==> scale DELTA by CONFAC. */
/*     MAXIT     -- Maximum allowed number of Newton iterations. */
/*     IRES      -- Error flag returned from RES.  See RES description */
/*                  in DDASPK prologue.  If IRES = -1, then IERNEW */
/*                  will be set to 1. */
/*                  If IRES < -1, then IERNEW will be set to -1. */
/*     IERSL     -- Error flag for linear system solver. */
/*                  See IERSL description in subroutine DSLVK. */
/*                  If IERSL = 1, then IERNEW will be set to 1. */
/*                  If IERSL < 0, then IERNEW will be set to -1. */
/*     IERNEW    -- Error flag for Newton iteration. */
/*                   0  ==> Newton iteration converged. */
/*                   1  ==> recoverable error inside Newton iteration. */
/*                  -1  ==> unrecoverable error inside Newton iteration. */
/* ----------------------------------------------------------------------- */

/* ***ROUTINES CALLED */
/*   RES, DSLVK, DDWNRM */

/* ***END PROLOGUE  DNSK */




/*     Initialize Newton counter M and accumulation vector E. */

    /* Parameter adjustments */
    --iwm;
    --wm;
    --e;
    --delta;
    --savr;
    --ipar;
    --rpar;
    --wt;
    --yprime;
    --y;

    /* Function Body */
    m = 0;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
	e[i__] = 0.;
    }

/*     Corrector loop. */

L300:
    ++iwm[19];

/*     If necessary, multiply residual by convergence factor. */

    if (*muldel == 1) {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L320: */
	    delta[i__] *= *confac;
	}
    }

/*     Save residual in SAVR. */

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L340: */
	savr[i__] = delta[i__];
    }

/*     Compute a new iterate.  Store the correction in DELTA. */

    dslvk_(neq, &y[1], x, &yprime[1], &savr[1], &delta[1], &wt[1], &wm[1], &
	    iwm[1], (S_fp)res, ires, (U_fp)psol, iersl, cj, eplin, sqrtn, 
	    rsqrtn, &rhok, &rpar[1], &ipar[1]);
    if (*ires != 0 || *iersl != 0) {
	goto L380;
    }

/*     Update Y, E, and YPRIME. */

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] -= delta[i__];
	e[i__] -= delta[i__];
/* L360: */
	yprime[i__] -= *cj * delta[i__];
    }

/*     Test for convergence of the iteration. */

    delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (m == 0) {
	oldnrm = delnrm;
	if (delnrm <= *tolnew) {
	    goto L370;
	}
    } else {
	d__1 = delnrm / oldnrm;
	d__2 = 1. / m;
	rate = pow_dd(&d__1, &d__2);
	if (rate > .9) {
	    goto L380;
	}
	*s = rate / (1. - rate);
    }
    if (*s * delnrm <= *epcon) {
	goto L370;
    }

/*     The corrector has not yet converged.  Update M and test whether */
/*     the maximum number of iterations have been tried. */

    ++m;
    if (m >= *maxit) {
	goto L380;
    }

/*     Evaluate the residual, and go back to do another iteration. */

    ++iwm[12];
    (*res)(x, &y[1], &yprime[1], cj, &delta[1], ires, &rpar[1], &ipar[1]);
    if (*ires < 0) {
	goto L380;
    }
    goto L300;

/*     The iteration has converged. */

L370:
    return 0;

/*     The iteration has not converged.  Set IERNEW appropriately. */

L380:
    if (*ires <= -2 || *iersl < 0) {
	*iernew = -1;
    } else {
	*iernew = 1;
    }
    return 0;


/* ------END OF SUBROUTINE DNSK------------------------------------------- */
} /* dnsk_ */

/* Subroutine */ int dslvk_(integer *neq, doublereal *y, doublereal *tn, 
	doublereal *yprime, doublereal *savr, doublereal *x, doublereal *ewt, 
	doublereal *wm, integer *iwm, S_fp res, integer *ires, U_fp psol, 
	integer *iersl, doublereal *cj, doublereal *eplin, doublereal *sqrtn, 
	doublereal *rsqrtn, doublereal *rhok, doublereal *rpar, integer *ipar)
{
    /* Initialized data */

    static integer irst = 1;

    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    integer i__, lq, lr, lv, lz, ldl, nli, nre, kmp, lwk, nps, lwp, ncfl, 
	    lhes, lgmr, maxl, nres, npsl, liwp, iflag;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *), dcopy_(integer *, doublereal *, integer *, doublereal 
	    *, integer *);
    integer miter, nrmax, nrsts, maxlp1;
    extern /* Subroutine */ int dspigm_(integer *, doublereal *, doublereal *,
	     doublereal *, doublereal *, doublereal *, doublereal *, integer *
	    , integer *, integer *, doublereal *, doublereal *, S_fp, integer 
	    *, integer *, U_fp, integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *, integer *, 
	    integer *, doublereal *, integer *);


/* ***BEGIN PROLOGUE  DSLVK */
/* ***REFER TO  DDASPK */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  940928   Removed MNEWT and added RHOK in call list. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* DSLVK uses a restart algorithm and interfaces to DSPIGM for */
/* the solution of the linear system arising from a Newton iteration. */

/* In addition to variables described elsewhere, */
/* communication with DSLVK uses the following variables.. */
/* WM    = Real work space containing data for the algorithm */
/*         (Krylov basis vectors, Hessenberg matrix, etc.). */
/* IWM   = Integer work space containing data for the algorithm. */
/* X     = The right-hand side vector on input, and the solution vector */
/*         on output, of length NEQ. */
/* IRES  = Error flag from RES. */
/* IERSL = Output flag .. */
/*         IERSL =  0 means no trouble occurred (or user RES routine */
/*                    returned IRES < 0) */
/*         IERSL =  1 means the iterative method failed to converge */
/*                    (DSPIGM returned IFLAG > 0.) */
/*         IERSL = -1 means there was a nonrecoverable error in the */
/*                    iterative solver, and an error exit will occur. */
/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   DSCAL, DCOPY, DSPIGM */

/* ***END PROLOGUE  DSLVK */




/* ----------------------------------------------------------------------- */
/* IRST is set to 1, to indicate restarting is in effect. */
/* NRMAX is the maximum number of restarts. */
/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --ipar;
    --rpar;
    --iwm;
    --wm;
    --ewt;
    --x;
    --savr;
    --yprime;
    --y;

    /* Function Body */

    liwp = iwm[30];
    nli = iwm[20];
    nps = iwm[21];
    ncfl = iwm[16];
    nre = iwm[12];
    lwp = iwm[29];
    maxl = iwm[24];
    kmp = iwm[25];
    nrmax = iwm[26];
    miter = iwm[23];
    *iersl = 0;
    *ires = 0;
/* ----------------------------------------------------------------------- */
/* Use a restarting strategy to solve the linear system */
/* P*X = -F.  Parse the work vector, and perform initializations. */
/* Note that zero is the initial guess for X. */
/* ----------------------------------------------------------------------- */
    maxlp1 = maxl + 1;
    lv = 1;
    lr = lv + *neq * maxl;
    lhes = lr + *neq + 1;
    lq = lhes + maxl * maxlp1;
    lwk = lq + (maxl << 1);
/* Computing MIN */
    i__1 = 1, i__2 = maxl - kmp;
    ldl = lwk + min(i__1,i__2) * *neq;
    lz = ldl + *neq;
    dscal_(neq, rsqrtn, &ewt[1], &c__1);
    dcopy_(neq, &x[1], &c__1, &wm[lr], &c__1);
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L110: */
	x[i__] = 0.;
    }
/* ----------------------------------------------------------------------- */
/* Top of loop for the restart algorithm.  Initial pass approximates */
/* X and sets up a transformed system to perform subsequent restarts */
/* to update X.  NRSTS is initialized to -1, because restarting */
/* does not occur until after the first pass. */
/* Update NRSTS; conditionally copy DL to R; call the DSPIGM */
/* algorithm to solve A*Z = R;  updated counters;  update X with */
/* the residual solution. */
/* Note:  if convergence is not achieved after NRMAX restarts, */
/* then the linear solver is considered to have failed. */
/* ----------------------------------------------------------------------- */
    nrsts = -1;
L115:
    ++nrsts;
    if (nrsts > 0) {
	dcopy_(neq, &wm[ldl], &c__1, &wm[lr], &c__1);
    }
    dspigm_(neq, tn, &y[1], &yprime[1], &savr[1], &wm[lr], &ewt[1], &maxl, &
	    maxlp1, &kmp, eplin, cj, (S_fp)res, ires, &nres, (U_fp)psol, &
	    npsl, &wm[lz], &wm[lv], &wm[lhes], &wm[lq], &lgmr, &wm[lwp], &iwm[
	    liwp], &wm[lwk], &wm[ldl], rhok, &iflag, &irst, &nrsts, &rpar[1], 
	    &ipar[1]);
    nli += lgmr;
    nps += npsl;
    nre += nres;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L120: */
	x[i__] += wm[lz + i__ - 1];
    }
    if (iflag == 1 && nrsts < nrmax && *ires == 0) {
	goto L115;
    }
/* ----------------------------------------------------------------------- */
/* The restart scheme is finished.  Test IRES and IFLAG to see if */
/* convergence was not achieved, and set flags accordingly. */
/* ----------------------------------------------------------------------- */
    if (*ires < 0) {
	++ncfl;
    } else if (iflag != 0) {
	++ncfl;
	if (iflag > 0) {
	    *iersl = 1;
	}
	if (iflag < 0) {
	    *iersl = -1;
	}
    }
/* ----------------------------------------------------------------------- */
/* Update IWM with counters, rescale EWT, and return. */
/* ----------------------------------------------------------------------- */
    iwm[20] = nli;
    iwm[21] = nps;
    iwm[16] = ncfl;
    iwm[12] = nre;
    dscal_(neq, sqrtn, &ewt[1], &c__1);
    return 0;

/* ------END OF SUBROUTINE DSLVK------------------------------------------ */
} /* dslvk_ */

/* Subroutine */ int dspigm_(integer *neq, doublereal *tn, doublereal *y, 
	doublereal *yprime, doublereal *savr, doublereal *r__, doublereal *
	wght, integer *maxl, integer *maxlp1, integer *kmp, doublereal *eplin,
	 doublereal *cj, S_fp res, integer *ires, integer *nre, S_fp psol, 
	integer *npsl, doublereal *z__, doublereal *v, doublereal *hes, 
	doublereal *q, integer *lgmr, doublereal *wp, integer *iwp, 
	doublereal *wk, doublereal *dl, doublereal *rhok, integer *iflag, 
	integer *irst, integer *nrsts, doublereal *rpar, integer *ipar)
{
    /* System generated locals */
    integer v_dim1, v_offset, hes_dim1, hes_offset, i__1, i__2, i__3;
    doublereal d__1;

    /* Local variables */
    doublereal c__;
    integer i__, j, k;
    doublereal s;
    integer i2, ll, ip1, ier;
    doublereal tem, rho;
    integer llp1, info;
    extern /* Subroutine */ int datv_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, S_fp, integer *, S_fp, doublereal *, doublereal *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *, integer *, doublereal *, integer *);
    doublereal prod, rnrm;
    extern doublereal dnrm2_(integer *, doublereal *, integer *);
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *), dhels_(doublereal *, integer *, integer *, doublereal 
	    *, doublereal *), dheqr_(doublereal *, integer *, integer *, 
	    doublereal *, integer *, integer *);
    doublereal dlnrm;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *), dorth_(doublereal *, doublereal *, 
	    doublereal *, integer *, integer *, integer *, integer *, 
	    doublereal *), daxpy_(integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *);
    integer maxlm1;
    doublereal snormw;


/* ***BEGIN PROLOGUE  DSPIGM */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */
/* ***REVISION DATE  940927   Removed MNEWT and added RHOK in call list. */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* This routine solves the linear system A * Z = R using a scaled */
/* preconditioned version of the generalized minimum residual method. */
/* An initial guess of Z = 0 is assumed. */

/*      On entry */

/*          NEQ = Problem size, passed to PSOL. */

/*           TN = Current Value of T. */

/*            Y = Array Containing current dependent variable vector. */

/*       YPRIME = Array Containing current first derivative of Y. */

/*         SAVR = Array containing current value of G(T,Y,YPRIME). */

/*            R = The right hand side of the system A*Z = R. */
/*                R is also used as work space when computing */
/*                the final approximation and will therefore be */
/*                destroyed. */
/*                (R is the same as V(*,MAXL+1) in the call to DSPIGM.) */

/*         WGHT = The vector of length NEQ containing the nonzero */
/*                elements of the diagonal scaling matrix. */

/*         MAXL = The maximum allowable order of the matrix H. */

/*       MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. */

/*          KMP = The number of previous vectors the new vector, VNEW, */
/*                must be made orthogonal to.  (KMP .LE. MAXL.) */

/*        EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. */

/*           CJ = Scalar proportional to current value of */
/*                1/(step size H). */

/*           WK = Real work array used by routine DATV and PSOL. */

/*           DL = Real work array used for calculation of the residual */
/*                norm RHO when the method is incomplete (KMP.LT.MAXL) */
/*                and/or when using restarting. */

/*           WP = Real work array used by preconditioner PSOL. */

/*          IWP = Integer work array used by preconditioner PSOL. */

/*         IRST = Method flag indicating if restarting is being */
/*                performed.  IRST .GT. 0 means restarting is active, */
/*                while IRST = 0 means restarting is not being used. */

/*        NRSTS = Counter for the number of restarts on the current */
/*                call to DSPIGM.  If NRSTS .GT. 0, then the residual */
/*                R is already scaled, and so scaling of R is not */
/*                necessary. */


/*      On Return */

/*         Z    = The final computed approximation to the solution */
/*                of the system A*Z = R. */

/*         LGMR = The number of iterations performed and */
/*                the current order of the upper Hessenberg */
/*                matrix HES. */

/*         NRE  = The number of calls to RES (i.e. DATV) */

/*         NPSL = The number of calls to PSOL. */

/*         V    = The neq by (LGMR+1) array containing the LGMR */
/*                orthogonal vectors V(*,1) to V(*,LGMR). */

/*         HES  = The upper triangular factor of the QR decomposition */
/*                of the (LGMR+1) by LGMR upper Hessenberg matrix whose */
/*                entries are the scaled inner-products of A*V(*,I) */
/*                and V(*,K). */

/*         Q    = Real array of length 2*MAXL containing the components */
/*                of the givens rotations used in the QR decomposition */
/*                of HES.  It is loaded in DHEQR and used in DHELS. */

/*         IRES = Error flag from RES. */

/*           DL = Scaled preconditioned residual, */
/*                (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when */
/*                performing restarts of the Krylov iteration. */

/*         RHOK = Weighted norm of final preconditioned residual. */

/*        IFLAG = Integer error flag.. */
/*                0 Means convergence in LGMR iterations, LGMR.LE.MAXL. */
/*                1 Means the convergence test did not pass in MAXL */
/*                  iterations, but the new residual norm (RHO) is */
/*                  .LT. the old residual norm (RNRM), and so Z is */
/*                  computed. */
/*                2 Means the convergence test did not pass in MAXL */
/*                  iterations, new residual norm (RHO) .GE. old residual */
/*                  norm (RNRM), and the initial guess, Z = 0, is */
/*                  returned. */
/*                3 Means there was a recoverable error in PSOL */
/*                  caused by the preconditioner being out of date. */
/*               -1 Means there was an unrecoverable error in PSOL. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY */

/* ***END PROLOGUE  DSPIGM */


    /* Parameter adjustments */
    v_dim1 = *neq;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    --y;
    --yprime;
    --savr;
    --r__;
    --wght;
    hes_dim1 = *maxlp1;
    hes_offset = 1 + hes_dim1;
    hes -= hes_offset;
    --z__;
    --q;
    --wp;
    --iwp;
    --wk;
    --dl;
    --rpar;
    --ipar;

    /* Function Body */
    ier = 0;
    *iflag = 0;
    *lgmr = 0;
    *npsl = 0;
    *nre = 0;
/* ----------------------------------------------------------------------- */
/* The initial guess for Z is 0.  The initial residual is therefore */
/* the vector R.  Initialize Z to 0. */
/* ----------------------------------------------------------------------- */
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	z__[i__] = 0.;
    }
/* ----------------------------------------------------------------------- */
/* Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. */
/* Form V(*,1), the scaled preconditioned right hand side. */
/* ----------------------------------------------------------------------- */
    if (*nrsts == 0) {
	(*psol)(neq, tn, &y[1], &yprime[1], &savr[1], &wk[1], cj, &wght[1], &
		wp[1], &iwp[1], &r__[1], eplin, &ier, &rpar[1], &ipar[1]);
	*npsl = 1;
	if (ier != 0) {
	    goto L300;
	}
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L30: */
	    v[i__ + v_dim1] = r__[i__] * wght[i__];
	}
    } else {
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
/* L35: */
	    v[i__ + v_dim1] = r__[i__];
	}
    }
/* ----------------------------------------------------------------------- */
/* Calculate norm of scaled vector V(*,1) and normalize it */
/* If, however, the norm of V(*,1) (i.e. the norm of the preconditioned */
/* residual) is .le. EPLIN, then return with Z=0. */
/* ----------------------------------------------------------------------- */
    rnrm = dnrm2_(neq, &v[v_offset], &c__1);
    if (rnrm <= *eplin) {
	*rhok = rnrm;
	return 0;
    }
    tem = 1. / rnrm;
    dscal_(neq, &tem, &v[v_dim1 + 1], &c__1);
/* ----------------------------------------------------------------------- */
/* Zero out the HES array. */
/* ----------------------------------------------------------------------- */
    i__1 = *maxl;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *maxlp1;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* L60: */
	    hes[i__ + j * hes_dim1] = 0.;
	}
/* L65: */
    }
/* ----------------------------------------------------------------------- */
/* Main loop to compute the vectors V(*,2) to V(*,MAXL). */
/* The running product PROD is needed for the convergence test. */
/* ----------------------------------------------------------------------- */
    prod = 1.;
    i__1 = *maxl;
    for (ll = 1; ll <= i__1; ++ll) {
	*lgmr = ll;
/* ----------------------------------------------------------------------- */
/* Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is */
/* the matrix A with scaling and inverse preconditioner factors applied. */
/* Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). */
/* call routine DHEQR to update the factors of HES. */
/* ----------------------------------------------------------------------- */
	datv_(neq, &y[1], tn, &yprime[1], &savr[1], &v[ll * v_dim1 + 1], &
		wght[1], &z__[1], (S_fp)res, ires, (S_fp)psol, &v[(ll + 1) * 
		v_dim1 + 1], &wk[1], &wp[1], &iwp[1], cj, eplin, &ier, nre, 
		npsl, &rpar[1], &ipar[1]);
	if (*ires < 0) {
	    return 0;
	}
	if (ier != 0) {
	    goto L300;
	}
	dorth_(&v[(ll + 1) * v_dim1 + 1], &v[v_offset], &hes[hes_offset], neq,
		 &ll, maxlp1, kmp, &snormw);
	hes[ll + 1 + ll * hes_dim1] = snormw;
	dheqr_(&hes[hes_offset], maxlp1, &ll, &q[1], &info, &ll);
	if (info == ll) {
	    goto L120;
	}
/* ----------------------------------------------------------------------- */
/* Update RHO, the estimate of the norm of the residual R - A*ZL. */
/* If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not */
/* necessarily orthogonal for LL .GT. KMP.  The vector DL must then */
/* be computed, and its norm used in the calculation of RHO. */
/* ----------------------------------------------------------------------- */
	prod *= q[ll * 2];
	rho = (d__1 = prod * rnrm, abs(d__1));
	if (ll > *kmp && *kmp < *maxl) {
	    if (ll == *kmp + 1) {
		dcopy_(neq, &v[v_dim1 + 1], &c__1, &dl[1], &c__1);
		i__2 = *kmp;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    ip1 = i__ + 1;
		    i2 = i__ << 1;
		    s = q[i2];
		    c__ = q[i2 - 1];
		    i__3 = *neq;
		    for (k = 1; k <= i__3; ++k) {
/* L70: */
			dl[k] = s * dl[k] + c__ * v[k + ip1 * v_dim1];
		    }
/* L75: */
		}
	    }
	    s = q[ll * 2];
	    c__ = q[(ll << 1) - 1] / snormw;
	    llp1 = ll + 1;
	    i__2 = *neq;
	    for (k = 1; k <= i__2; ++k) {
/* L80: */
		dl[k] = s * dl[k] + c__ * v[k + llp1 * v_dim1];
	    }
	    dlnrm = dnrm2_(neq, &dl[1], &c__1);
	    rho *= dlnrm;
	}
/* ----------------------------------------------------------------------- */
/* Test for convergence.  If passed, compute approximation ZL. */
/* If failed and LL .LT. MAXL, then continue iterating. */
/* ----------------------------------------------------------------------- */
	if (rho <= *eplin) {
	    goto L200;
	}
	if (ll == *maxl) {
	    goto L100;
	}
/* ----------------------------------------------------------------------- */
/* Rescale so that the norm of V(1,LL+1) is one. */
/* ----------------------------------------------------------------------- */
	tem = 1. / snormw;
	dscal_(neq, &tem, &v[(ll + 1) * v_dim1 + 1], &c__1);
/* L90: */
    }
L100:
    if (rho < rnrm) {
	goto L150;
    }
L120:
    *iflag = 2;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L130: */
	z__[i__] = 0.;
    }
    return 0;
L150:
    *iflag = 1;
/* ----------------------------------------------------------------------- */
/* The tolerance was not met, but the residual norm was reduced. */
/* If performing restarting (IRST .gt. 0) calculate the residual vector */
/* RL and store it in the DL array.  If the incomplete version is */
/* being used (KMP .lt. MAXL) then DL has already been calculated. */
/* ----------------------------------------------------------------------- */
    if (*irst > 0) {
	if (*kmp == *maxl) {

/*           Calculate DL from the V(I)'s. */

	    dcopy_(neq, &v[v_dim1 + 1], &c__1, &dl[1], &c__1);
	    maxlm1 = *maxl - 1;
	    i__1 = maxlm1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		ip1 = i__ + 1;
		i2 = i__ << 1;
		s = q[i2];
		c__ = q[i2 - 1];
		i__2 = *neq;
		for (k = 1; k <= i__2; ++k) {
/* L170: */
		    dl[k] = s * dl[k] + c__ * v[k + ip1 * v_dim1];
		}
/* L175: */
	    }
	    s = q[*maxl * 2];
	    c__ = q[(*maxl << 1) - 1] / snormw;
	    i__1 = *neq;
	    for (k = 1; k <= i__1; ++k) {
/* L180: */
		dl[k] = s * dl[k] + c__ * v[k + *maxlp1 * v_dim1];
	    }
	}

/*        Scale DL by RNRM*PROD to obtain the residual RL. */

	tem = rnrm * prod;
	dscal_(neq, &tem, &dl[1], &c__1);
    }
/* ----------------------------------------------------------------------- */
/* Compute the approximation ZL to the solution. */
/* Since the vector Z was used as work space, and the initial guess */
/* of the Newton correction is zero, Z must be reset to zero. */
/* ----------------------------------------------------------------------- */
L200:
    ll = *lgmr;
    llp1 = ll + 1;
    i__1 = llp1;
    for (k = 1; k <= i__1; ++k) {
/* L210: */
	r__[k] = 0.;
    }
    r__[1] = rnrm;
    dhels_(&hes[hes_offset], maxlp1, &ll, &q[1], &r__[1]);
    i__1 = *neq;
    for (k = 1; k <= i__1; ++k) {
/* L220: */
	z__[k] = 0.;
    }
    i__1 = ll;
    for (i__ = 1; i__ <= i__1; ++i__) {
	daxpy_(neq, &r__[i__], &v[i__ * v_dim1 + 1], &c__1, &z__[1], &c__1);
/* L230: */
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L240: */
	z__[i__] /= wght[i__];
    }
/* Load RHO into RHOK. */
    *rhok = rho;
    return 0;
/* ----------------------------------------------------------------------- */
/* This block handles error returns forced by routine PSOL. */
/* ----------------------------------------------------------------------- */
L300:
    if (ier < 0) {
	*iflag = -1;
    }
    if (ier > 0) {
	*iflag = 3;
    }

    return 0;

/* ------END OF SUBROUTINE DSPIGM----------------------------------------- */
} /* dspigm_ */

/* Subroutine */ int datv_(integer *neq, doublereal *y, doublereal *tn, 
	doublereal *yprime, doublereal *savr, doublereal *v, doublereal *wght,
	 doublereal *yptem, S_fp res, integer *ires, S_fp psol, doublereal *
	z__, doublereal *vtem, doublereal *wp, integer *iwp, doublereal *cj, 
	doublereal *eplin, integer *ier, integer *nre, integer *npsl, 
	doublereal *rpar, integer *ipar)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer i__;


/* ***BEGIN PROLOGUE  DATV */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* This routine computes the product */

/*   Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), */

/* where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, */
/* and A involves the past history of Y.  The quantity CJ*(Y-A) is */
/* an approximation to the first derivative of Y and is stored */
/* in the array YPRIME.  Note that dF/dY = dG/dY + CJ*dG/dYPRIME. */

/* D is a diagonal scaling matrix, and P is the left preconditioning */
/* matrix.  V is assumed to have L2 norm equal to 1. */
/* The product is stored in Z and is computed by means of a */
/* difference quotient, a call to RES, and one call to PSOL. */

/*      On entry */

/*          NEQ = Problem size, passed to RES and PSOL. */

/*            Y = Array containing current dependent variable vector. */

/*       YPRIME = Array containing current first derivative of y. */

/*         SAVR = Array containing current value of G(T,Y,YPRIME). */

/*            V = Real array of length NEQ (can be the same array as Z). */

/*         WGHT = Array of length NEQ containing scale factors. */
/*                1/WGHT(I) are the diagonal elements of the matrix D. */

/*        YPTEM = Work array of length NEQ. */

/*         VTEM = Work array of length NEQ used to store the */
/*                unscaled version of V. */

/*         WP = Real work array used by preconditioner PSOL. */

/*         IWP = Integer work array used by preconditioner PSOL. */

/*           CJ = Scalar proportional to current value of */
/*                1/(step size H). */


/*      On return */

/*            Z = Array of length NEQ containing desired scaled */
/*                matrix-vector product. */

/*         IRES = Error flag from RES. */

/*          IER = Error flag from PSOL. */

/*         NRE  = The number of calls to RES. */

/*         NPSL = The number of calls to PSOL. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   RES, PSOL */

/* ***END PROLOGUE  DATV */


    /* Parameter adjustments */
    --ipar;
    --rpar;
    --iwp;
    --wp;
    --vtem;
    --z__;
    --yptem;
    --wght;
    --v;
    --savr;
    --yprime;
    --y;

    /* Function Body */
    *ires = 0;
/* ----------------------------------------------------------------------- */
/* Set VTEM = D * V. */
/* ----------------------------------------------------------------------- */
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
	vtem[i__] = v[i__] / wght[i__];
    }
    *ier = 0;
/* ----------------------------------------------------------------------- */
/* Store Y in Z and increment Z by VTEM. */
/* Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. */
/* ----------------------------------------------------------------------- */
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yptem[i__] = yprime[i__] + vtem[i__] * *cj;
/* L20: */
	z__[i__] = y[i__] + vtem[i__];
    }
/* ----------------------------------------------------------------------- */
/* Call RES with incremented Y, YPRIME arguments */
/* stored in Z, YPTEM.  VTEM is overwritten with new residual. */
/* ----------------------------------------------------------------------- */
    (*res)(tn, &z__[1], &yptem[1], cj, &vtem[1], ires, &rpar[1], &ipar[1]);
    ++(*nre);
    if (*ires < 0) {
	return 0;
    }
/* ----------------------------------------------------------------------- */
/* Set Z = (dF/dY) * VBAR using difference quotient. */
/* (VBAR is old value of VTEM before calling RES) */
/* ----------------------------------------------------------------------- */
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L70: */
	z__[i__] = vtem[i__] - savr[i__];
    }
/* ----------------------------------------------------------------------- */
/* Apply inverse of left preconditioner to Z. */
/* ----------------------------------------------------------------------- */
    (*psol)(neq, tn, &y[1], &yprime[1], &savr[1], &yptem[1], cj, &wght[1], &
	    wp[1], &iwp[1], &z__[1], eplin, ier, &rpar[1], &ipar[1]);
    ++(*npsl);
    if (*ier != 0) {
	return 0;
    }
/* ----------------------------------------------------------------------- */
/* Apply D-inverse to Z and return. */
/* ----------------------------------------------------------------------- */
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L90: */
	z__[i__] *= wght[i__];
    }
    return 0;

/* ------END OF SUBROUTINE DATV------------------------------------------- */
} /* datv_ */

/* Subroutine */ int dorth_(doublereal *vnew, doublereal *v, doublereal *hes, 
	integer *n, integer *ll, integer *ldhes, integer *kmp, doublereal *
	snormw)
{
    /* System generated locals */
    integer v_dim1, v_offset, hes_dim1, hes_offset, i__1, i__2;
    doublereal d__1, d__2, d__3;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    integer i__, i0;
    doublereal arg, tem;
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    doublereal vnrm;
    extern doublereal dnrm2_(integer *, doublereal *, integer *);
    extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *);
    doublereal sumdsq;


/* ***BEGIN PROLOGUE  DORTH */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* This routine orthogonalizes the vector VNEW against the previous */
/* KMP vectors in the V array.  It uses a modified Gram-Schmidt */
/* orthogonalization procedure with conditional reorthogonalization. */

/*      On entry */

/*         VNEW = The vector of length N containing a scaled product */
/*                OF The Jacobian and the vector V(*,LL). */

/*         V    = The N x LL array containing the previous LL */
/*                orthogonal vectors V(*,1) to V(*,LL). */

/*         HES  = An LL x LL upper Hessenberg matrix containing, */
/*                in HES(I,K), K.LT.LL, scaled inner products of */
/*                A*V(*,K) and V(*,I). */

/*        LDHES = The leading dimension of the HES array. */

/*         N    = The order of the matrix A, and the length of VNEW. */

/*         LL   = The current order of the matrix HES. */

/*          KMP = The number of previous vectors the new vector VNEW */
/*                must be made orthogonal to (KMP .LE. MAXL). */


/*      On return */

/*         VNEW = The new vector orthogonal to V(*,I0), */
/*                where I0 = MAX(1, LL-KMP+1). */

/*         HES  = Upper Hessenberg matrix with column LL filled in with */
/*                scaled inner products of A*V(*,LL) and V(*,I). */

/*       SNORMW = L-2 norm of VNEW. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   DDOT, DNRM2, DAXPY */

/* ***END PROLOGUE  DORTH */


/* ----------------------------------------------------------------------- */
/* Get norm of unaltered VNEW for later use. */
/* ----------------------------------------------------------------------- */
    /* Parameter adjustments */
    --vnew;
    v_dim1 = *n;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    hes_dim1 = *ldhes;
    hes_offset = 1 + hes_dim1;
    hes -= hes_offset;

    /* Function Body */
    vnrm = dnrm2_(n, &vnew[1], &c__1);
/* ----------------------------------------------------------------------- */
/* Do Modified Gram-Schmidt on VNEW = A*V(LL). */
/* Scaled inner products give new column of HES. */
/* Projections of earlier vectors are subtracted from VNEW. */
/* ----------------------------------------------------------------------- */
/* Computing MAX */
    i__1 = 1, i__2 = *ll - *kmp + 1;
    i0 = max(i__1,i__2);
    i__1 = *ll;
    for (i__ = i0; i__ <= i__1; ++i__) {
	hes[i__ + *ll * hes_dim1] = ddot_(n, &v[i__ * v_dim1 + 1], &c__1, &
		vnew[1], &c__1);
	tem = -hes[i__ + *ll * hes_dim1];
	daxpy_(n, &tem, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1);
/* L10: */
    }
/* ----------------------------------------------------------------------- */
/* Compute SNORMW = norm of VNEW. */
/* If VNEW is small compared to its input value (in norm), then */
/* Reorthogonalize VNEW to V(*,1) through V(*,LL). */
/* Correct if relative correction exceeds 1000*(unit roundoff). */
/* Finally, correct SNORMW using the dot products involved. */
/* ----------------------------------------------------------------------- */
    *snormw = dnrm2_(n, &vnew[1], &c__1);
    if (vnrm + *snormw * .001 != vnrm) {
	return 0;
    }
    sumdsq = 0.;
    i__1 = *ll;
    for (i__ = i0; i__ <= i__1; ++i__) {
	tem = -ddot_(n, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1);
	if (hes[i__ + *ll * hes_dim1] + tem * .001 == hes[i__ + *ll * 
		hes_dim1]) {
	    goto L30;
	}
	hes[i__ + *ll * hes_dim1] -= tem;
	daxpy_(n, &tem, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1);
/* Computing 2nd power */
	d__1 = tem;
	sumdsq += d__1 * d__1;
L30:
	;
    }
    if (sumdsq == 0.) {
	return 0;
    }
/* Computing MAX */
/* Computing 2nd power */
    d__3 = *snormw;
    d__1 = 0., d__2 = d__3 * d__3 - sumdsq;
    arg = max(d__1,d__2);
    *snormw = sqrt(arg);
    return 0;

/* ------END OF SUBROUTINE DORTH------------------------------------------ */
} /* dorth_ */

/* Subroutine */ int dheqr_(doublereal *a, integer *lda, integer *n, 
	doublereal *q, integer *info, integer *ijob)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    doublereal c__;
    integer i__, j, k;
    doublereal s, t, t1, t2;
    integer iq, km1, kp1, nm1;


/* ***BEGIN PROLOGUE  DHEQR */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */

/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/*     This routine performs a QR decomposition of an upper */
/*     Hessenberg matrix A.  There are two options available: */

/*          (1)  performing a fresh decomposition */
/*          (2)  updating the QR factors by adding a row and A */
/*               column to the matrix A. */

/*     DHEQR decomposes an upper Hessenberg matrix by using Givens */
/*     rotations. */

/*     On entry */

/*        A       DOUBLE PRECISION(LDA, N) */
/*                The matrix to be decomposed. */

/*        LDA     INTEGER */
/*                The leading dimension of the array A. */

/*        N       INTEGER */
/*                A is an (N+1) by N Hessenberg matrix. */

/*        IJOB    INTEGER */
/*                = 1     Means that a fresh decomposition of the */
/*                        matrix A is desired. */
/*                .GE. 2  Means that the current decomposition of A */
/*                        will be updated by the addition of a row */
/*                        and a column. */
/*     On return */

/*        A       The upper triangular matrix R. */
/*                The factorization can be written Q*A = R, where */
/*                Q is a product of Givens rotations and R is upper */
/*                triangular. */

/*        Q       DOUBLE PRECISION(2*N) */
/*                The factors C and S of each Givens rotation used */
/*                in decomposing A. */

/*        INFO    INTEGER */
/*                = 0  normal value. */
/*                = K  If  A(K,K) .EQ. 0.0.  This is not an error */
/*                     condition for this subroutine, but it does */
/*                     indicate that DHELS will divide by zero */
/*                     if called. */

/*     Modification of LINPACK. */
/*     Peter Brown, Lawrence Livermore Natl. Lab. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED (NONE) */

/* ***END PROLOGUE  DHEQR */


    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --q;

    /* Function Body */
    if (*ijob > 1) {
	goto L70;
    }
/* ----------------------------------------------------------------------- */
/* A new factorization is desired. */
/* ----------------------------------------------------------------------- */

/*     QR decomposition without pivoting. */

    *info = 0;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	km1 = k - 1;
	kp1 = k + 1;

/*           Compute Kth column of R. */
/*           First, multiply the Kth column of A by the previous */
/*           K-1 Givens rotations. */

	if (km1 < 1) {
	    goto L20;
	}
	i__2 = km1;
	for (j = 1; j <= i__2; ++j) {
	    i__ = ((j - 1) << 1) + 1;
	    t1 = a[j + k * a_dim1];
	    t2 = a[j + 1 + k * a_dim1];
	    c__ = q[i__];
	    s = q[i__ + 1];
	    a[j + k * a_dim1] = c__ * t1 - s * t2;
	    a[j + 1 + k * a_dim1] = s * t1 + c__ * t2;
/* L10: */
	}

/*           Compute Givens components C and S. */

L20:
	iq = (km1 << 1) + 1;
	t1 = a[k + k * a_dim1];
	t2 = a[kp1 + k * a_dim1];
	if (t2 != 0.) {
	    goto L30;
	}
	c__ = 1.;
	s = 0.;
	goto L50;
L30:
	if (abs(t2) < abs(t1)) {
	    goto L40;
	}
	t = t1 / t2;
	s = -1. / sqrt(t * t + 1.);
	c__ = -s * t;
	goto L50;
L40:
	t = t2 / t1;
	c__ = 1. / sqrt(t * t + 1.);
	s = -c__ * t;
L50:
	q[iq] = c__;
	q[iq + 1] = s;
	a[k + k * a_dim1] = c__ * t1 - s * t2;
	if (a[k + k * a_dim1] == 0.) {
	    *info = k;
	}
/* L60: */
    }
    return 0;
/* ----------------------------------------------------------------------- */
/* The old factorization of A will be updated.  A row and a column */
/* has been added to the matrix A. */
/* N by N-1 is now the old size of the matrix. */
/* ----------------------------------------------------------------------- */
L70:
    nm1 = *n - 1;
/* ----------------------------------------------------------------------- */
/* Multiply the new column by the N previous Givens rotations. */
/* ----------------------------------------------------------------------- */
    i__1 = nm1;
    for (k = 1; k <= i__1; ++k) {
	i__ = ((k - 1) << 1) + 1;
	t1 = a[k + *n * a_dim1];
	t2 = a[k + 1 + *n * a_dim1];
	c__ = q[i__];
	s = q[i__ + 1];
	a[k + *n * a_dim1] = c__ * t1 - s * t2;
	a[k + 1 + *n * a_dim1] = s * t1 + c__ * t2;
/* L100: */
    }
/* ----------------------------------------------------------------------- */
/* Complete update of decomposition by forming last Givens rotation, */
/* and multiplying it times the column vector (A(N,N),A(NP1,N)). */
/* ----------------------------------------------------------------------- */
    *info = 0;
    t1 = a[*n + *n * a_dim1];
    t2 = a[*n + 1 + *n * a_dim1];
    if (t2 != 0.) {
	goto L110;
    }
    c__ = 1.;
    s = 0.;
    goto L130;
L110:
    if (abs(t2) < abs(t1)) {
	goto L120;
    }
    t = t1 / t2;
    s = -1. / sqrt(t * t + 1.);
    c__ = -s * t;
    goto L130;
L120:
    t = t2 / t1;
    c__ = 1. / sqrt(t * t + 1.);
    s = -c__ * t;
L130:
    iq = (*n << 1) - 1;
    q[iq] = c__;
    q[iq + 1] = s;
    a[*n + *n * a_dim1] = c__ * t1 - s * t2;
    if (a[*n + *n * a_dim1] == 0.) {
	*info = *n;
    }
    return 0;

/* ------END OF SUBROUTINE DHEQR------------------------------------------ */
} /* dheqr_ */

/* Subroutine */ int dhels_(doublereal *a, integer *lda, integer *n, 
	doublereal *q, doublereal *b)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;

    /* Local variables */
    doublereal c__;
    integer k;
    doublereal s, t, t1, t2;
    integer kb, iq, kp1;
    extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *);


/* ***BEGIN PROLOGUE  DHELS */
/* ***DATE WRITTEN   890101   (YYMMDD) */
/* ***REVISION DATE  900926   (YYMMDD) */


/* ----------------------------------------------------------------------- */
/* ***DESCRIPTION */

/* This is similar to the LINPACK routine DGESL except that */
/* A is an upper Hessenberg matrix. */

/*     DHELS solves the least squares problem */

/*           MIN (B-A*X,B-A*X) */

/*     using the factors computed by DHEQR. */

/*     On entry */

/*        A       DOUBLE PRECISION (LDA, N) */
/*                The output from DHEQR which contains the upper */
/*                triangular factor R in the QR decomposition of A. */

/*        LDA     INTEGER */
/*                The leading dimension of the array  A . */

/*        N       INTEGER */
/*                A is originally an (N+1) by N matrix. */

/*        Q       DOUBLE PRECISION(2*N) */
/*                The coefficients of the N givens rotations */
/*                used in the QR factorization of A. */

/*        B       DOUBLE PRECISION(N+1) */
/*                The right hand side vector. */


/*     On return */

/*        B       The solution vector X. */


/*     Modification of LINPACK. */
/*     Peter Brown, Lawrence Livermore Natl. Lab. */

/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED */
/*   DAXPY */

/* ***END PROLOGUE  DHELS */


/*        Minimize (B-A*X,B-A*X). */
/*        First form Q*B. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --q;
    --b;

    /* Function Body */
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	kp1 = k + 1;
	iq = ((k - 1) << 1) + 1;
	c__ = q[iq];
	s = q[iq + 1];
	t1 = b[k];
	t2 = b[kp1];
	b[k] = c__ * t1 - s * t2;
	b[kp1] = s * t1 + c__ * t2;
/* L20: */
    }

/*        Now solve R*X = Q*B. */

    i__1 = *n;
    for (kb = 1; kb <= i__1; ++kb) {
	k = *n + 1 - kb;
	b[k] /= a[k + k * a_dim1];
	t = -b[k];
	i__2 = k - 1;
	daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1);
/* L40: */
    }
    return 0;

/* ------END OF SUBROUTINE DHELS------------------------------------------ */
} /* dhels_ */

