/* Subroutine */ int cdrvgb_(logical *dotype, integer *nn, integer *nval, integer *nrhs, real *thresh, logical *tsterr, complex *a, integer *la, complex *afb, integer *lafb, complex *asav, complex *b, complex * bsav, complex *x, complex *xact, real *s, complex *work, real *rwork, integer *iwork, integer *nout) { /* Initialized data */ static integer iseedy[4] = { 1988,1989,1990,1991 }; static char transs[1*3] = "N" "T" "C"; static char facts[1*3] = "F" "N" "E"; static char equeds[1*4] = "N" "R" "C" "B"; /* Format strings */ static char fmt_9999[] = "(\002 *** In CDRVGB, LA=\002,i5,\002 is too sm" "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In" "crease LA to at least \002,i5)"; static char fmt_9998[] = "(\002 *** In CDRVGB, LAFB=\002,i5,\002 is too " "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> " "Increase LAFB to at least \002,i5)"; static char fmt_9997[] = "(1x,a6,\002, N=\002,i5,\002, KL=\002,i5,\002, " "KU=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12." "5)"; static char fmt_9995[] = "(1x,a6,\002( '\002,a1,\002','\002,a1,\002'," "\002,i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002" "', type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"; static char fmt_9996[] = "(1x,a6,\002( '\002,a1,\002','\002,a1,\002'," "\002,i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, " "test(\002,i1,\002)=\002,g12.5)"; /* System generated locals */ address a__1[2]; integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11[2]; real r__1, r__2; char ch__1[2]; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); double c_abs(complex *); /* Local variables */ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl, iku, nku; char fact[1]; integer ioff, mode; real amax; char path[3]; integer imat, info; char dist[1]; real rdum[1]; char type__[1]; integer nrun, ldafb; extern /* Subroutine */ int cgbt01_(integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, integer *, complex *, real *), cgbt02_(char *, integer *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *), cgbt05_(char *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, real *); integer ifact; extern /* Subroutine */ int cget04_(integer *, integer *, complex *, integer *, complex *, integer *, real *, real *); integer nfail, iseed[4], nfact; extern logical lsame_(char *, char *); char equed[1]; integer nbmin; real rcond, roldc; extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); integer nimat; real roldi; extern doublereal sget06_(real *, real *); real anorm; integer itran; logical equil; real roldo; char trans[1]; integer izero, nerrs; logical zerot; char xtype[1]; extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer *, char *, integer *, integer *, real *, integer *, real *, char * ), aladhd_(integer *, char *); extern doublereal clangb_(char *, integer *, integer *, integer *, complex *, integer *, real *), clange_(char *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int claqgb_(integer *, integer *, integer *, integer *, complex *, integer *, real *, real *, real *, real *, real *, char *), alaerh_(char *, char *, integer *, integer *, char *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *); logical prefac; real colcnd; extern doublereal clantb_(char *, char *, char *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *, integer *, complex *, integer *, real *, real *, real *, real *, real *, integer *); real rcondc; extern doublereal slamch_(char *); logical nofact; extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *, integer *, complex *, integer *, integer *, integer *); integer iequed; extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *); real rcondi; extern /* Subroutine */ int clarhs_(char *, char *, char *, char *, integer *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer *); real cndnum, anormi, rcondo, ainvnm; extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *, real *, integer *, real *, real *, integer *, integer *, char *, complex *, integer *, complex *, integer *); logical trfcon; real anormo, rowcnd; extern /* Subroutine */ int cgbsvx_(char *, char *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, integer *, char *, real *, real *, complex *, integer *, complex * , integer *, real *, real *, real *, complex *, real *, integer *), xlaenv_(integer *, integer *); real anrmpv; extern /* Subroutine */ int cerrvx_(char *, integer *); real result[7], rpvgrw; /* Fortran I/O blocks */ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___27 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___65 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___73 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___74 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___75 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___76 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___77 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___78 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___79 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___80 = { 0, 0, 0, fmt_9996, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CDRVGB tests the driver routines CGBSV and -SVX. */ /* Arguments */ /* ========= */ /* DOTYPE (input) LOGICAL array, dimension (NTYPES) */ /* The matrix types to be used for testing. Matrices of type j */ /* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */ /* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */ /* NN (input) INTEGER */ /* The number of values of N contained in the vector NVAL. */ /* NVAL (input) INTEGER array, dimension (NN) */ /* The values of the matrix column dimension N. */ /* NRHS (input) INTEGER */ /* The number of right hand side vectors to be generated for */ /* each linear system. */ /* THRESH (input) REAL */ /* The threshold value for the test ratios. A result is */ /* included in the output file if RESULT >= THRESH. To have */ /* every test ratio printed, use THRESH = 0. */ /* TSTERR (input) LOGICAL */ /* Flag that indicates whether error exits are to be tested. */ /* A (workspace) COMPLEX array, dimension (LA) */ /* LA (input) INTEGER */ /* The length of the array A. LA >= (2*NMAX-1)*NMAX */ /* where NMAX is the largest entry in NVAL. */ /* AFB (workspace) COMPLEX array, dimension (LAFB) */ /* LAFB (input) INTEGER */ /* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */ /* where NMAX is the largest entry in NVAL. */ /* ASAV (workspace) COMPLEX array, dimension (LA) */ /* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* S (workspace) REAL array, dimension (2*NMAX) */ /* WORK (workspace) COMPLEX array, dimension */ /* (NMAX*max(3,NRHS,NMAX)) */ /* RWORK (workspace) REAL array, dimension */ /* (max(NMAX,2*NRHS)) */ /* IWORK (workspace) INTEGER array, dimension (NMAX) */ /* NOUT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --iwork; --rwork; --work; --s; --xact; --x; --bsav; --b; --asav; --afb; --a; --nval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Initialize constants and the random number seed. */ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2); nrun = 0; nfail = 0; nerrs = 0; for (i__ = 1; i__ <= 4; ++i__) { iseed[i__ - 1] = iseedy[i__ - 1]; /* L10: */ } /* Test the error exits */ if (*tsterr) { cerrvx_(path, nout); } infoc_1.infot = 0; /* Set the block size and minimum block size for testing. */ nb = 1; nbmin = 2; xlaenv_(&c__1, &nb); xlaenv_(&c__2, &nbmin); /* Do for each value of N in NVAL */ i__1 = *nn; for (in = 1; in <= i__1; ++in) { n = nval[in]; ldb = max(n,1); *(unsigned char *)xtype = 'N'; /* Set limits on the number of loop iterations. */ /* Computing MAX */ i__2 = 1, i__3 = min(n,4); nkl = max(i__2,i__3); if (n == 0) { nkl = 1; } nku = nkl; nimat = 8; if (n <= 0) { nimat = 1; } i__2 = nkl; for (ikl = 1; ikl <= i__2; ++ikl) { /* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */ /* it easier to skip redundant values for small values of N. */ if (ikl == 1) { kl = 0; } else if (ikl == 2) { /* Computing MAX */ i__3 = n - 1; kl = max(i__3,0); } else if (ikl == 3) { kl = (n * 3 - 1) / 4; } else if (ikl == 4) { kl = (n + 1) / 4; } i__3 = nku; for (iku = 1; iku <= i__3; ++iku) { /* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */ /* makes it easier to skip redundant values for small */ /* values of N. */ if (iku == 1) { ku = 0; } else if (iku == 2) { /* Computing MAX */ i__4 = n - 1; ku = max(i__4,0); } else if (iku == 3) { ku = (n * 3 - 1) / 4; } else if (iku == 4) { ku = (n + 1) / 4; } /* Check that A and AFB are big enough to generate this */ /* matrix. */ lda = kl + ku + 1; ldafb = (kl << 1) + ku + 1; if (lda * n > *la || ldafb * n > *lafb) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (lda * n > *la) { io___26.ciunit = *nout; s_wsfe(&io___26); do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); i__4 = n * (kl + ku + 1); do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer)); e_wsfe(); ++nerrs; } if (ldafb * n > *lafb) { io___27.ciunit = *nout; s_wsfe(&io___27); do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); i__4 = n * ((kl << 1) + ku + 1); do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer)); e_wsfe(); ++nerrs; } goto L130; } i__4 = nimat; for (imat = 1; imat <= i__4; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat]) { goto L120; } /* Skip types 2, 3, or 4 if the matrix is too small. */ zerot = imat >= 2 && imat <= 4; if (zerot && n < imat - 1) { goto L120; } /* Set up parameters with CLATB4 and generate a */ /* test matrix with CLATMS. */ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, & mode, &cndnum, dist); rcondc = 1.f / cndnum; s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6); clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, & cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[ 1], &info); /* Check the error code from CLATMS. */ if (info != 0) { alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, & kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout); goto L120; } /* For types 2, 3, and 4, zero one or more columns of */ /* the matrix to test that INFO is returned correctly. */ izero = 0; if (zerot) { if (imat == 2) { izero = 1; } else if (imat == 3) { izero = n; } else { izero = n / 2 + 1; } ioff = (izero - 1) * lda; if (imat < 4) { /* Computing MAX */ i__5 = 1, i__6 = ku + 2 - izero; i1 = max(i__5,i__6); /* Computing MIN */ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero); i2 = min(i__5,i__6); i__5 = i2; for (i__ = i1; i__ <= i__5; ++i__) { i__6 = ioff + i__; a[i__6].r = 0.f, a[i__6].i = 0.f; /* L20: */ } } else { i__5 = n; for (j = izero; j <= i__5; ++j) { /* Computing MAX */ i__6 = 1, i__7 = ku + 2 - j; /* Computing MIN */ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j); i__8 = min(i__9,i__10); for (i__ = max(i__6,i__7); i__ <= i__8; ++i__) { i__6 = ioff + i__; a[i__6].r = 0.f, a[i__6].i = 0.f; /* L30: */ } ioff += lda; /* L40: */ } } } /* Save a copy of the matrix A in ASAV. */ i__5 = kl + ku + 1; clacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda); for (iequed = 1; iequed <= 4; ++iequed) { *(unsigned char *)equed = *(unsigned char *)&equeds[ iequed - 1]; if (iequed == 1) { nfact = 3; } else { nfact = 1; } i__5 = nfact; for (ifact = 1; ifact <= i__5; ++ifact) { *(unsigned char *)fact = *(unsigned char *)&facts[ ifact - 1]; prefac = lsame_(fact, "F"); nofact = lsame_(fact, "N"); equil = lsame_(fact, "E"); if (zerot) { if (prefac) { goto L100; } rcondo = 0.f; rcondi = 0.f; } else if (! nofact) { /* Compute the condition number for comparison */ /* with the value returned by SGESVX (FACT = */ /* 'N' reuses the condition number from the */ /* previous iteration with FACT = 'F'). */ i__8 = kl + ku + 1; clacpy_("Full", &i__8, &n, &asav[1], &lda, & afb[kl + 1], &ldafb); if (equil || iequed > 1) { /* Compute row and column scale factors to */ /* equilibrate the matrix A. */ cgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], & ldafb, &s[1], &s[n + 1], &rowcnd, &colcnd, &amax, &info); if (info == 0 && n > 0) { if (lsame_(equed, "R")) { rowcnd = 0.f; colcnd = 1.f; } else if (lsame_(equed, "C")) { rowcnd = 1.f; colcnd = 0.f; } else if (lsame_(equed, "B")) { rowcnd = 0.f; colcnd = 0.f; } /* Equilibrate the matrix. */ claqgb_(&n, &n, &kl, &ku, &afb[kl + 1] , &ldafb, &s[1], &s[n + 1], & rowcnd, &colcnd, &amax, equed); } } /* Save the condition number of the */ /* non-equilibrated system for use in CGET04. */ if (equil) { roldo = rcondo; roldi = rcondi; } /* Compute the 1-norm and infinity-norm of A. */ anormo = clangb_("1", &n, &kl, &ku, &afb[kl + 1], &ldafb, &rwork[1]); anormi = clangb_("I", &n, &kl, &ku, &afb[kl + 1], &ldafb, &rwork[1]); /* Factor the matrix A. */ cgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, & iwork[1], &info); /* Form the inverse of A. */ claset_("Full", &n, &n, &c_b48, &c_b49, &work[ 1], &ldb); s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)6, ( ftnlen)6); cgbtrs_("No transpose", &n, &kl, &ku, &n, & afb[1], &ldafb, &iwork[1], &work[1], & ldb, &info); /* Compute the 1-norm condition number of A. */ ainvnm = clange_("1", &n, &n, &work[1], &ldb, &rwork[1]); if (anormo <= 0.f || ainvnm <= 0.f) { rcondo = 1.f; } else { rcondo = 1.f / anormo / ainvnm; } /* Compute the infinity-norm condition number */ /* of A. */ ainvnm = clange_("I", &n, &n, &work[1], &ldb, &rwork[1]); if (anormi <= 0.f || ainvnm <= 0.f) { rcondi = 1.f; } else { rcondi = 1.f / anormi / ainvnm; } } for (itran = 1; itran <= 3; ++itran) { /* Do for each value of TRANS. */ *(unsigned char *)trans = *(unsigned char *)& transs[itran - 1]; if (itran == 1) { rcondc = rcondo; } else { rcondc = rcondi; } /* Restore the matrix A. */ i__8 = kl + ku + 1; clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[ 1], &lda); /* Form an exact solution and set the right hand */ /* side. */ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, ( ftnlen)6); clarhs_(path, xtype, "Full", trans, &n, &n, & kl, &ku, nrhs, &a[1], &lda, &xact[1], &ldb, &b[1], &ldb, iseed, &info); *(unsigned char *)xtype = 'C'; clacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[ 1], &ldb); if (nofact && itran == 1) { /* --- Test CGBSV --- */ /* Compute the LU factorization of the matrix */ /* and solve the system. */ i__8 = kl + ku + 1; clacpy_("Full", &i__8, &n, &a[1], &lda, & afb[kl + 1], &ldafb); clacpy_("Full", &n, nrhs, &b[1], &ldb, &x[ 1], &ldb); s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen) 6, (ftnlen)6); cgbsv_(&n, &kl, &ku, nrhs, &afb[1], & ldafb, &iwork[1], &x[1], &ldb, & info); /* Check error code from CGBSV . */ if (info != izero) { alaerh_(path, "CGBSV ", &info, &izero, " ", &n, &n, &kl, &ku, nrhs, &imat, &nfail, &nerrs, nout); } /* Reconstruct matrix from factors and */ /* compute residual. */ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, & afb[1], &ldafb, &iwork[1], &work[ 1], result); nt = 1; if (izero == 0) { /* Compute residual of the computed */ /* solution. */ clacpy_("Full", &n, nrhs, &b[1], &ldb, &work[1], &ldb); cgbt02_("No transpose", &n, &n, &kl, & ku, nrhs, &a[1], &lda, &x[1], &ldb, &work[1], &ldb, &result[ 1]); /* Check solution from generated exact */ /* solution. */ cget04_(&n, nrhs, &x[1], &ldb, &xact[ 1], &ldb, &rcondc, &result[2]) ; nt = 3; } /* Print information about the tests that did */ /* not pass the threshold. */ i__8 = nt; for (k = 1; k <= i__8; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } io___65.ciunit = *nout; s_wsfe(&io___65); do_fio(&c__1, "CGBSV ", (ftnlen)6) ; do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(real)); e_wsfe(); ++nfail; } /* L50: */ } nrun += nt; } /* --- Test CGBSVX --- */ if (! prefac) { i__8 = (kl << 1) + ku + 1; claset_("Full", &i__8, &n, &c_b48, &c_b48, &afb[1], &ldafb); } claset_("Full", &n, nrhs, &c_b48, &c_b48, &x[ 1], &ldb); if (iequed > 1 && n > 0) { /* Equilibrate the matrix if FACT = 'F' and */ /* EQUED = 'R', 'C', or 'B'. */ claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[ 1], &s[n + 1], &rowcnd, &colcnd, & amax, equed); } /* Solve the system and compute the condition */ /* number and error bounds using CGBSVX. */ s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)6, ( ftnlen)6); cgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1] , &lda, &afb[1], &ldafb, &iwork[1], equed, &s[1], &s[ldb + 1], &b[1], & ldb, &x[1], &ldb, &rcond, &rwork[1], & rwork[*nrhs + 1], &work[1], &rwork[(* nrhs << 1) + 1], &info); /* Check the error code from CGBSVX. */ if (info != izero) { /* Writing concatenation */ i__11[0] = 1, a__1[0] = fact; i__11[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__11, &c__2, (ftnlen) 2); alaerh_(path, "CGBSVX", &info, &izero, ch__1, &n, &n, &kl, &ku, nrhs, & imat, &nfail, &nerrs, nout); } /* Compare RWORK(2*NRHS+1) from CGBSVX with the */ /* computed reciprocal pivot growth RPVGRW */ if (info != 0) { anrmpv = 0.f; i__8 = info; for (j = 1; j <= i__8; ++j) { /* Computing MAX */ i__6 = ku + 2 - j; /* Computing MIN */ i__9 = n + ku + 1 - j, i__10 = kl + ku + 1; i__7 = min(i__9,i__10); for (i__ = max(i__6,1); i__ <= i__7; ++i__) { /* Computing MAX */ r__1 = anrmpv, r__2 = c_abs(&a[ i__ + (j - 1) * lda]); anrmpv = dmax(r__1,r__2); /* L60: */ } /* L70: */ } /* Computing MIN */ i__7 = info - 1, i__6 = kl + ku; i__8 = min(i__7,i__6); /* Computing MAX */ i__9 = 1, i__10 = kl + ku + 2 - info; rpvgrw = clantb_("M", "U", "N", &info, & i__8, &afb[max(i__9, i__10)], & ldafb, rdum); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = anrmpv / rpvgrw; } } else { i__8 = kl + ku; rpvgrw = clantb_("M", "U", "N", &n, &i__8, &afb[1], &ldafb, rdum); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = clangb_("M", &n, &kl, &ku, & a[1], &lda, rdum) / rpvgrw; } } /* Computing MAX */ r__2 = rwork[(*nrhs << 1) + 1]; result[6] = (r__1 = rpvgrw - rwork[(*nrhs << 1) + 1], dabs(r__1)) / dmax(r__2, rpvgrw) / slamch_("E"); if (! prefac) { /* Reconstruct matrix from factors and */ /* compute residual. */ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, & afb[1], &ldafb, &iwork[1], &work[ 1], result); k1 = 1; } else { k1 = 2; } if (info == 0) { trfcon = FALSE_; /* Compute residual of the computed solution. */ clacpy_("Full", &n, nrhs, &bsav[1], &ldb, &work[1], &ldb); cgbt02_(trans, &n, &n, &kl, &ku, nrhs, & asav[1], &lda, &x[1], &ldb, &work[ 1], &ldb, &result[1]); /* Check solution from generated exact */ /* solution. */ if (nofact || prefac && lsame_(equed, "N")) { cget04_(&n, nrhs, &x[1], &ldb, &xact[ 1], &ldb, &rcondc, &result[2]) ; } else { if (itran == 1) { roldc = roldo; } else { roldc = roldi; } cget04_(&n, nrhs, &x[1], &ldb, &xact[ 1], &ldb, &roldc, &result[2]); } /* Check the error bounds from iterative */ /* refinement. */ cgbt05_(trans, &n, &kl, &ku, nrhs, &asav[ 1], &lda, &bsav[1], &ldb, &x[1], & ldb, &xact[1], &ldb, &rwork[1], & rwork[*nrhs + 1], &result[3]); } else { trfcon = TRUE_; } /* Compare RCOND from CGBSVX with the computed */ /* value in RCONDC. */ result[5] = sget06_(&rcond, &rcondc); /* Print information about the tests that did */ /* not pass the threshold. */ if (! trfcon) { for (k = k1; k <= 7; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___73.ciunit = *nout; s_wsfe(&io___73); do_fio(&c__1, "CGBSVX", (ftnlen)6); do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer) ); do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[k - 1], (ftnlen) sizeof(real)); e_wsfe(); } else { io___74.ciunit = *nout; s_wsfe(&io___74); do_fio(&c__1, "CGBSVX", (ftnlen)6); do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer) ); do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[k - 1], (ftnlen) sizeof(real)); e_wsfe(); } ++nfail; } /* L80: */ } nrun = nrun + 7 - k1; } else { if (result[0] >= *thresh && ! prefac) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___75.ciunit = *nout; s_wsfe(&io___75); do_fio(&c__1, "CGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__1, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)); e_wsfe(); } else { io___76.ciunit = *nout; s_wsfe(&io___76); do_fio(&c__1, "CGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__1, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)); e_wsfe(); } ++nfail; ++nrun; } if (result[5] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___77.ciunit = *nout; s_wsfe(&io___77); do_fio(&c__1, "CGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__6, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(real)); e_wsfe(); } else { io___78.ciunit = *nout; s_wsfe(&io___78); do_fio(&c__1, "CGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__6, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(real)); e_wsfe(); } ++nfail; ++nrun; } if (result[6] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___79.ciunit = *nout; s_wsfe(&io___79); do_fio(&c__1, "CGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__7, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real)); e_wsfe(); } else { io___80.ciunit = *nout; s_wsfe(&io___80); do_fio(&c__1, "CGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__7, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real)); e_wsfe(); } ++nfail; ++nrun; } } /* L90: */ } L100: ; } /* L110: */ } L120: ; } L130: ; } /* L140: */ } /* L150: */ } /* Print a summary of the results. */ alasvm_(path, nout, &nfail, &nrun, &nerrs); return 0; /* End of CDRVGB */ } /* cdrvgb_ */
/* Subroutine */ int cgbrfs_(char *trans, integer *n, integer *kl, integer * ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer * ldafb, integer *ipiv, complex *b, integer *ldb, complex *x, integer * ldx, real *ferr, real *berr, complex *work, real *rwork, integer * info) { /* System generated locals */ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; real r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer i__, j, k; real s; integer kk; real xk; integer nz; real eps; integer kase; real safe1, safe2; extern /* Subroutine */ int cgbmv_(char *, integer *, integer *, integer * , integer *, complex *, complex *, integer *, complex *, integer * , complex *, complex *, integer *); extern logical lsame_(char *, char *); integer isave[3]; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); integer count; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); extern doublereal slamch_(char *); real safmin; extern /* Subroutine */ int xerbla_(char *, integer *), cgbtrs_( char *, integer *, integer *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); logical notran; char transn[1], transt[1]; real lstres; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGBRFS improves the computed solution to a system of linear */ /* equations when the coefficient matrix is banded, and provides */ /* error bounds and backward error estimates for the solution. */ /* Arguments */ /* ========= */ /* TRANS (input) CHARACTER*1 */ /* Specifies the form of the system of equations: */ /* = 'N': A * X = B (No transpose) */ /* = 'T': A**T * X = B (Transpose) */ /* = 'C': A**H * X = B (Conjugate transpose) */ /* N (input) INTEGER */ /* The order 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. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* The original band matrix A, stored in rows 1 to KL+KU+1. */ /* The j-th column of A is stored in the j-th column of the */ /* array AB as follows: */ /* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KL+KU+1. */ /* AFB (input) COMPLEX array, dimension (LDAFB,N) */ /* Details of the LU factorization of the band matrix A, as */ /* computed by CGBTRF. 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. */ /* LDAFB (input) INTEGER */ /* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices from CGBTRF; for 1<=i<=N, row i of the */ /* matrix was interchanged with row IPIV(i). */ /* B (input) COMPLEX array, dimension (LDB,NRHS) */ /* The right hand side matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (input/output) COMPLEX array, dimension (LDX,NRHS) */ /* On entry, the solution matrix X, as computed by CGBTRS. */ /* On exit, the improved solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* FERR (output) REAL array, dimension (NRHS) */ /* The estimated forward error bound for each solution vector */ /* X(j) (the j-th column of the solution matrix X). */ /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ /* is an estimated upper bound for the magnitude of the largest */ /* element in (X(j) - XTRUE) divided by the magnitude of the */ /* largest element in X(j). The estimate is as reliable as */ /* the estimate for RCOND, and is almost always a slight */ /* overestimate of the true error. */ /* BERR (output) REAL array, dimension (NRHS) */ /* The componentwise relative backward error of each solution */ /* vector X(j) (i.e., the smallest relative change in */ /* any element of A or B that makes X(j) an exact solution). */ /* WORK (workspace) COMPLEX array, dimension (2*N) */ /* RWORK (workspace) REAL array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Internal Parameters */ /* =================== */ /* ITMAX is the maximum number of steps of iterative refinement. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; afb_dim1 = *ldafb; afb_offset = 1 + afb_dim1; afb -= afb_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); if (! notran && ! lsame_(trans, "T") && ! lsame_( trans, "C")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kl < 0) { *info = -3; } else if (*ku < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldab < *kl + *ku + 1) { *info = -7; } else if (*ldafb < (*kl << 1) + *ku + 1) { *info = -9; } else if (*ldb < max(1,*n)) { *info = -12; } else if (*ldx < max(1,*n)) { *info = -14; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.f; berr[j] = 0.f; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transn = 'N'; *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transn = 'C'; *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ /* Computing MIN */ i__1 = *kl + *ku + 2, i__2 = *n + 1; nz = min(i__1,i__2); eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { count = 1; lstres = 3.f; L20: /* Loop until stopping criterion is satisfied. */ /* Compute residual R = B - op(A) * X, */ /* where op(A) = A, A**T, or A**H, depending on TRANS. */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); q__1.r = -1.f, q__1.i = -0.f; cgbmv_(trans, n, n, kl, ku, &q__1, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1); /* Compute componentwise relative backward error from formula */ /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. If the i-th component of the denominator is less */ /* than SAFE2, then SAFE1 is added to the i-th components of the */ /* numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[ i__ + j * b_dim1]), dabs(r__2)); /* L30: */ } /* Compute abs(op(A))*abs(X) + abs(B). */ if (notran) { i__2 = *n; for (k = 1; k <= i__2; ++k) { kk = *ku + 1 - k; i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j * x_dim1]), dabs(r__2)); /* Computing MAX */ i__3 = 1, i__4 = k - *ku; /* Computing MIN */ i__6 = *n, i__7 = k + *kl; i__5 = min(i__6,i__7); for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) { i__3 = kk + i__ + k * ab_dim1; rwork[i__] += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&ab[kk + i__ + k * ab_dim1]), dabs(r__2))) * xk; /* L40: */ } /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; kk = *ku + 1 - k; /* Computing MAX */ i__5 = 1, i__3 = k - *ku; /* Computing MIN */ i__6 = *n, i__7 = k + *kl; i__4 = min(i__6,i__7); for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) { i__5 = kk + i__ + k * ab_dim1; i__3 = i__ + j * x_dim1; s += ((r__1 = ab[i__5].r, dabs(r__1)) + (r__2 = r_imag(& ab[kk + i__ + k * ab_dim1]), dabs(r__2))) * (( r__3 = x[i__3].r, dabs(r__3)) + (r__4 = r_imag(&x[ i__ + j * x_dim1]), dabs(r__4))); /* L60: */ } rwork[k] += s; /* L70: */ } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__4 = i__; r__3 = s, r__4 = ((r__1 = work[i__4].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2))) / rwork[i__]; s = dmax(r__3,r__4); } else { /* Computing MAX */ i__4 = i__; r__3 = s, r__4 = ((r__1 = work[i__4].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__] + safe1); s = dmax(r__3,r__4); } /* L80: */ } berr[j] = s; /* Test stopping criterion. Continue iterating if */ /* 1) The residual BERR(J) is larger than machine epsilon, and */ /* 2) BERR(J) decreased by at least a factor of 2 during the */ /* last iteration, and */ /* 3) At most ITMAX iterations tried. */ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { /* Update solution and try again. */ cgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] , &work[1], n, info); caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); lstres = berr[j]; ++count; goto L20; } /* Bound error from formula */ /* norm(X - XTRUE) / norm(X) .le. FERR = */ /* norm( abs(inv(op(A)))* */ /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ /* where */ /* norm(Z) is the magnitude of the largest component of Z */ /* inv(op(A)) is the inverse of op(A) */ /* abs(Z) is the componentwise absolute value of the matrix or */ /* vector Z */ /* NZ is the maximum number of nonzeros in any row of A, plus 1 */ /* EPS is machine epsilon */ /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ /* is incremented by SAFE1 if the i-th component of */ /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ /* Use CLACN2 to estimate the infinity-norm of the matrix */ /* inv(op(A)) * diag(W), */ /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__4 = i__; rwork[i__] = (r__1 = work[i__4].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__]; } else { i__4 = i__; rwork[i__] = (r__1 = work[i__4].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L90: */ } kase = 0; L100: clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ cgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & ipiv[1], &work[1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__4 = i__; i__5 = i__; i__3 = i__; q__1.r = rwork[i__5] * work[i__3].r, q__1.i = rwork[i__5] * work[i__3].i; work[i__4].r = q__1.r, work[i__4].i = q__1.i; /* L110: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__4 = i__; i__5 = i__; i__3 = i__; q__1.r = rwork[i__5] * work[i__3].r, q__1.i = rwork[i__5] * work[i__3].i; work[i__4].r = q__1.r, work[i__4].i = q__1.i; /* L120: */ } cgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & ipiv[1], &work[1], n, info); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__4 = i__ + j * x_dim1; r__3 = lstres, r__4 = (r__1 = x[i__4].r, dabs(r__1)) + (r__2 = r_imag(&x[i__ + j * x_dim1]), dabs(r__2)); lstres = dmax(r__3,r__4); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of CGBRFS */ } /* cgbrfs_ */
/* Subroutine */ int cgbsv_(integer *n, integer *kl, integer *ku, integer * nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer * ldb, integer *info) { /* -- LAPACK driver 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 ======= CGBSV computes the solution to a complex system of linear equations A * X = B, where A is a band matrix of order N with KL subdiagonals and KU superdiagonals, and X and B are N-by-NRHS matrices. The LU decomposition with partial pivoting and row interchanges is used to factor A as A = L * U, where L is a product of permutation and unit lower triangular matrices with KL subdiagonals, and U is upper triangular with KL+KU superdiagonals. The factored form of A is then used to solve the system of equations A * X = B. Arguments ========= N (input) INTEGER The number of linear equations, i.e., the order 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. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. AB (input/output) COMPLEX 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(N,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 (N) The pivot indices that define the permutation matrix P; row i of the matrix was interchanged with row IPIV(i). B (input/output) COMPLEX array, dimension (LDB,NRHS) On entry, the N-by-NRHS right hand side matrix B. On exit, if INFO = 0, the N-by-NRHS solution matrix X. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). 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 the solution has not been computed. 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. ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; /* Local variables */ extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *, integer *, complex *, integer *, integer *, integer *), xerbla_( char *, integer *), cgbtrs_(char *, integer *, integer *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); #define IPIV(I) ipiv[(I)-1] #define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)] #define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)] *info = 0; if (*n < 0) { *info = -1; } else if (*kl < 0) { *info = -2; } else if (*ku < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*ldab < (*kl << 1) + *ku + 1) { *info = -6; } else if (*ldb < max(*n,1)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBSV ", &i__1); return 0; } /* Compute the LU factorization of the band matrix A. */ cgbtrf_(n, n, kl, ku, &AB(1,1), ldab, &IPIV(1), info); if (*info == 0) { /* Solve the system A*X = B, overwriting B with X. */ cgbtrs_("No transpose", n, kl, ku, nrhs, &AB(1,1), ldab, &IPIV( 1), &B(1,1), ldb, info); } return 0; /* End of CGBSV */ } /* cgbsv_ */
/* Subroutine */ int cla_gbrfsx_extended__(integer *prec_type__, integer * trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer * ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex * y, integer *ldy, real *berr_out__, integer *n_norms__, real * err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb, complex *dy, complex *y_tail__, real *rcond, integer *ithresh, real * rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; real r__1, r__2; char ch__1[1]; /* Builtin functions */ double r_imag(complex *); /* Local variables */ real dxratmax, dzratmax; integer i__, j, m; extern /* Subroutine */ int cla_gbamv__(integer *, integer *, integer *, integer *, integer *, real *, complex *, integer *, complex *, integer *, real *, real *, integer *); logical incr_prec__; real prev_dz_z__, yk, final_dx_x__; extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *, complex *); real final_dz_z__, prevnormdx; integer cnt; real dyk, eps, incr_thresh__, dx_x__, dz_z__; extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer * , complex *, real *, real *); real ymin; extern /* Subroutine */ int blas_cgbmv_x__(integer *, integer *, integer * , integer *, integer *, complex *, complex *, integer *, complex * , integer *, complex *, complex *, integer *, integer *); integer y_prec_state__; extern /* Subroutine */ int blas_cgbmv2_x__(integer *, integer *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex *, integer *); real dxrat, dzrat; extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); char trans[1]; real normx, normy; extern doublereal slamch_(char *); extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); real normdx; extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *); real hugeval; integer x_state__, z_state__; /* -- LAPACK routine (version 3.2.1) -- */ /* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ /* -- Jason Riedy of Univ. of California Berkeley. -- */ /* -- April 2009 -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley and NAG Ltd. -- */ /* .. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLA_GBRFSX_EXTENDED improves the computed solution to a system of */ /* linear equations by performing extra-precise iterative refinement */ /* and provides error bounds and backward error estimates for the solution. */ /* This subroutine is called by CGBRFSX to perform iterative refinement. */ /* In addition to normwise error bound, the code provides maximum */ /* componentwise error bound if possible. See comments for ERR_BNDS_NORM */ /* and ERR_BNDS_COMP for details of the error bounds. Note that this */ /* subroutine is only resonsible for setting the second fields of */ /* ERR_BNDS_NORM and ERR_BNDS_COMP. */ /* Arguments */ /* ========= */ /* PREC_TYPE (input) INTEGER */ /* Specifies the intermediate precision to be used in refinement. */ /* The value is defined by ILAPREC(P) where P is a CHARACTER and */ /* P = 'S': Single */ /* = 'D': Double */ /* = 'I': Indigenous */ /* = 'X', 'E': Extra */ /* TRANS_TYPE (input) INTEGER */ /* Specifies the transposition operation on A. */ /* The value is defined by ILATRANS(T) where T is a CHARACTER and */ /* T = 'N': No transpose */ /* = 'T': Transpose */ /* = 'C': Conjugate transpose */ /* N (input) INTEGER */ /* The number of linear equations, i.e., the order 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 */ /* NRHS (input) INTEGER */ /* The number of right-hand-sides, i.e., the number of columns of the */ /* matrix B. */ /* AB (input) COMPLEX array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* AFB (input) COMPLEX array, dimension (LDAF,N) */ /* The factors L and U from the factorization */ /* A = P*L*U as computed by CGBTRF. */ /* LDAFB (input) INTEGER */ /* The leading dimension of the array AF. LDAF >= max(1,N). */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices from the factorization A = P*L*U */ /* as computed by CGBTRF; row i of the matrix was interchanged */ /* with row IPIV(i). */ /* COLEQU (input) LOGICAL */ /* If .TRUE. then column equilibration was done to A before calling */ /* this routine. This is needed to compute the solution and error */ /* bounds correctly. */ /* C (input) REAL array, dimension (N) */ /* The column scale factors for A. If COLEQU = .FALSE., C */ /* is not accessed. If C is input, each element of C should be a power */ /* of the radix to ensure a reliable solution and error estimates. */ /* Scaling by powers of the radix does not cause rounding errors unless */ /* the result underflows or overflows. Rounding errors during scaling */ /* lead to refining with a matrix that is not equivalent to the */ /* input matrix, producing error estimates that may not be */ /* reliable. */ /* B (input) COMPLEX array, dimension (LDB,NRHS) */ /* The right-hand-side matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* Y (input/output) COMPLEX array, dimension (LDY,NRHS) */ /* On entry, the solution matrix X, as computed by CGBTRS. */ /* On exit, the improved solution matrix Y. */ /* LDY (input) INTEGER */ /* The leading dimension of the array Y. LDY >= max(1,N). */ /* BERR_OUT (output) REAL array, dimension (NRHS) */ /* On exit, BERR_OUT(j) contains the componentwise relative backward */ /* error for right-hand-side j from the formula */ /* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. This is computed by CLA_LIN_BERR. */ /* N_NORMS (input) INTEGER */ /* Determines which error bounds to return (see ERR_BNDS_NORM */ /* and ERR_BNDS_COMP). */ /* If N_NORMS >= 1 return normwise error bounds. */ /* If N_NORMS >= 2 return componentwise error bounds. */ /* ERR_BNDS_NORM (input/output) REAL array, dimension */ /* (NRHS, N_ERR_BNDS) */ /* For each right-hand side, this array contains information about */ /* various error bounds and condition numbers corresponding to the */ /* normwise relative error, which is defined as follows: */ /* Normwise relative error in the ith solution vector: */ /* max_j (abs(XTRUE(j,i) - X(j,i))) */ /* ------------------------------ */ /* max_j abs(X(j,i)) */ /* The array is indexed by the type of error information as described */ /* below. There currently are up to three pieces of information */ /* returned. */ /* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ /* right-hand side. */ /* The second index in ERR_BNDS_NORM(:,err) contains the following */ /* three fields: */ /* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ /* reciprocal condition number is less than the threshold */ /* sqrt(n) * slamch('Epsilon'). */ /* err = 2 "Guaranteed" error bound: The estimated forward error, */ /* almost certainly within a factor of 10 of the true error */ /* so long as the next entry is greater than the threshold */ /* sqrt(n) * slamch('Epsilon'). This error bound should only */ /* be trusted if the previous boolean is true. */ /* err = 3 Reciprocal condition number: Estimated normwise */ /* reciprocal condition number. Compared with the threshold */ /* sqrt(n) * slamch('Epsilon') to determine if the error */ /* estimate is "guaranteed". These reciprocal condition */ /* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ /* appropriately scaled matrix Z. */ /* Let Z = S*A, where S scales each row by a power of the */ /* radix so all absolute row sums of Z are approximately 1. */ /* This subroutine is only responsible for setting the second field */ /* above. */ /* See Lapack Working Note 165 for further details and extra */ /* cautions. */ /* ERR_BNDS_COMP (input/output) REAL array, dimension */ /* (NRHS, N_ERR_BNDS) */ /* For each right-hand side, this array contains information about */ /* various error bounds and condition numbers corresponding to the */ /* componentwise relative error, which is defined as follows: */ /* Componentwise relative error in the ith solution vector: */ /* abs(XTRUE(j,i) - X(j,i)) */ /* max_j ---------------------- */ /* abs(X(j,i)) */ /* The array is indexed by the right-hand side i (on which the */ /* componentwise relative error depends), and the type of error */ /* information as described below. There currently are up to three */ /* pieces of information returned for each right-hand side. If */ /* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ /* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ /* the first (:,N_ERR_BNDS) entries are returned. */ /* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ /* right-hand side. */ /* The second index in ERR_BNDS_COMP(:,err) contains the following */ /* three fields: */ /* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ /* reciprocal condition number is less than the threshold */ /* sqrt(n) * slamch('Epsilon'). */ /* err = 2 "Guaranteed" error bound: The estimated forward error, */ /* almost certainly within a factor of 10 of the true error */ /* so long as the next entry is greater than the threshold */ /* sqrt(n) * slamch('Epsilon'). This error bound should only */ /* be trusted if the previous boolean is true. */ /* err = 3 Reciprocal condition number: Estimated componentwise */ /* reciprocal condition number. Compared with the threshold */ /* sqrt(n) * slamch('Epsilon') to determine if the error */ /* estimate is "guaranteed". These reciprocal condition */ /* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ /* appropriately scaled matrix Z. */ /* Let Z = S*(A*diag(x)), where x is the solution for the */ /* current right-hand side and S scales each row of */ /* A*diag(x) by a power of the radix so all absolute row */ /* sums of Z are approximately 1. */ /* This subroutine is only responsible for setting the second field */ /* above. */ /* See Lapack Working Note 165 for further details and extra */ /* cautions. */ /* RES (input) COMPLEX array, dimension (N) */ /* Workspace to hold the intermediate residual. */ /* AYB (input) REAL array, dimension (N) */ /* Workspace. */ /* DY (input) COMPLEX array, dimension (N) */ /* Workspace to hold the intermediate solution. */ /* Y_TAIL (input) COMPLEX array, dimension (N) */ /* Workspace to hold the trailing bits of the intermediate solution. */ /* RCOND (input) REAL */ /* Reciprocal scaled condition number. This is an estimate of the */ /* reciprocal Skeel condition number of the matrix A after */ /* equilibration (if done). If this is less than the machine */ /* precision (in particular, if it is zero), the matrix is singular */ /* to working precision. Note that the error may still be small even */ /* if this number is very small and the matrix appears ill- */ /* conditioned. */ /* ITHRESH (input) INTEGER */ /* The maximum number of residual computations allowed for */ /* refinement. The default is 10. For 'aggressive' set to 100 to */ /* permit convergence using approximate factorizations or */ /* factorizations other than LU. If the factorization uses a */ /* technique other than Gaussian elimination, the guarantees in */ /* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ /* RTHRESH (input) REAL */ /* Determines when to stop refinement if the error estimate stops */ /* decreasing. Refinement will stop when the next solution no longer */ /* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ /* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ /* default value is 0.5. For 'aggressive' set to 0.9 to permit */ /* convergence on extremely ill-conditioned matrices. See LAWN 165 */ /* for more details. */ /* DZ_UB (input) REAL */ /* Determines when to start considering componentwise convergence. */ /* Componentwise convergence is only considered after each component */ /* of the solution Y is stable, which we definte as the relative */ /* change in each component being less than DZ_UB. The default value */ /* is 0.25, requiring the first bit to be stable. See LAWN 165 for */ /* more details. */ /* IGNORE_CWISE (input) LOGICAL */ /* If .TRUE. then ignore componentwise convergence. Default value */ /* is .FALSE.. */ /* INFO (output) INTEGER */ /* = 0: Successful exit. */ /* < 0: if INFO = -i, the ith argument to CGBTRS had an illegal */ /* value */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. Parameters .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions.. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function Definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ err_bnds_comp_dim1 = *nrhs; err_bnds_comp_offset = 1 + err_bnds_comp_dim1; err_bnds_comp__ -= err_bnds_comp_offset; err_bnds_norm_dim1 = *nrhs; err_bnds_norm_offset = 1 + err_bnds_norm_dim1; err_bnds_norm__ -= err_bnds_norm_offset; ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; afb_dim1 = *ldafb; afb_offset = 1 + afb_dim1; afb -= afb_offset; --ipiv; --c__; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; y_dim1 = *ldy; y_offset = 1 + y_dim1; y -= y_offset; --berr_out__; --res; --ayb; --dy; --y_tail__; /* Function Body */ if (*info != 0) { return 0; } chla_transtype__(ch__1, (ftnlen)1, trans_type__); *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; eps = slamch_("Epsilon"); hugeval = slamch_("Overflow"); /* Force HUGEVAL to Inf */ hugeval *= hugeval; /* Using HUGEVAL may lead to spurious underflows. */ incr_thresh__ = (real) (*n) * eps; m = *kl + *ku + 1; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { y_prec_state__ = 1; if (y_prec_state__ == 2) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f; } } dxrat = 0.f; dxratmax = 0.f; dzrat = 0.f; dzratmax = 0.f; final_dx_x__ = hugeval; final_dz_z__ = hugeval; prevnormdx = hugeval; prev_dz_z__ = hugeval; dz_z__ = hugeval; dx_x__ = hugeval; x_state__ = 1; z_state__ = 0; incr_prec__ = FALSE_; i__2 = *ithresh; for (cnt = 1; cnt <= i__2; ++cnt) { /* Compute residual RES = B_s - op(A_s) * Y, */ /* op(A) = A, A**T, or A**H depending on TRANS (and type). */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); if (y_prec_state__ == 0) { cgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[ j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); } else if (y_prec_state__ == 1) { blas_cgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, & res[1], &c__1, prec_type__); } else { blas_cgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], & c__1, &c_b8, &res[1], &c__1, prec_type__); } /* XXX: RES is no longer needed. */ ccopy_(n, &res[1], &c__1, &dy[1], &c__1); cgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] , &dy[1], n, info); /* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ normx = 0.f; normy = 0.f; normdx = 0.f; dz_z__ = 0.f; ymin = hugeval; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + j * y_dim1; yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ + j * y_dim1]), dabs(r__2)); i__4 = i__; dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[ i__]), dabs(r__2)); if (yk != 0.f) { /* Computing MAX */ r__1 = dz_z__, r__2 = dyk / yk; dz_z__ = dmax(r__1,r__2); } else if (dyk != 0.f) { dz_z__ = hugeval; } ymin = dmin(ymin,yk); normy = dmax(normy,yk); if (*colequ) { /* Computing MAX */ r__1 = normx, r__2 = yk * c__[i__]; normx = dmax(r__1,r__2); /* Computing MAX */ r__1 = normdx, r__2 = dyk * c__[i__]; normdx = dmax(r__1,r__2); } else { normx = normy; normdx = dmax(normdx,dyk); } } if (normx != 0.f) { dx_x__ = normdx / normx; } else if (normdx == 0.f) { dx_x__ = 0.f; } else { dx_x__ = hugeval; } dxrat = normdx / prevnormdx; dzrat = dz_z__ / prev_dz_z__; /* Check termination criteria. */ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { incr_prec__ = TRUE_; } if (x_state__ == 3 && dxrat <= *rthresh) { x_state__ = 1; } if (x_state__ == 1) { if (dx_x__ <= eps) { x_state__ = 2; } else if (dxrat > *rthresh) { if (y_prec_state__ != 2) { incr_prec__ = TRUE_; } else { x_state__ = 3; } } else { if (dxrat > dxratmax) { dxratmax = dxrat; } } if (x_state__ > 1) { final_dx_x__ = dx_x__; } } if (z_state__ == 0 && dz_z__ <= *dz_ub__) { z_state__ = 1; } if (z_state__ == 3 && dzrat <= *rthresh) { z_state__ = 1; } if (z_state__ == 1) { if (dz_z__ <= eps) { z_state__ = 2; } else if (dz_z__ > *dz_ub__) { z_state__ = 0; dzratmax = 0.f; final_dz_z__ = hugeval; } else if (dzrat > *rthresh) { if (y_prec_state__ != 2) { incr_prec__ = TRUE_; } else { z_state__ = 3; } } else { if (dzrat > dzratmax) { dzratmax = dzrat; } } if (z_state__ > 1) { final_dz_z__ = dz_z__; } } /* Exit if both normwise and componentwise stopped working, */ /* but if componentwise is unstable, let it go at least two */ /* iterations. */ if (x_state__ != 1) { if (*ignore_cwise__) { goto L666; } if (z_state__ == 3 || z_state__ == 2) { goto L666; } if (z_state__ == 0 && cnt > 1) { goto L666; } } if (incr_prec__) { incr_prec__ = FALSE_; ++y_prec_state__; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f; } } prevnormdx = normdx; prev_dz_z__ = dz_z__; /* Update soluton. */ if (y_prec_state__ < 2) { caxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); } else { cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); } } /* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */ L666: /* Set final_* when cnt hits ithresh. */ if (x_state__ == 1) { final_dx_x__ = dx_x__; } if (z_state__ == 1) { final_dz_z__ = dz_z__; } /* Compute error bounds. */ if (*n_norms__ >= 1) { err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( 1 - dxratmax); } if (*n_norms__ >= 2) { err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( 1 - dzratmax); } /* Compute componentwise relative backward error from formula */ /* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. */ /* Compute residual RES = B_s - op(A_s) * Y, */ /* op(A) = A, A**T, or A**H depending on TRANS (and type). */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); cgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + j * b_dim1]), dabs(r__2)); } /* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ cla_gbamv__(trans_type__, n, n, kl, ku, &c_b31, &ab[ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1); cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); /* End of loop for each RHS. */ } return 0; } /* cla_gbrfsx_extended__ */
/* Subroutine */ int cgbsv_(integer *n, integer *kl, integer *ku, integer * nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer * ldb, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; /* Local variables */ /* -- LAPACK driver routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CGBSV computes the solution to a complex system of linear equations */ /* A * X = B, where A is a band matrix of order N with KL subdiagonals */ /* and KU superdiagonals, and X and B are N-by-NRHS matrices. */ /* The LU decomposition with partial pivoting and row interchanges is */ /* used to factor A as A = L * U, where L is a product of permutation */ /* and unit lower triangular matrices with KL subdiagonals, and U is */ /* upper triangular with KL+KU superdiagonals. The factored form of A */ /* is then used to solve the system of equations A * X = B. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of linear equations, i.e., the order 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. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrix B. NRHS >= 0. */ /* AB (input/output) COMPLEX 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(N,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 (N) */ /* The pivot indices that define the permutation matrix P; */ /* row i of the matrix was interchanged with row IPIV(i). */ /* B (input/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the N-by-NRHS right hand side matrix B. */ /* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* 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 the solution has not been computed. */ /* 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. */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*kl < 0) { *info = -2; } else if (*ku < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*ldab < (*kl << 1) + *ku + 1) { *info = -6; } else if (*ldb < max(*n,1)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBSV ", &i__1); return 0; } /* Compute the LU factorization of the band matrix A. */ cgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); if (*info == 0) { /* Solve the system A*X = B, overwriting B with X. */ cgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[ 1], &b[b_offset], ldb, info); } return 0; /* End of CGBSV */ } /* cgbsv_ */
/* Subroutine */ int cgbsvx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2; complex q__1; /* Builtin functions */ double c_abs(complex *); /* Local variables */ integer i__, j, j1, j2; real amax; char norm[1]; extern logical lsame_(char *, char *); real rcmin, rcmax, anorm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); logical equil; extern doublereal clangb_(char *, integer *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int claqgb_(integer *, integer *, integer *, integer *, complex *, integer *, real *, real *, real *, real *, real *, char *), cgbcon_(char *, integer *, integer *, integer *, complex *, integer *, integer *, real *, real *, complex *, real *, integer *); real colcnd; extern doublereal clantb_(char *, char *, char *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *, integer *, complex *, integer *, real *, real *, real *, real *, real *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int cgbrfs_(char *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, real *, integer *), cgbtrf_(integer *, integer *, integer *, integer *, complex *, integer *, integer *, integer *); logical nofact; extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); real bignum; extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); integer infequ; logical colequ; real rowcnd; logical notran; real smlnum; logical rowequ; real rpvgrw; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGBSVX uses the LU factorization to compute the solution to a complex */ /* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */ /* where A is a band matrix of order N with KL subdiagonals and KU */ /* superdiagonals, and X and B are N-by-NRHS matrices. */ /* Error bounds on the solution and a condition estimate are also */ /* provided. */ /* Description */ /* =========== */ /* The following steps are performed by this subroutine: */ /* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ /* the system: */ /* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ /* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ /* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ /* Whether or not the system will be equilibrated depends on the */ /* scaling of the matrix A, but if equilibration is used, A is */ /* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ /* or diag(C)*B (if TRANS = 'T' or 'C'). */ /* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ /* matrix A (after equilibration if FACT = 'E') as */ /* A = L * U, */ /* where L is a product of permutation and unit lower triangular */ /* matrices with KL subdiagonals, and U is upper triangular with */ /* KL+KU superdiagonals. */ /* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ /* returns with INFO = i. Otherwise, the factored form of A is used */ /* to estimate the condition number of the matrix A. If the */ /* reciprocal of the condition number is less than machine precision, */ /* INFO = N+1 is returned as a warning, but the routine still goes on */ /* to solve for X and compute error bounds as described below. */ /* 4. The system of equations is solved for X using the factored form */ /* of A. */ /* 5. Iterative refinement is applied to improve the computed solution */ /* matrix and calculate error bounds and backward error estimates */ /* for it. */ /* 6. If equilibration was used, the matrix X is premultiplied by */ /* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ /* that it solves the original system before equilibration. */ /* Arguments */ /* ========= */ /* FACT (input) CHARACTER*1 */ /* Specifies whether or not the factored form of the matrix A is */ /* supplied on entry, and if not, whether the matrix A should be */ /* equilibrated before it is factored. */ /* = 'F': On entry, AFB and IPIV contain the factored form of */ /* A. If EQUED is not 'N', the matrix A has been */ /* equilibrated with scaling factors given by R and C. */ /* AB, AFB, and IPIV are not modified. */ /* = 'N': The matrix A will be copied to AFB and factored. */ /* = 'E': The matrix A will be equilibrated if necessary, then */ /* copied to AFB and factored. */ /* TRANS (input) CHARACTER*1 */ /* Specifies the form of the system of equations. */ /* = 'N': A * X = B (No transpose) */ /* = 'T': A**T * X = B (Transpose) */ /* = 'C': A**H * X = B (Conjugate transpose) */ /* N (input) INTEGER */ /* The number of linear equations, i.e., the order 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. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AB (input/output) COMPLEX array, dimension (LDAB,N) */ /* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ /* The j-th column of A is stored in the j-th column of the */ /* array AB as follows: */ /* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ /* If FACT = 'F' and EQUED is not 'N', then A must have been */ /* equilibrated by the scaling factors in R and/or C. AB is not */ /* modified if FACT = 'F' or 'N', or if FACT = 'E' and */ /* EQUED = 'N' on exit. */ /* On exit, if EQUED .ne. 'N', A is scaled as follows: */ /* EQUED = 'R': A := diag(R) * A */ /* EQUED = 'C': A := A * diag(C) */ /* EQUED = 'B': A := diag(R) * A * diag(C). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KL+KU+1. */ /* AFB (input or output) COMPLEX array, dimension (LDAFB,N) */ /* If FACT = 'F', then AFB is an input argument and on entry */ /* contains details of the LU factorization of the band matrix */ /* A, as computed by CGBTRF. 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. If EQUED .ne. 'N', then AFB is */ /* the factored form of the equilibrated matrix A. */ /* If FACT = 'N', then AFB is an output argument and on exit */ /* returns details of the LU factorization of A. */ /* If FACT = 'E', then AFB is an output argument and on exit */ /* returns details of the LU factorization of the equilibrated */ /* matrix A (see the description of AB for the form of the */ /* equilibrated matrix). */ /* LDAFB (input) INTEGER */ /* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ /* IPIV (input or output) INTEGER array, dimension (N) */ /* If FACT = 'F', then IPIV is an input argument and on entry */ /* contains the pivot indices from the factorization A = L*U */ /* as computed by CGBTRF; row i of the matrix was interchanged */ /* with row IPIV(i). */ /* If FACT = 'N', then IPIV is an output argument and on exit */ /* contains the pivot indices from the factorization A = L*U */ /* of the original matrix A. */ /* If FACT = 'E', then IPIV is an output argument and on exit */ /* contains the pivot indices from the factorization A = L*U */ /* of the equilibrated matrix A. */ /* EQUED (input or output) CHARACTER*1 */ /* Specifies the form of equilibration that was done. */ /* = 'N': No equilibration (always true if FACT = 'N'). */ /* = 'R': Row equilibration, i.e., A has been premultiplied by */ /* diag(R). */ /* = 'C': Column equilibration, i.e., A has been postmultiplied */ /* by diag(C). */ /* = 'B': Both row and column equilibration, i.e., A has been */ /* replaced by diag(R) * A * diag(C). */ /* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ /* output argument. */ /* R (input or output) REAL array, dimension (N) */ /* The row scale factors for A. If EQUED = 'R' or 'B', A is */ /* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ /* is not accessed. R is an input argument if FACT = 'F'; */ /* otherwise, R is an output argument. If FACT = 'F' and */ /* EQUED = 'R' or 'B', each element of R must be positive. */ /* C (input or output) REAL array, dimension (N) */ /* The column scale factors for A. If EQUED = 'C' or 'B', A is */ /* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ /* is not accessed. C is an input argument if FACT = 'F'; */ /* otherwise, C is an output argument. If FACT = 'F' and */ /* EQUED = 'C' or 'B', each element of C must be positive. */ /* B (input/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the right hand side matrix B. */ /* On exit, */ /* if EQUED = 'N', B is not modified; */ /* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ /* diag(R)*B; */ /* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ /* overwritten by diag(C)*B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (output) COMPLEX array, dimension (LDX,NRHS) */ /* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ /* to the original system of equations. Note that A and B are */ /* modified on exit if EQUED .ne. 'N', and the solution to the */ /* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ /* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ /* and EQUED = 'R' or 'B'. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* RCOND (output) REAL */ /* The estimate of the reciprocal condition number of the matrix */ /* A after equilibration (if done). If RCOND is less than the */ /* machine precision (in particular, if RCOND = 0), the matrix */ /* is singular to working precision. This condition is */ /* indicated by a return code of INFO > 0. */ /* FERR (output) REAL array, dimension (NRHS) */ /* The estimated forward error bound for each solution vector */ /* X(j) (the j-th column of the solution matrix X). */ /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ /* is an estimated upper bound for the magnitude of the largest */ /* element in (X(j) - XTRUE) divided by the magnitude of the */ /* largest element in X(j). The estimate is as reliable as */ /* the estimate for RCOND, and is almost always a slight */ /* overestimate of the true error. */ /* BERR (output) REAL array, dimension (NRHS) */ /* The componentwise relative backward error of each solution */ /* vector X(j) (i.e., the smallest relative change in */ /* any element of A or B that makes X(j) an exact solution). */ /* WORK (workspace) COMPLEX array, dimension (2*N) */ /* RWORK (workspace/output) REAL array, dimension (N) */ /* On exit, RWORK(1) contains the reciprocal pivot growth */ /* factor norm(A)/norm(U). The "max absolute element" norm is */ /* used. If RWORK(1) is much less than 1, then the stability */ /* of the LU factorization of the (equilibrated) matrix A */ /* could be poor. This also means that the solution X, condition */ /* estimator RCOND, and forward error bound FERR could be */ /* unreliable. If factorization fails with 0<INFO<=N, then */ /* RWORK(1) contains the reciprocal pivot growth factor for the */ /* leading INFO columns of A. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, and i is */ /* <= N: U(i,i) is exactly zero. The factorization */ /* has been completed, but the factor U is exactly */ /* singular, so the solution and error bounds */ /* could not be computed. RCOND = 0 is returned. */ /* = N+1: U is nonsingular, but RCOND is less than machine */ /* precision, meaning that the matrix is singular */ /* to working precision. Nevertheless, the */ /* solution and error bounds are computed because */ /* there are a number of situations where the */ /* computed solution can be more accurate than the */ /* value of RCOND would suggest. */ /* ===================================================================== */ /* Moved setting of INFO = N+1 so INFO does not subsequently get */ /* overwritten. Sven, 17 Mar 05. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; afb_dim1 = *ldafb; afb_offset = 1 + afb_dim1; afb -= afb_offset; --ipiv; --r__; --c__; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; nofact = lsame_(fact, "N"); equil = lsame_(fact, "E"); notran = lsame_(trans, "N"); if (nofact || equil) { *(unsigned char *)equed = 'N'; rowequ = FALSE_; colequ = FALSE_; } else { rowequ = lsame_(equed, "R") || lsame_(equed, "B"); colequ = lsame_(equed, "C") || lsame_(equed, "B"); smlnum = slamch_("Safe minimum"); bignum = 1.f / smlnum; } /* Test the input parameters. */ if (! nofact && ! equil && ! lsame_(fact, "F")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*kl < 0) { *info = -4; } else if (*ku < 0) { *info = -5; } else if (*nrhs < 0) { *info = -6; } else if (*ldab < *kl + *ku + 1) { *info = -8; } else if (*ldafb < (*kl << 1) + *ku + 1) { *info = -10; } else if (lsame_(fact, "F") && ! (rowequ || colequ || lsame_(equed, "N"))) { *info = -12; } else { if (rowequ) { rcmin = bignum; rcmax = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ r__1 = rcmin, r__2 = r__[j]; rcmin = dmin(r__1,r__2); /* Computing MAX */ r__1 = rcmax, r__2 = r__[j]; rcmax = dmax(r__1,r__2); /* L10: */ } if (rcmin <= 0.f) { *info = -13; } else if (*n > 0) { rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum); } else { rowcnd = 1.f; } } if (colequ && *info == 0) { rcmin = bignum; rcmax = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ r__1 = rcmin, r__2 = c__[j]; rcmin = dmin(r__1,r__2); /* Computing MAX */ r__1 = rcmax, r__2 = c__[j]; rcmax = dmax(r__1,r__2); /* L20: */ } if (rcmin <= 0.f) { *info = -14; } else if (*n > 0) { colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum); } else { colcnd = 1.f; } } if (*info == 0) { if (*ldb < max(1,*n)) { *info = -16; } else if (*ldx < max(1,*n)) { *info = -18; } } } if (*info != 0) { i__1 = -(*info); xerbla_("CGBSVX", &i__1); return 0; } if (equil) { /* Compute row and column scalings to equilibrate the matrix A. */ cgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd, &colcnd, &amax, &infequ); if (infequ == 0) { /* Equilibrate the matrix. */ claqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & rowcnd, &colcnd, &amax, equed); rowequ = lsame_(equed, "R") || lsame_(equed, "B"); colequ = lsame_(equed, "C") || lsame_(equed, "B"); } } /* Scale the right hand side. */ if (notran) { if (rowequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; i__4 = i__; i__5 = i__ + j * b_dim1; q__1.r = r__[i__4] * b[i__5].r, q__1.i = r__[i__4] * b[ i__5].i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L30: */ } /* L40: */ } } } else if (colequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; i__4 = i__; i__5 = i__ + j * b_dim1; q__1.r = c__[i__4] * b[i__5].r, q__1.i = c__[i__4] * b[i__5] .i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L50: */ } /* L60: */ } } if (nofact || equil) { /* Compute the LU factorization of the band matrix A. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = j - *ku; j1 = max(i__2,1); /* Computing MIN */ i__2 = j + *kl; j2 = min(i__2,*n); i__2 = j2 - j1 + 1; ccopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[* kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1); /* L70: */ } cgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); /* Return if INFO is non-zero. */ if (*info > 0) { /* Compute the reciprocal pivot growth factor of the */ /* leading rank-deficient INFO columns of A. */ anorm = 0.f; i__1 = *info; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; i__3 = min(i__4,i__5); for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__1 = anorm, r__2 = c_abs(&ab[i__ + j * ab_dim1]); anorm = dmax(r__1,r__2); /* L80: */ } /* L90: */ } /* Computing MIN */ i__3 = *info - 1, i__2 = *kl + *ku; i__1 = min(i__3,i__2); /* Computing MAX */ i__4 = 1, i__5 = *kl + *ku + 2 - *info; rpvgrw = clantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5) + afb_dim1], ldafb, &rwork[1]); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = anorm / rpvgrw; } rwork[1] = rpvgrw; *rcond = 0.f; return 0; } } /* Compute the norm of the matrix A and the */ /* reciprocal pivot growth factor RPVGRW. */ if (notran) { *(unsigned char *)norm = '1'; } else { *(unsigned char *)norm = 'I'; } anorm = clangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &rwork[1]); i__1 = *kl + *ku; rpvgrw = clantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &rwork[ 1]); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = clangb_("M", n, kl, ku, &ab[ab_offset], ldab, &rwork[1]) / rpvgrw; } /* Compute the reciprocal of the condition number of A. */ cgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, &work[1], &rwork[1], info); /* Compute the solution matrix X. */ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); cgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ x_offset], ldx, info); /* Use iterative refinement to improve the computed solution and */ /* compute error bounds and backward error estimates for it. */ cgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], & berr[1], &work[1], &rwork[1], info); /* Transform the solution matrix X to a solution of the original */ /* system. */ if (notran) { if (colequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__2 = i__ + j * x_dim1; i__4 = i__; i__5 = i__ + j * x_dim1; q__1.r = c__[i__4] * x[i__5].r, q__1.i = c__[i__4] * x[ i__5].i; x[i__2].r = q__1.r, x[i__2].i = q__1.i; /* L100: */ } /* L110: */ } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] /= colcnd; /* L120: */ } } } else if (rowequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__2 = i__ + j * x_dim1; i__4 = i__; i__5 = i__ + j * x_dim1; q__1.r = r__[i__4] * x[i__5].r, q__1.i = r__[i__4] * x[i__5] .i; x[i__2].r = q__1.r, x[i__2].i = q__1.i; /* L130: */ } /* L140: */ } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] /= rowcnd; /* L150: */ } } /* Set INFO = N+1 if the matrix is singular to working precision. */ if (*rcond < slamch_("Epsilon")) { *info = *n + 1; } rwork[1] = rpvgrw; return 0; /* End of CGBSVX */ } /* cgbsvx_ */
/* Subroutine */ int cerrge_(char *path, integer *nunit) { /* System generated locals */ integer i__1; real r__1, r__2; complex q__1; /* Local variables */ complex a[16] /* was [4][4] */, b[4]; integer i__, j; real r__[4]; complex w[8], x[4]; char c2[2]; real r1[4], r2[4]; complex af[16] /* was [4][4] */; integer ip[4], info; real anrm, ccond, rcond; /* 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 */ /* ======= */ /* CERRGE tests the error exits for the COMPLEX 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__) { i__1 = i__ + (j << 2) - 5; r__1 = 1.f / (real) (i__ + j); r__2 = -1.f / (real) (i__ + j); q__1.r = r__1, q__1.i = r__2; a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = i__ + (j << 2) - 5; r__1 = 1.f / (real) (i__ + j); r__2 = -1.f / (real) (i__ + j); q__1.r = r__1, q__1.i = r__2; af[i__1].r = q__1.r, af[i__1].i = q__1.i; /* L10: */ } i__1 = j - 1; b[i__1].r = 0.f, b[i__1].i = 0.f; r1[j - 1] = 0.f; r2[j - 1] = 0.f; i__1 = j - 1; w[i__1].r = 0.f, w[i__1].i = 0.f; i__1 = j - 1; x[i__1].r = 0.f, x[i__1].i = 0.f; ip[j - 1] = j; /* L20: */ } infoc_1.ok = TRUE_; /* Test error exits of the routines that use the LU decomposition */ /* of a general matrix. */ if (lsamen_(&c__2, c2, "GE")) { /* CGETRF */ s_copy(srnamc_1.srnamt, "CGETRF", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgetrf_(&c_n1, &c__0, a, &c__1, ip, &info); chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgetrf_(&c__0, &c_n1, a, &c__1, ip, &info); chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgetrf_(&c__2, &c__1, a, &c__1, ip, &info); chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGETF2 */ s_copy(srnamc_1.srnamt, "CGETF2", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgetf2_(&c_n1, &c__0, a, &c__1, ip, &info); chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgetf2_(&c__0, &c_n1, a, &c__1, ip, &info); chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgetf2_(&c__2, &c__1, a, &c__1, ip, &info); chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGETRI */ s_copy(srnamc_1.srnamt, "CGETRI", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info); chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgetri_(&c__2, a, &c__1, ip, w, &c__2, &info); chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; cgetri_(&c__2, a, &c__2, ip, w, &c__1, &info); chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGETRS */ s_copy(srnamc_1.srnamt, "CGETRS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info); chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info); chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info); chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; cgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info); chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; cgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info); chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGERFS */ s_copy(srnamc_1.srnamt, "CGERFS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, & c__1, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, & c__1, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, & c__1, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; cgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, & c__2, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, & c__2, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, & c__2, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 12; cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, & c__1, r1, r2, w, r__, &info); chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGECON */ s_copy(srnamc_1.srnamt, "CGECON", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info) ; chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info) ; chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info) ; chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGEEQU */ s_copy(srnamc_1.srnamt, "CGEEQU", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* Test error exits of the routines that use the LU decomposition */ /* of a general band matrix. */ } else if (lsamen_(&c__2, c2, "GB")) { /* CGBTRF */ s_copy(srnamc_1.srnamt, "CGBTRF", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info); chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info); chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info); chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info); chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; cgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info); chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGBTF2 */ s_copy(srnamc_1.srnamt, "CGBTF2", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info); chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info); chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info); chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info); chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; cgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info); chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGBTRS */ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; cgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; cgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; cgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, & info); chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGBRFS */ s_copy(srnamc_1.srnamt, "CGBRFS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, & c__1, x, &c__1, r1, r2, w, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 12; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 14; cgbrfs_("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, r__, &info); chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGBCON */ s_copy(srnamc_1.srnamt, "CGBCON", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__, &info); chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__, &info); chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__, &info); chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__, &info); chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; cgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__, &info); chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGBEQU */ s_copy(srnamc_1.srnamt, "CGBEQU", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; cgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond, &anrm, &info); chkxer_("CGBEQU", &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 CERRGE */ } /* cerrge_ */