GreenPolyProducts/cantera
5
0
Fork 0
mirror of https://github.com/Cantera/cantera.git synced 2025-02-25 18:55:29 -06:00
Code Issues Packages Projects Releases Wiki Activity
Files
c57ededb30e34e89eafe6be8ea526c791d7cc51f
cantera/ext/f2c_math/ddaspk.c
Harry Moffat 6f4a6f6879 First commit of this directory
2004-08-05 19:15:05 +00:00

8784 lines
298 KiB
C
Raw Blame History

/* ddaspk.f -- translated by f2c (version 20031025).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#ifdef _cpluscplus
extern "C" {
#endif
#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 */
static doublereal h__;
static integer i__;
static doublereal r__, h0;
static integer le;
static doublereal rh, tn;
static integer ici, idi, lid, ier;
static char msg[80];
static integer lwm, lvt, lwt, nwt, nli0, nni0;
static logical lcfl, lcfn, done;
static doublereal rcfl;
static integer nnid;
static logical lavl;
static integer maxl, iret;
static doublereal hmax;
static integer lphi;
static doublereal hmin;
static integer lyic, lpwk, nstd;
static doublereal rcfn;
static integer ncfl0, ncfn0;
extern /* Subroutine */ int dnedd_();
static integer mband;
extern /* Subroutine */ int dnedk_();
static integer lenic, lenid, ncphi, lenpd, lsoff, msave, index, itemp,
leniw, nzflg;
static doublereal atoli;
static integer lypic;
static logical lwarn;
static doublereal avlin;
static integer lenwp, lenrw, mxord, nwarn;
static doublereal rtoli;
static integer lsavr;
extern doublereal d1mach_(integer *);
static 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);
static 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_();
static integer icnflg;
static doublereal tscale, epconi;
extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *);
static 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 *);
static integer leniwp;
extern /* Subroutine */ int xerrwd_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, ftnlen), dinvwt_(integer *, doublereal *, integer *)
;
static 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 */
static doublereal cj;
static integer nh, mxnh;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static 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 */
static 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 */
static integer i__, j;
static doublereal r__;
static integer j1;
static doublereal ck;
static integer km1, kp1, kp2, ncf, nef;
static doublereal erk, err, est;
static integer nsp1;
static doublereal hnew, terk, xold;
static integer knew;
static doublereal erkm1, erkm2, erkp1, temp1, temp2;
static integer kdiff;
static doublereal enorm, alpha0, terkm1, terkm2, terkp1, alphas;
extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *);
static doublereal cjlast;
extern doublereal ddwnrm_(integer *, doublereal *, doublereal *,
doublereal *, integer *);
static 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 */
static integer i__;
static 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 */
static 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 */
static integer i__;
static 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 */
static 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 */
static doublereal c__, d__;
static integer i__, j;
static doublereal temp1, gamma;
static 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 */
static integer i__;
static 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)
{
static 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 *);
static 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)
{
static integer m;
static doublereal rlx, rate, fnrm;
static 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 *);
static 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 */
static integer i__;
static doublereal rl;
static char msg[80];
static doublereal tau;
static integer ivar;
static doublereal slpi, f1nrm, ratio;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static doublereal rlmin, fnrmp;
static integer kprin;
static 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 */
static 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 *);
static integer idum, ires;
static 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 *);
static doublereal pnorm, delnrm;
static integer iernew;
extern doublereal ddwnrm_(integer *, doublereal *, doublereal *,
doublereal *, integer *);
static doublereal tolnew;
static 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 */
static integer i__, m;
static doublereal rate;
extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *,
integer *);
static doublereal delnrm;
extern doublereal ddwnrm_(integer *, doublereal *, doublereal *,
doublereal *, integer *);
static 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 */
static integer i__, j, k, l, n, i1, i2, ii, mba;
static doublereal del;
static integer meb1, nrow;
static doublereal squr;
extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *), dgefa_(doublereal *,
integer *, integer *, integer *, integer *);
static integer mband, lenpd, isave, msave;
static doublereal ysave;
static integer lipvt, mtype, meband;
static doublereal delinv;
static integer ipsave;
static 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 *);
static 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)
{
static integer nj, lwp, ires, liwp, mxnj;
static 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 *);
static integer ierpj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static 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)
{
static integer m, ier, lwp;
static doublereal rlx, rate;
static integer ires;
static doublereal fnrm, rhok;
static integer iret, liwp;
static doublereal fnrm0;
static integer lsoff;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static 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 *);
static 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 *);
static 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 */
static integer i__;
static doublereal rl;
static integer ier;
static char msg[80];
static doublereal tau;
static integer ivar;
static doublereal slpi, f1nrm, ratio;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static doublereal rlmin, fnrmp;
static integer kprin;
static 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 */
static 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 *);
static integer ires, liwp;
static doublereal temp1, temp2, eplin;
static integer ierpj, iersl;
static doublereal delnrm;
static integer iernew;
extern doublereal ddwnrm_(integer *, doublereal *, doublereal *,
doublereal *, integer *);
static doublereal tolnew;
static 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 */
static integer i__, m;
static 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 *);
static doublereal delnrm;
extern doublereal ddwnrm_(integer *, doublereal *, doublereal *,
doublereal *, integer *);
static 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 */
static 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 *);
static 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 */
static doublereal c__;
static integer i__, j, k;
static doublereal s;
static integer i2, ll, ip1, ier;
static doublereal tem, rho;
static 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 *);
static 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 *);
static 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 *);
static integer maxlm1;
static 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 */
static 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 */
static integer i__, i0;
static doublereal arg, tem;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal vnrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static 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 */
static doublereal c__;
static integer i__, j, k;
static doublereal s, t, t1, t2;
static 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 */
static doublereal c__;
static integer k;
static doublereal s, t, t1, t2;
static 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_ */
#ifdef _cpluscplus
}
#endif
Reference in New Issue View Git Blame Copy Permalink