/* Subroutine */ int derrge_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[16] /* was [4][4] */, b[4];
integer i__, j;
doublereal w[12], x[4];
char c2[2];
doublereal r1[4], r2[4], af[16] /* was [4][4] */;
integer ip[4], iw[4], info;
doublereal anrm, ccond, rcond;
extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *),
dgetf2_(integer *, integer *, doublereal *, integer *, integer *,
integer *), dgbcon_(char *, integer *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dgecon_(char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), alaesm_(char *,
logical *, integer *), dgbequ_(integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *)
, dgbrfs_(char *, integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dgbtrf_(integer *, integer *, integer *, integer *, doublereal *,
integer *, integer *, integer *), dgeequ_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dgerfs_(char *, integer *
, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dgetrf_(integer *, integer *, doublereal *, integer *,
integer *, integer *), dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dgbtrs_(char *, integer *, integer *,
integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *), dgetrs_(char *,
integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRGE tests the error exits for the DOUBLE PRECISION routines */
/* for general matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
r1[j - 1] = 0.;
r2[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
ip[j - 1] = j;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GE")) {
/* Test error exits of the routines that use the LU decomposition */
/* of a general matrix. */
/* DGETRF */
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETF2 */
s_copy(srnamc_1.srnamt, "DGETF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETRI */
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETRS */
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGERFS */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGECON */
s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEEQU */
s_copy(srnamc_1.srnamt, "DGEEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "GB")) {
/* Test error exits of the routines that use the LU decomposition */
/* of a general band matrix. */
/* DGBTRF */
s_copy(srnamc_1.srnamt, "DGBTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBTF2 */
s_copy(srnamc_1.srnamt, "DGBTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBTRS */
s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBRFS */
s_copy(srnamc_1.srnamt, "DGBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
c__2, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
c__2, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__2, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBCON */
s_copy(srnamc_1.srnamt, "DGBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBEQU */
s_copy(srnamc_1.srnamt, "DGBEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRGE */
} /* derrge_ */
/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Local variables */
integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
kv, nw;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(
integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *
);
doublereal work13[4160] /* was [65][64] */, work31[4160] /*
was [65][64] */;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dgbtf2_(
integer *, integer *, integer *, integer *, doublereal *, integer
*, integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGBTRF computes an LU factorization of a real m-by-n band matrix A */
/* using partial pivoting with row interchanges. */
/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U because of fill-in resulting from the row interchanges. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku);
/* The block size must not exceed the limit set by the size of the */
/* local arrays WORK13 and WORK31. */
nb = min(nb,64);
if (nb <= 1 || nb > *kl) {
/* Use unblocked code */
dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
} else {
/* Use blocked code */
/* Zero the superdiagonal elements of the work array WORK13 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work13[i__ + j * 65 - 66] = 0.;
/* L10: */
}
/* L20: */
}
/* Zero the subdiagonal elements of the work array WORK31 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = nb;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work31[i__ + j * 65 - 66] = 0.;
/* L30: */
}
/* L40: */
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
ab[i__ + j * ab_dim1] = 0.;
/* L50: */
}
/* L60: */
}
/* JU is the index of the last column affected by the current */
/* stage of the factorization */
ju = 1;
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = min(*m,*n) - j + 1;
jb = min(i__3,i__4);
/* The active part of the matrix is partitioned */
/* A11 A12 A13 */
/* A21 A22 A23 */
/* A31 A32 A33 */
/* Here A11, A21 and A31 denote the current block of JB columns */
/* which is about to be factorized. The number of rows in the */
/* partitioning are JB, I2, I3 respectively, and the numbers */
/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
/* and the subdiagonal elements of A31 lie outside the band. */
/* Computing MIN */
i__3 = *kl - jb, i__4 = *m - j - jb + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = jb, i__4 = *m - j - *kl + 1;
i3 = min(i__3,i__4);
/* J2 and J3 are computed after JU has been updated. */
/* Factorize the current block of JB columns */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
/* Set fill-in elements in column JJ+KV to zero */
if (jj + kv <= *n) {
i__4 = *kl;
for (i__ = 1; i__ <= i__4; ++i__) {
ab[i__ + (jj + kv) * ab_dim1] = 0.;
/* L70: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__4 = *kl, i__5 = *m - jj;
km = min(i__4,i__5);
i__4 = km + 1;
jp = idamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
ipiv[jj] = jp + jj - j;
if (ab[kv + jp + jj * ab_dim1] != 0.) {
/* Computing MAX */
/* Computing MIN */
i__6 = jj + *ku + jp - 1;
i__4 = ju, i__5 = min(i__6,*n);
ju = max(i__4,i__5);
if (jp != 1) {
/* Apply interchange to columns J to J+JB-1 */
if (jp + jj - 1 < j + *kl) {
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__4, &ab[kv + jp + jj - j + j * ab_dim1],
&i__5);
} else {
/* The interchange affects columns J to JJ-1 of A31 */
/* which are stored in the work array WORK31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
&i__5, &work31[jp + jj - j - *kl - 1], &
c__65);
i__4 = j + jb - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
ab[kv + jp + jj * ab_dim1], &i__6);
}
}
/* Compute multipliers */
d__1 = 1. / ab[kv + 1 + jj * ab_dim1];
dscal_(&km, &d__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
/* Update trailing submatrix within the band and within */
/* the current block. JM is the index of the last column */
/* which needs to be updated. */
/* Computing MIN */
i__4 = ju, i__5 = j + jb - 1;
jm = min(i__4,i__5);
if (jm > jj) {
i__4 = jm - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1],
&c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = jj;
}
}
/* Copy current column of A31 into the work array WORK31 */
/* Computing MIN */
i__4 = jj - j + 1;
nw = min(i__4,i3);
if (nw > 0) {
dcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
}
/* L80: */
}
if (j + jb <= *n) {
/* Apply the row interchanges to the other blocks. */
/* Computing MIN */
i__3 = ju - j + 1;
j2 = min(i__3,kv) - jb;
/* Computing MAX */
i__3 = 0, i__4 = ju - j - kv + 1;
j3 = max(i__3,i__4);
/* Use DLASWP to apply the row interchanges to A12, A22, and */
/* A32. */
i__3 = *ldab - 1;
dlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
c__1, &jb, &ipiv[j], &c__1);
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L90: */
}
/* Apply the row interchanges to A13, A23, and A33 */
/* columnwise. */
k2 = j - 1 + jb + j2;
i__3 = j3;
for (i__ = 1; i__ <= i__3; ++i__) {
jj = k2 + i__;
i__4 = j + jb - 1;
for (ii = j + i__ - 1; ii <= i__4; ++ii) {
ip = ipiv[ii];
if (ip != ii) {
temp = ab[kv + 1 + ii - jj + jj * ab_dim1];
ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 +
ip - jj + jj * ab_dim1];
ab[kv + 1 + ip - jj + jj * ab_dim1] = temp;
}
/* L100: */
}
/* L110: */
}
/* Update the relevant part of the trailing submatrix */
if (j2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
if (i2 > 0) {
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j2, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
&ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
&c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], &
i__5);
}
if (i3 > 0) {
/* Update A32 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j2, &jb,
&c_b18, work31, &c__65, &ab[kv + 1 - jb + (j
+ jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
}
}
if (j3 > 0) {
/* Copy the lower triangle of A13 into the work array */
/* WORK13 */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj
+ j + kv - 1) * ab_dim1];
/* L120: */
}
/* L130: */
}
/* Update A13 in the work array */
i__3 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13,
&c__65);
if (i2 > 0) {
/* Update A23 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j3, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv)
* ab_dim1], &i__4);
}
if (i3 > 0) {
/* Update A33 */
i__3 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j3, &jb,
&c_b18, work31, &c__65, work13, &c__65, &
c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], &
i__3);
}
/* Copy the lower triangle of A13 back into place */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] =
work13[ii + jj * 65 - 66];
/* L140: */
}
/* L150: */
}
}
} else {
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L160: */
}
}
/* Partially undo the interchanges in the current block to */
/* restore the upper triangular form of A31 and copy the upper */
/* triangle of A31 back into place */
i__3 = j;
for (jj = j + jb - 1; jj >= i__3; --jj) {
jp = ipiv[jj] - jj + 1;
if (jp != 1) {
/* Apply interchange to columns J to JJ-1 */
if (jp + jj - 1 < j + *kl) {
/* The interchange does not affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
i__6);
} else {
/* The interchange does affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &work31[jp + jj - j - *kl - 1], &c__65);
}
}
/* Copy the current column of A31 back into place */
/* Computing MIN */
i__4 = i3, i__5 = jj - j + 1;
nw = min(i__4,i__5);
if (nw > 0) {
dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
}
/* L170: */
}
/* L180: */
}
}
return 0;
/* End of DGBTRF */
} /* dgbtrf_ */
/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DGBTRF computes an LU factorization of a real m-by-n band matrix A
using partial pivoting with row interchanges.
This is the blocked version of the algorithm, calling Level 3 BLAS.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
On entry, the matrix A in band storage, in rows KL+1 to
2*KL+KU+1; rows 1 to KL of the array need not be set.
The j-th column of A is stored in the j-th column of the
array AB as follows:
AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
On exit, details of the factorization: U is stored as an
upper triangular band matrix with KL+KU superdiagonals in
rows 1 to KL+KU+1, and the multipliers used during the
factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
See below for further details.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
IPIV (output) INTEGER array, dimension (min(M,N))
The pivot indices; for 1 <= i <= min(M,N), row i of the
matrix was interchanged with row IPIV(i).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = +i, U(i,i) is exactly zero. The factorization
has been completed, but the factor U is exactly
singular, and division by zero will occur if it is used
to solve a system of equations.
Further Details
===============
The band storage scheme is illustrated by the following example, when
M = N = 6, KL = 2, KU = 1:
On entry: On exit:
* * * + + + * * * u14 u25 u36
* * + + + + * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
a31 a42 a53 a64 * * m31 m42 m53 m64 * *
VISArray elements marked * are not used by the routine; elements marked
+ need not be set on entry, but are required by the routine to store
elements of U because of fill-in resulting from the row interchanges.
=====================================================================
KV is the number of superdiagonals in the factor U, allowing for
fill-in
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c__65 = 65;
static doublereal c_b18 = -1.;
static doublereal c_b31 = 1.;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal temp;
static integer i, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(
integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *
);
static doublereal work13[4160] /* was [65][64] */, work31[4160]
/* was [65][64] */;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static integer i2, i3, j2, j3, k2;
extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *);
static integer jb, nb, ii, jj, jm, ip, jp, km, ju, kv;
extern integer idamax_(integer *, doublereal *, integer *);
static integer nw;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
#define WORK13(I) work13[(I)]
#define WAS(I) was[(I)]
#define IPIV(I) ipiv[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku, 6L, 1L);
/* The block size must not exceed the limit set by the size of the
local arrays WORK13 and WORK31. */
nb = min(nb,64);
if (nb <= 1 || nb > *kl) {
/* Use unblocked code */
dgbtf2_(m, n, kl, ku, &AB(1,1), ldab, &IPIV(1), info);
} else {
/* Use blocked code
Zero the superdiagonal elements of the work array WORK13 */
i__1 = nb;
for (j = 1; j <= nb; ++j) {
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
WORK13(i + j * 65 - 66) = 0.;
/* L10: */
}
/* L20: */
}
/* Zero the subdiagonal elements of the work array WORK31 */
i__1 = nb;
for (j = 1; j <= nb; ++j) {
i__2 = nb;
for (i = j + 1; i <= nb; ++i) {
work31[i + j * 65 - 66] = 0.;
/* L30: */
}
/* L40: */
}
/* Gaussian elimination with partial pivoting
Set fill-in elements in columns KU+2 to KV to zero */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= min(kv,*n); ++j) {
i__2 = *kl;
for (i = kv - j + 2; i <= *kl; ++i) {
AB(i,j) = 0.;
/* L50: */
}
/* L60: */
}
/* JU is the index of the last column affected by the current
stage of the factorization */
ju = 1;
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; nb < 0 ? j >= min(*m,*n) : j <= min(*m,*n); j += nb) {
/* Computing MIN */
i__3 = nb, i__4 = min(*m,*n) - j + 1;
jb = min(i__3,i__4);
/* The active part of the matrix is partitioned
A11 A12 A13
A21 A22 A23
A31 A32 A33
Here A11, A21 and A31 denote the current block of JB
columns
which is about to be factorized. The number of rows i
n the
partitioning are JB, I2, I3 respectively, and the num
bers
of columns are JB, J2, J3. The superdiagonal elements
of A13
and the subdiagonal elements of A31 lie outside the b
and.
Computing MIN */
i__3 = *kl - jb, i__4 = *m - j - jb + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = jb, i__4 = *m - j - *kl + 1;
i3 = min(i__3,i__4);
/* J2 and J3 are computed after JU has been updated.
Factorize the current block of JB columns */
i__3 = j + jb - 1;
for (jj = j; jj <= j+jb-1; ++jj) {
/* Set fill-in elements in column JJ+KV to zero
*/
if (jj + kv <= *n) {
i__4 = *kl;
for (i = 1; i <= *kl; ++i) {
AB(i,jj+kv) = 0.;
/* L70: */
}
}
/* Find pivot and test for singularity. KM is the
number of
subdiagonal elements in the current column.
Computing MIN */
i__4 = *kl, i__5 = *m - jj;
km = min(i__4,i__5);
i__4 = km + 1;
jp = idamax_(&i__4, &AB(kv+1,jj), &c__1);
IPIV(jj) = jp + jj - j;
if (AB(kv+jp,jj) != 0.) {
/* Computing MAX
Computing MIN */
i__6 = jj + *ku + jp - 1;
i__4 = ju, i__5 = min(i__6,*n);
ju = max(i__4,i__5);
if (jp != 1) {
/* Apply interchange to columns J t
o J+JB-1 */
if (jp + jj - 1 < j + *kl) {
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dswap_(&jb, &AB(kv+1+jj-j,j), &
i__4, &AB(kv+jp+jj-j,j),
&i__5);
} else {
/* The interchange affects c
olumns J to JJ-1 of A31
which are stored in the w
ork array WORK31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &AB(kv+1+jj-j,j),
&i__5, &work31[jp + jj - j - *kl - 1], &
c__65);
i__4 = j + jb - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &AB(kv+1,jj), &i__5, &
AB(kv+jp,jj), &i__6);
}
}
/* Compute multipliers */
d__1 = 1. / AB(kv+1,jj);
dscal_(&km, &d__1, &AB(kv+2,jj), &c__1);
/* Update trailing submatrix within the ba
nd and within
the current block. JM is the index of t
he last column
which needs to be updated.
Computing MIN */
i__4 = ju, i__5 = j + jb - 1;
jm = min(i__4,i__5);
if (jm > jj) {
i__4 = jm - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dger_(&km, &i__4, &c_b18, &AB(kv+2,jj),
&c__1, &AB(kv,jj+1), &i__5, &
AB(kv+1,jj+1), &i__6);
}
} else {
/* If pivot is zero, set INFO to the index
of the pivot
unless a zero pivot has already been fo
und. */
if (*info == 0) {
*info = jj;
}
}
/* Copy current column of A31 into the work array
WORK31
Computing MIN */
i__4 = jj - j + 1;
nw = min(i__4,i3);
if (nw > 0) {
dcopy_(&nw, &AB(kv+*kl+1-jj+j,jj), &
c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
}
/* L80: */
}
if (j + jb <= *n) {
/* Apply the row interchanges to the other blocks
.
Computing MIN */
i__3 = ju - j + 1;
j2 = min(i__3,kv) - jb;
/* Computing MAX */
i__3 = 0, i__4 = ju - j - kv + 1;
j3 = max(i__3,i__4);
/* Use DLASWP to apply the row interchanges to A1
2, A22, and
A32. */
i__3 = *ldab - 1;
dlaswp_(&j2, &AB(kv+1-jb,j+jb), &i__3, &
c__1, &jb, &IPIV(j), &c__1);
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i = j; i <= j+jb-1; ++i) {
IPIV(i) = IPIV(i) + j - 1;
/* L90: */
}
/* Apply the row interchanges to A13, A23, and A3
3
columnwise. */
k2 = j - 1 + jb + j2;
i__3 = j3;
for (i = 1; i <= j3; ++i) {
jj = k2 + i;
i__4 = j + jb - 1;
for (ii = j + i - 1; ii <= j+jb-1; ++ii) {
ip = IPIV(ii);
if (ip != ii) {
temp = AB(kv+1+ii-jj,jj);
AB(kv+1+ii-jj,jj) = AB(kv+1+ip-jj,jj);
AB(kv+1+ip-jj,jj) = temp;
}
/* L100: */
}
/* L110: */
}
/* Update the relevant part of the trailing subma
trix */
if (j2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
&c_b31, &AB(kv+1,j), &i__3, &AB(kv+1-jb,j+jb), &i__4);
if (i2 > 0) {
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j2, &jb,
&c_b18, &AB(kv+1+jb,j), &i__3,
&AB(kv+1-jb,j+jb), &i__4,
&c_b31, &AB(kv+1,j+jb), &
i__5);
}
if (i3 > 0) {
/* Update A32 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j2, &jb,
&c_b18, work31, &c__65, &AB(kv+1-jb,j+jb), &i__3, &c_b31, &AB(kv+*kl+1-jb,j+jb), &i__4);
}
}
if (j3 > 0) {
/* Copy the lower triangle of A13 into the
work array
WORK13 */
i__3 = j3;
for (jj = 1; jj <= j3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= jb; ++ii) {
WORK13(ii + jj * 65 - 66) = AB(ii-jj+1,jj+j+kv-1);
/* L120: */
}
/* L130: */
}
/* Update A13 in the work array */
i__3 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
&c_b31, &AB(kv+1,j), &i__3, work13,
&c__65);
if (i2 > 0) {
/* Update A23 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j3, &jb,
&c_b18, &AB(kv+1+jb,j), &i__3,
work13, &c__65, &c_b31, &AB(jb+1,j+kv), &i__4);
}
if (i3 > 0) {
/* Update A33 */
i__3 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j3, &jb,
&c_b18, work31, &c__65, work13, &c__65, &
c_b31, &AB(*kl+1,j+kv), &
i__3);
}
/* Copy the lower triangle of A13 back int
o place */
i__3 = j3;
for (jj = 1; jj <= j3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= jb; ++ii) {
AB(ii-jj+1,jj+j+kv-1) =
WORK13(ii + jj * 65 - 66);
/* L140: */
}
/* L150: */
}
}
} else {
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i = j; i <= j+jb-1; ++i) {
IPIV(i) = IPIV(i) + j - 1;
/* L160: */
}
}
/* Partially undo the interchanges in the current block
to
restore the upper triangular form of A31 and copy the
upper
triangle of A31 back into place */
i__3 = j;
for (jj = j + jb - 1; jj >= j; --jj) {
jp = IPIV(jj) - jj + 1;
if (jp != 1) {
/* Apply interchange to columns J to JJ-1
*/
if (jp + jj - 1 < j + *kl) {
/* The interchange does not affect
A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &AB(kv+1+jj-j,j), &
i__5, &AB(kv+jp+jj-j,j), &
i__6);
} else {
/* The interchange does affect A31
*/
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &AB(kv+1+jj-j,j), &
i__5, &work31[jp + jj - j - *kl - 1], &c__65);
}
}
/* Copy the current column of A31 back into place
Computing MIN */
i__4 = i3, i__5 = jj - j + 1;
nw = min(i__4,i__5);
if (nw > 0) {
dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &AB(kv+*kl+1-jj+j,jj), &c__1);
}
/* L170: */
}
/* L180: */
}
}
return 0;
/* End of DGBTRF */
} /* dgbtrf_ */
