/* Subroutine */
C_INT CInternalSolver::dsolsy_(double *wm, C_INT *iwm, double *x,
double *tem)
{
/* System generated locals */
C_INT i__1;
/* Local variables */
C_INT i__;
double r__, di;
C_INT ml, mu;
double hl0, phl0;
C_INT meband;
/* ***BEGIN PROLOGUE DSOLSY */
/* ***SUBSIDIARY */
/* ***PURPOSE ODEPACK linear system solver. */
/* ***TYPE DOUBLE PRECISION (SSOLSY-S, DSOLSY-D) */
/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */
/* ***DESCRIPTION */
/* This routine manages the solution of the linear system arising from */
/* a chord iteration. It is called if MITER .ne. 0. */
/* If MITER is 1 or 2, it calls DGESL to accomplish this. */
/* If MITER = 3 it updates the coefficient h*EL0 in the diagonal */
/* matrix, and then computes the solution. */
/* If MITER is 4 or 5, it calls DGBSL. */
/* Communication with DSOLSY uses the following variables: */
/* WM = real work space containing the inverse diagonal matrix if */
/* MITER = 3 and the LU decomposition of the matrix otherwise. */
/* Storage of matrix elements starts at WM(3). */
/* WM also contains the following matrix-related data: */
/* WM(1) = SQRT(UROUND) (not used here), */
/* WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. */
/* IWM = integer work space containing pivot information, starting at */
/* IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band */
/* parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. */
/* X = the right-hand side vector on input, and the solution vector */
/* on output, of length N. */
/* TEM = vector of work space of length N, not used in this version. */
/* IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. */
/* IERSL = 1 if a singular matrix arose with MITER = 3. */
/* This routine also uses the COMMON variables EL0, H, MITER, and N. */
/* ***SEE ALSO DLSODE */
/* ***ROUTINES CALLED DGBSL, DGESL */
/* ***COMMON BLOCKS DLS001 */
/* ***REVISION HISTORY (YYMMDD) */
/* 791129 DATE WRITTEN */
/* 890501 Modified prologue to SLATEC/LDOC format. (FNF) */
/* 890503 Minor cosmetic changes. (FNF) */
/* 930809 Renamed to allow single/double precision versions. (ACH) */
/* 010418 Reduced size of Common block /DLS001/. (ACH) */
/* 031105 Restored 'own' variables to Common block /DLS001/, to */
/* enable interrupt/restart feature. (ACH) */
/* ***END PROLOGUE DSOLSY */
/* **End */
/* ***FIRST EXECUTABLE STATEMENT DSOLSY */
/* Parameter adjustments */
--tem;
--x;
--iwm;
--wm;
/* Function Body */
dls001_1.iersl = 0;
switch (dls001_1.miter)
{
case 1: goto L100;
case 2: goto L100;
case 3: goto L300;
case 4: goto L400;
case 5: goto L400;
}
L100:
dgesl_(&wm[3], &dls001_1.n, &dls001_1.n, &iwm[21], &x[1], &c__0);
return 0;
L300:
phl0 = wm[2];
hl0 = dls001_1.h__ * dls001_1.el0;
wm[2] = hl0;
if (hl0 == phl0)
{
goto L330;
}
r__ = hl0 / phl0;
i__1 = dls001_1.n;
for (i__ = 1; i__ <= i__1; ++i__)
{
di = 1. - r__ * (1. - 1. / wm[i__ + 2]);
if (fabs(di) == 0.)
{
goto L390;
}
/* L320: */
wm[i__ + 2] = 1. / di;
}
L330:
i__1 = dls001_1.n;
for (i__ = 1; i__ <= i__1; ++i__)
{
/* L340: */
x[i__] = wm[i__ + 2] * x[i__];
}
return 0;
L390:
dls001_1.iersl = 1;
return 0;
L400:
ml = iwm[1];
mu = iwm[2];
meband = (ml << 1) + mu + 1;
dgbsl_(&wm[3], &meband, &dls001_1.n, &ml, &mu, &iwm[21], &x[1], &c__0);
return 0;
/* ----------------------- END OF SUBROUTINE DSOLSY ---------------------- */
} /* dsolsy_ */
/* DECK DDCOR */
/* Subroutine */ int ddcor_(doublereal *dfdy, doublereal *el, S_fp fa,
doublereal *h__, integer *ierror, integer *impl, integer *ipvt,
integer *matdim, integer *miter, integer *ml, integer *mu, integer *n,
integer *nde, integer *nq, doublereal *t, S_fp users, doublereal *y,
doublereal *yh, doublereal *ywt, logical *evalfa, doublereal *save1,
doublereal *save2, doublereal *a, doublereal *d__, integer *jstate)
{
/* System generated locals */
integer a_dim1, a_offset, dfdy_dim1, dfdy_offset, yh_dim1, yh_offset,
i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer i__, j, mw;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer iflag;
extern /* Subroutine */ int dgbsl_(doublereal *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *), dgesl_(
doublereal *, integer *, integer *, integer *, doublereal *,
integer *);
/* ***BEGIN PROLOGUE DDCOR */
/* ***SUBSIDIARY */
/* ***PURPOSE Subroutine DDCOR computes corrections to the Y array. */
/* ***LIBRARY SLATEC (SDRIVE) */
/* ***TYPE DOUBLE PRECISION (SDCOR-S, DDCOR-D, CDCOR-C) */
/* ***AUTHOR Kahaner, D. K., (NIST) */
/* National Institute of Standards and Technology */
/* Gaithersburg, MD 20899 */
/* Sutherland, C. D., (LANL) */
/* Mail Stop D466 */
/* Los Alamos National Laboratory */
/* Los Alamos, NM 87545 */
/* ***DESCRIPTION */
/* In the case of functional iteration, update Y directly from the */
/* result of the last call to F. */
/* In the case of the chord method, compute the corrector error and */
/* solve the linear system with that as right hand side and DFDY as */
/* coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, */
/* or 5. */
/* ***ROUTINES CALLED DGBSL, DGESL, DNRM2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 790601 DATE WRITTEN */
/* 900329 Initial submission to SLATEC. */
/* ***END PROLOGUE DDCOR */
/* ***FIRST EXECUTABLE STATEMENT DDCOR */
/* Parameter adjustments */
el -= 14;
--ipvt;
a_dim1 = *matdim;
a_offset = 1 + a_dim1;
a -= a_offset;
dfdy_dim1 = *matdim;
dfdy_offset = 1 + dfdy_dim1;
dfdy -= dfdy_offset;
yh_dim1 = *n;
yh_offset = 1 + yh_dim1;
yh -= yh_offset;
--y;
--ywt;
--save1;
--save2;
/* Function Body */
if (*miter == 0) {
if (*ierror == 1 || *ierror == 5) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
save1[i__] = (*h__ * save2[i__] - yh[i__ + (yh_dim1 << 1)] -
save1[i__]) / ywt[i__];
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = (d__1 = y[i__], abs(d__1)), d__3 = ywt[i__];
save1[i__] = (*h__ * save2[i__] - yh[i__ + (yh_dim1 << 1)] -
save1[i__]) / max(d__2,d__3);
/* L102: */
}
}
*d__ = dnrm2_(n, &save1[1], &c__1) / sqrt((doublereal) (*n));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L105: */
save1[i__] = *h__ * save2[i__] - yh[i__ + (yh_dim1 << 1)];
}
} else if (*miter == 1 || *miter == 2) {
if (*impl == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L130: */
save2[i__] = *h__ * save2[i__] - yh[i__ + (yh_dim1 << 1)] -
save1[i__];
}
} else if (*impl == 1) {
if (*evalfa) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
} else {
*evalfa = TRUE_;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L150: */
save2[i__] = *h__ * save2[i__];
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L160: */
save2[i__] -= a[i__ + j * a_dim1] * (yh[j + (yh_dim1 << 1)
] + save1[j]);
}
}
} else if (*impl == 2) {
if (*evalfa) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
} else {
*evalfa = TRUE_;
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L180: */
save2[i__] = *h__ * save2[i__] - a[i__ + a_dim1] * (yh[i__ + (
yh_dim1 << 1)] + save1[i__]);
}
} else if (*impl == 3) {
if (*evalfa) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
} else {
*evalfa = TRUE_;
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L140: */
save2[i__] = *h__ * save2[i__];
}
i__2 = *nde;
for (j = 1; j <= i__2; ++j) {
i__1 = *nde;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L170: */
save2[i__] -= a[i__ + j * a_dim1] * (yh[j + (yh_dim1 << 1)
] + save1[j]);
}
}
}
dgesl_(&dfdy[dfdy_offset], matdim, n, &ipvt[1], &save2[1], &c__0);
if (*ierror == 1 || *ierror == 5) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
save1[i__] += save2[i__];
/* L200: */
save2[i__] /= ywt[i__];
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
save1[i__] += save2[i__];
/* L205: */
/* Computing MAX */
d__2 = (d__1 = y[i__], abs(d__1)), d__3 = ywt[i__];
save2[i__] /= max(d__2,d__3);
}
}
*d__ = dnrm2_(n, &save2[1], &c__1) / sqrt((doublereal) (*n));
} else if (*miter == 4 || *miter == 5) {
if (*impl == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L230: */
save2[i__] = *h__ * save2[i__] - yh[i__ + (yh_dim1 << 1)] -
save1[i__];
}
} else if (*impl == 1) {
if (*evalfa) {
(*fa)(n, t, &y[1], &a[*ml + 1 + a_dim1], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
} else {
*evalfa = TRUE_;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L250: */
save2[i__] = *h__ * save2[i__];
}
mw = *ml + 1 + *mu;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *ml + 1, i__3 = mw + 1 - j;
/* Computing MIN */
i__5 = mw + *n - j, i__6 = mw + *ml;
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
save2[i__ + j - mw] -= a[i__ + j * a_dim1] * (yh[j + (
yh_dim1 << 1)] + save1[j]);
/* L260: */
}
}
} else if (*impl == 2) {
if (*evalfa) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
} else {
*evalfa = TRUE_;
}
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L280: */
save2[i__] = *h__ * save2[i__] - a[i__ + a_dim1] * (yh[i__ + (
yh_dim1 << 1)] + save1[i__]);
}
} else if (*impl == 3) {
if (*evalfa) {
(*fa)(n, t, &y[1], &a[*ml + 1 + a_dim1], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
} else {
*evalfa = TRUE_;
}
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L270: */
save2[i__] = *h__ * save2[i__];
}
mw = *ml + 1 + *mu;
i__4 = *nde;
for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
i__1 = *ml + 1, i__2 = mw + 1 - j;
/* Computing MIN */
i__5 = mw + *nde - j, i__6 = mw + *ml;
i__3 = min(i__5,i__6);
for (i__ = max(i__1,i__2); i__ <= i__3; ++i__) {
save2[i__ + j - mw] -= a[i__ + j * a_dim1] * (yh[j + (
yh_dim1 << 1)] + save1[j]);
/* L290: */
}
}
}
dgbsl_(&dfdy[dfdy_offset], matdim, n, ml, mu, &ipvt[1], &save2[1], &
c__0);
if (*ierror == 1 || *ierror == 5) {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
save1[i__] += save2[i__];
/* L300: */
save2[i__] /= ywt[i__];
}
} else {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
save1[i__] += save2[i__];
/* L305: */
/* Computing MAX */
d__2 = (d__1 = y[i__], abs(d__1)), d__3 = ywt[i__];
save2[i__] /= max(d__2,d__3);
}
}
*d__ = dnrm2_(n, &save2[1], &c__1) / sqrt((doublereal) (*n));
} else if (*miter == 3) {
iflag = 2;
(*users)(&y[1], &yh[(yh_dim1 << 1) + 1], &ywt[1], &save1[1], &save2[1]
, t, h__, &el[*nq * 13 + 1], impl, n, nde, &iflag);
if (*n == 0) {
*jstate = 10;
return 0;
}
if (*ierror == 1 || *ierror == 5) {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
save1[i__] += save2[i__];
/* L320: */
save2[i__] /= ywt[i__];
}
} else {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
save1[i__] += save2[i__];
/* L325: */
/* Computing MAX */
d__2 = (d__1 = y[i__], abs(d__1)), d__3 = ywt[i__];
save2[i__] /= max(d__2,d__3);
}
}
*d__ = dnrm2_(n, &save2[1], &c__1) / sqrt((doublereal) (*n));
}
return 0;
} /* ddcor_ */
