/* Subroutine */ int cdrvpt_(logical *dotype, integer *nn, integer *nval, integer *nrhs, real *thresh, logical *tsterr, complex *a, real *d__, complex *e, complex *b, complex *x, complex *xact, complex *work, real *rwork, integer *nout) { /* Initialized data */ static integer iseedy[4] = { 0,0,0,1 }; /* Format strings */ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002" ", test \002,i2,\002, ratio = \002,g12.5)"; static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5" ",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)"; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; real r__1, r__2; /* Local variables */ integer i__, j, k, n; real z__[3]; integer k1, ia, in, kl, ku, ix, nt, lda; char fact[1]; real cond; integer mode; real dmax__; integer imat, info; char path[3], dist[1], type__[1]; integer nrun, ifact; integer nfail, iseed[4]; real rcond; integer nimat; real anorm; integer izero, nerrs; logical zerot; real rcondc; real ainvnm; real result[6]; /* Fortran I/O blocks */ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___38 = { 0, 0, 0, fmt_9998, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CDRVPT tests CPTSV 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 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 (NMAX*2) */ /* D (workspace) REAL array, dimension (NMAX*2) */ /* E (workspace) COMPLEX array, dimension (NMAX*2) */ /* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */ /* WORK (workspace) COMPLEX array, dimension */ /* (NMAX*max(3,NRHS)) */ /* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */ /* 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 */ --rwork; --work; --xact; --x; --b; --e; --d__; --a; --nval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "PT", (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; i__1 = *nn; for (in = 1; in <= i__1; ++in) { /* Do for each value of N in NVAL. */ n = nval[in]; lda = max(1,n); nimat = 12; if (n <= 0) { nimat = 1; } i__2 = nimat; for (imat = 1; imat <= i__2; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (n > 0 && ! dotype[imat]) { goto L110; } /* Set up parameters with CLATB4. */ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, & cond, dist); zerot = imat >= 8 && imat <= 10; if (imat <= 6) { /* Type 1-6: generate a symmetric tridiagonal matrix of */ /* known condition number in lower triangular band storage. */ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6); clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond, &anorm, &kl, &ku, "B", &a[1], &c__2, &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 L110; } izero = 0; /* Copy the matrix to D and E. */ ia = 1; i__3 = n - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; i__5 = ia; d__[i__4] = a[i__5].r; i__4 = i__; i__5 = ia + 1; e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i; ia += 2; /* L20: */ } if (n > 0) { i__3 = n; i__4 = ia; d__[i__3] = a[i__4].r; } } else { /* Type 7-12: generate a diagonally dominant matrix with */ /* unknown condition number in the vectors D and E. */ if (! zerot || ! dotype[7]) { /* Let D and E have values from [-1,1]. */ slarnv_(&c__2, iseed, &n, &d__[1]); i__3 = n - 1; clarnv_(&c__2, iseed, &i__3, &e[1]); /* Make the tridiagonal matrix diagonally dominant. */ if (n == 1) { d__[1] = dabs(d__[1]); } else { d__[1] = dabs(d__[1]) + c_abs(&e[1]); d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1] ); i__3 = n - 1; for (i__ = 2; i__ <= i__3; ++i__) { d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(& e[i__]) + c_abs(&e[i__ - 1]); /* L30: */ } } /* Scale D and E so the maximum element is ANORM. */ ix = isamax_(&n, &d__[1], &c__1); dmax__ = d__[ix]; r__1 = anorm / dmax__; sscal_(&n, &r__1, &d__[1], &c__1); if (n > 1) { i__3 = n - 1; r__1 = anorm / dmax__; csscal_(&i__3, &r__1, &e[1], &c__1); } } else if (izero > 0) { /* Reuse the last matrix by copying back the zeroed out */ /* elements. */ if (izero == 1) { d__[1] = z__[1]; if (n > 1) { e[1].r = z__[2], e[1].i = 0.f; } } else if (izero == n) { i__3 = n - 1; e[i__3].r = z__[0], e[i__3].i = 0.f; d__[n] = z__[1]; } else { i__3 = izero - 1; e[i__3].r = z__[0], e[i__3].i = 0.f; d__[izero] = z__[1]; i__3 = izero; e[i__3].r = z__[2], e[i__3].i = 0.f; } } /* For types 8-10, set one row and column of the matrix to */ /* zero. */ izero = 0; if (imat == 8) { izero = 1; z__[1] = d__[1]; d__[1] = 0.f; if (n > 1) { z__[2] = e[1].r; e[1].r = 0.f, e[1].i = 0.f; } } else if (imat == 9) { izero = n; if (n > 1) { i__3 = n - 1; z__[0] = e[i__3].r; i__3 = n - 1; e[i__3].r = 0.f, e[i__3].i = 0.f; } z__[1] = d__[n]; d__[n] = 0.f; } else if (imat == 10) { izero = (n + 1) / 2; if (izero > 1) { i__3 = izero - 1; z__[0] = e[i__3].r; i__3 = izero - 1; e[i__3].r = 0.f, e[i__3].i = 0.f; i__3 = izero; z__[2] = e[i__3].r; i__3 = izero; e[i__3].r = 0.f, e[i__3].i = 0.f; } z__[1] = d__[izero]; d__[izero] = 0.f; } } /* Generate NRHS random solution vectors. */ ix = 1; i__3 = *nrhs; for (j = 1; j <= i__3; ++j) { clarnv_(&c__2, iseed, &n, &xact[ix]); ix += lda; /* L40: */ } /* Set the right hand side. */ claptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda, &c_b25, &b[1], &lda); for (ifact = 1; ifact <= 2; ++ifact) { if (ifact == 1) { *(unsigned char *)fact = 'F'; } else { *(unsigned char *)fact = 'N'; } /* Compute the condition number for comparison with */ /* the value returned by CPTSVX. */ if (zerot) { if (ifact == 1) { goto L100; } rcondc = 0.f; } else if (ifact == 1) { /* Compute the 1-norm of A. */ anorm = clanht_("1", &n, &d__[1], &e[1]); scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1); if (n > 1) { i__3 = n - 1; ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1); } /* Factor the matrix A. */ cpttrf_(&n, &d__[n + 1], &e[n + 1], &info); /* Use CPTTRS to solve for one column at a time of */ /* inv(A), computing the maximum column sum as we go. */ ainvnm = 0.f; i__3 = n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = n; for (j = 1; j <= i__4; ++j) { i__5 = j; x[i__5].r = 0.f, x[i__5].i = 0.f; /* L50: */ } i__4 = i__; x[i__4].r = 1.f, x[i__4].i = 0.f; cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], & x[1], &lda, &info); /* Computing MAX */ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1); ainvnm = dmax(r__1,r__2); /* L60: */ } /* Compute the 1-norm condition number of A. */ if (anorm <= 0.f || ainvnm <= 0.f) { rcondc = 1.f; } else { rcondc = 1.f / anorm / ainvnm; } } if (ifact == 2) { /* --- Test CPTSV -- */ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1); if (n > 1) { i__3 = n - 1; ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1); } clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda); /* Factor A as L*D*L' and solve the system A*X = B. */ s_copy(srnamc_1.srnamt, "CPTSV ", (ftnlen)32, (ftnlen)6); cptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, & info); /* Check error code from CPTSV . */ if (info != izero) { alaerh_(path, "CPTSV ", &info, &izero, " ", &n, &n, & c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout); } nt = 0; if (izero == 0) { /* Check the factorization by computing the ratio */ /* norm(L*D*L' - A) / (n * norm(A) * EPS ) */ cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], & work[1], result); /* Compute the residual in the solution. */ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda); cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], & lda, &work[1], &lda, &result[1]); /* Check solution from generated exact solution. */ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, & rcondc, &result[2]); nt = 3; } /* Print information about the tests that did not pass */ /* the threshold. */ i__3 = nt; for (k = 1; k <= i__3; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } io___35.ciunit = *nout; s_wsfe(&io___35); do_fio(&c__1, "CPTSV ", (ftnlen)6); do_fio(&c__1, (char *)&n, (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; } /* L70: */ } nrun += nt; } /* --- Test CPTSVX --- */ if (ifact > 1) { /* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */ i__3 = n - 1; for (i__ = 1; i__ <= i__3; ++i__) { d__[n + i__] = 0.f; i__4 = n + i__; e[i__4].r = 0.f, e[i__4].i = 0.f; /* L80: */ } if (n > 0) { d__[n + n] = 0.f; } } claset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda); /* Solve the system and compute the condition number and */ /* error bounds using CPTSVX. */ s_copy(srnamc_1.srnamt, "CPTSVX", (ftnlen)32, (ftnlen)6); cptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1] , &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[ *nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info); /* Check the error code from CPTSVX. */ if (info != izero) { alaerh_(path, "CPTSVX", &info, &izero, fact, &n, &n, & c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout); } if (izero == 0) { if (ifact == 2) { /* Check the factorization by computing the ratio */ /* norm(L*D*L' - A) / (n * norm(A) * EPS ) */ k1 = 1; cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], & work[1], result); } else { k1 = 2; } /* Compute the residual in the solution. */ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda); cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, & work[1], &lda, &result[1]); /* Check solution from generated exact solution. */ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, & result[2]); /* Check error bounds from iterative refinement. */ cptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], & lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1], &result[3]); } else { k1 = 6; } /* Check the reciprocal of the condition number. */ result[5] = sget06_(&rcond, &rcondc); /* Print information about the tests that did not pass */ /* the threshold. */ for (k = k1; k <= 6; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } io___38.ciunit = *nout; s_wsfe(&io___38); do_fio(&c__1, "CPTSVX", (ftnlen)6); do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, (char *)&n, (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; } /* L90: */ } nrun = nrun + 7 - k1; L100: ; } L110: ; } /* L120: */ } /* Print a summary of the results. */ alasvm_(path, nout, &nfail, &nrun, &nerrs); return 0; /* End of CDRVPT */ } /* cdrvpt_ */
/* Subroutine */ int cptsv_(integer *n, integer *nrhs, real *d__, complex *e, complex *b, integer *ldb, integer *info) { /* System generated locals */ integer b_dim1, b_offset, i__1; /* Local variables */ extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), cpttrf_( integer *, real *, complex *, integer *), cpttrs_(char *, integer *, integer *, real *, complex *, complex *, integer *, integer *, ftnlen); /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* February 25, 1997 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPTSV computes the solution to a complex system of linear equations */ /* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal */ /* matrix, and X and B are N-by-NRHS matrices. */ /* A is factored as A = L*D*L**H, and the factored form of A is then */ /* used to solve the system of equations. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrix B. NRHS >= 0. */ /* D (input/output) REAL array, dimension (N) */ /* On entry, the n diagonal elements of the tridiagonal matrix */ /* A. On exit, the n diagonal elements of the diagonal matrix */ /* D from the factorization A = L*D*L**H. */ /* E (input/output) COMPLEX array, dimension (N-1) */ /* On entry, the (n-1) subdiagonal elements of the tridiagonal */ /* matrix A. On exit, the (n-1) subdiagonal elements of the */ /* unit bidiagonal factor L from the L*D*L**H factorization of */ /* A. E can also be regarded as the superdiagonal of the unit */ /* bidiagonal factor U from the U**H*D*U factorization of A. */ /* 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, the leading minor of order i is not */ /* positive definite, and the solution has not been */ /* computed. The factorization has not been completed */ /* unless i = N. */ /* ===================================================================== */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --d__; --e; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*nrhs < 0) { *info = -2; } else if (*ldb < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("CPTSV ", &i__1, (ftnlen)6); return 0; } /* Compute the L*D*L' (or U'*D*U) factorization of A. */ cpttrf_(n, &d__[1], &e[1], info); if (*info == 0) { /* Solve the system A*X = B, overwriting B with X. */ cpttrs_("Lower", n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info, ( ftnlen)5); } return 0; /* End of CPTSV */ } /* cptsv_ */
/* Subroutine */ int cchkpt_(logical *dotype, integer *nn, integer *nval, integer *nns, integer *nsval, real *thresh, logical *tsterr, complex * a, real *d__, complex *e, complex *b, complex *x, complex *xact, complex *work, real *rwork, integer *nout) { /* Initialized data */ static integer iseedy[4] = { 0,0,0,1 }; static char uplos[1*2] = "U" "L"; /* Format strings */ static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te" "st \002,i2,\002, ratio = \002,g12.5)"; static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, " "NRHS =\002,i3,\002, type \002,i2,\002, test \002,i2,\002, ratio " "= \002,g12.5)"; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; real r__1, r__2; /* Local variables */ integer i__, j, k, n; complex z__[3]; integer ia, in, kl, ku, ix, lda; real cond; integer mode; real dmax__; integer imat, info; char path[3], dist[1]; integer irhs, nrhs; char uplo[1], type__[1]; integer nrun; integer nfail, iseed[4]; real rcond; integer nimat; real anorm; integer iuplo, izero, nerrs; logical zerot; real rcondc; real ainvnm; real result[7]; /* Fortran I/O blocks */ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___38 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___40 = { 0, 0, 0, fmt_9999, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CCHKPT tests CPTTRF, -TRS, -RFS, and -CON */ /* 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 dimension N. */ /* NNS (input) INTEGER */ /* The number of values of NRHS contained in the vector NSVAL. */ /* NSVAL (input) INTEGER array, dimension (NNS) */ /* The values of the number of right hand sides NRHS. */ /* 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 (NMAX*2) */ /* D (workspace) REAL array, dimension (NMAX*2) */ /* E (workspace) COMPLEX array, dimension (NMAX*2) */ /* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */ /* where NSMAX is the largest entry in NSVAL. */ /* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */ /* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */ /* WORK (workspace) COMPLEX array, dimension */ /* (NMAX*max(3,NSMAX)) */ /* RWORK (workspace) REAL array, dimension */ /* (max(NMAX,2*NSMAX)) */ /* 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 */ --rwork; --work; --xact; --x; --b; --e; --d__; --a; --nsval; --nval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "PT", (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) { cerrgt_(path, nout); } infoc_1.infot = 0; i__1 = *nn; for (in = 1; in <= i__1; ++in) { /* Do for each value of N in NVAL. */ n = nval[in]; lda = max(1,n); nimat = 12; if (n <= 0) { nimat = 1; } i__2 = nimat; for (imat = 1; imat <= i__2; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (n > 0 && ! dotype[imat]) { goto L110; } /* Set up parameters with CLATB4. */ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, & cond, dist); zerot = imat >= 8 && imat <= 10; if (imat <= 6) { /* Type 1-6: generate a Hermitian tridiagonal matrix of */ /* known condition number in lower triangular band storage. */ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6); clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond, &anorm, &kl, &ku, "B", &a[1], &c__2, &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 L110; } izero = 0; /* Copy the matrix to D and E. */ ia = 1; i__3 = n - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = ia; d__[i__] = a[i__4].r; i__4 = i__; i__5 = ia + 1; e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i; ia += 2; /* L20: */ } if (n > 0) { i__3 = ia; d__[n] = a[i__3].r; } } else { /* Type 7-12: generate a diagonally dominant matrix with */ /* unknown condition number in the vectors D and E. */ if (! zerot || ! dotype[7]) { /* Let E be complex, D real, with values from [-1,1]. */ slarnv_(&c__2, iseed, &n, &d__[1]); i__3 = n - 1; clarnv_(&c__2, iseed, &i__3, &e[1]); /* Make the tridiagonal matrix diagonally dominant. */ if (n == 1) { d__[1] = dabs(d__[1]); } else { d__[1] = dabs(d__[1]) + c_abs(&e[1]); d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1] ); i__3 = n - 1; for (i__ = 2; i__ <= i__3; ++i__) { d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(& e[i__]) + c_abs(&e[i__ - 1]); /* L30: */ } } /* Scale D and E so the maximum element is ANORM. */ ix = isamax_(&n, &d__[1], &c__1); dmax__ = d__[ix]; r__1 = anorm / dmax__; sscal_(&n, &r__1, &d__[1], &c__1); i__3 = n - 1; r__1 = anorm / dmax__; csscal_(&i__3, &r__1, &e[1], &c__1); } else if (izero > 0) { /* Reuse the last matrix by copying back the zeroed out */ /* elements. */ if (izero == 1) { d__[1] = z__[1].r; if (n > 1) { e[1].r = z__[2].r, e[1].i = z__[2].i; } } else if (izero == n) { i__3 = n - 1; e[i__3].r = z__[0].r, e[i__3].i = z__[0].i; i__3 = n; d__[i__3] = z__[1].r; } else { i__3 = izero - 1; e[i__3].r = z__[0].r, e[i__3].i = z__[0].i; i__3 = izero; d__[i__3] = z__[1].r; i__3 = izero; e[i__3].r = z__[2].r, e[i__3].i = z__[2].i; } } /* For types 8-10, set one row and column of the matrix to */ /* zero. */ izero = 0; if (imat == 8) { izero = 1; z__[1].r = d__[1], z__[1].i = 0.f; d__[1] = 0.f; if (n > 1) { z__[2].r = e[1].r, z__[2].i = e[1].i; e[1].r = 0.f, e[1].i = 0.f; } } else if (imat == 9) { izero = n; if (n > 1) { i__3 = n - 1; z__[0].r = e[i__3].r, z__[0].i = e[i__3].i; i__3 = n - 1; e[i__3].r = 0.f, e[i__3].i = 0.f; } i__3 = n; z__[1].r = d__[i__3], z__[1].i = 0.f; d__[n] = 0.f; } else if (imat == 10) { izero = (n + 1) / 2; if (izero > 1) { i__3 = izero - 1; z__[0].r = e[i__3].r, z__[0].i = e[i__3].i; i__3 = izero; z__[2].r = e[i__3].r, z__[2].i = e[i__3].i; i__3 = izero - 1; e[i__3].r = 0.f, e[i__3].i = 0.f; i__3 = izero; e[i__3].r = 0.f, e[i__3].i = 0.f; } i__3 = izero; z__[1].r = d__[i__3], z__[1].i = 0.f; d__[izero] = 0.f; } } scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1); if (n > 1) { i__3 = n - 1; ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1); } /* + TEST 1 */ /* Factor A as L*D*L' and compute the ratio */ /* norm(L*D*L' - A) / (n * norm(A) * EPS ) */ cpttrf_(&n, &d__[n + 1], &e[n + 1], &info); /* Check error code from CPTTRF. */ if (info != izero) { alaerh_(path, "CPTTRF", &info, &izero, " ", &n, &n, &c_n1, & c_n1, &c_n1, &imat, &nfail, &nerrs, nout); goto L110; } if (info > 0) { rcondc = 0.f; goto L100; } cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1], result); /* Print the test ratio if greater than or equal to THRESH. */ if (result[0] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___30.ciunit = *nout; s_wsfe(&io___30); do_fio(&c__1, (char *)&n, (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; /* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */ /* Compute norm(A). */ anorm = clanht_("1", &n, &d__[1], &e[1]); /* Use CPTTRS to solve for one column at a time of inv(A), */ /* computing the maximum column sum as we go. */ ainvnm = 0.f; i__3 = n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = n; for (j = 1; j <= i__4; ++j) { i__5 = j; x[i__5].r = 0.f, x[i__5].i = 0.f; /* L40: */ } i__4 = i__; x[i__4].r = 1.f, x[i__4].i = 0.f; cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], & lda, &info); /* Computing MAX */ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1); ainvnm = dmax(r__1,r__2); /* L50: */ } /* Computing MAX */ r__1 = 1.f, r__2 = anorm * ainvnm; rcondc = 1.f / dmax(r__1,r__2); i__3 = *nns; for (irhs = 1; irhs <= i__3; ++irhs) { nrhs = nsval[irhs]; /* Generate NRHS random solution vectors. */ ix = 1; i__4 = nrhs; for (j = 1; j <= i__4; ++j) { clarnv_(&c__2, iseed, &n, &xact[ix]); ix += lda; /* L60: */ } for (iuplo = 1; iuplo <= 2; ++iuplo) { /* Do first for UPLO = 'U', then for UPLO = 'L'. */ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1]; /* Set the right hand side. */ claptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1], &lda, &c_b49, &b[1], &lda); /* + TEST 2 */ /* Solve A*x = b and compute the residual. */ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda); cpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], & lda, &info); /* Check error code from CPTTRS. */ if (info != 0) { alaerh_(path, "CPTTRS", &info, &c__0, uplo, &n, &n, & c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs, nout); } clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda); cptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, & work[1], &lda, &result[1]); /* + TEST 3 */ /* Check solution from generated exact solution. */ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, & result[2]); /* + TESTS 4, 5, and 6 */ /* Use iterative refinement to improve the solution. */ s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6); cptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[ n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], & rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1] , &info); /* Check error code from CPTRFS. */ if (info != 0) { alaerh_(path, "CPTRFS", &info, &c__0, uplo, &n, &n, & c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs, nout); } cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, & result[3]); cptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], & lda, &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &result[4]); /* Print information about the tests that did not pass the */ /* threshold. */ for (k = 2; k <= 6; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___38.ciunit = *nout; s_wsfe(&io___38); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&nrhs, (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; } /* L70: */ } nrun += 5; /* L80: */ } /* L90: */ } /* + TEST 7 */ /* Estimate the reciprocal of the condition number of the */ /* matrix. */ L100: s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6); cptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], & info); /* Check error code from CPTCON. */ if (info != 0) { alaerh_(path, "CPTCON", &info, &c__0, " ", &n, &n, &c_n1, & c_n1, &c_n1, &imat, &nfail, &nerrs, nout); } result[6] = sget06_(&rcond, &rcondc); /* Print the test ratio if greater than or equal to THRESH. */ if (result[6] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___40.ciunit = *nout; s_wsfe(&io___40); do_fio(&c__1, (char *)&n, (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; L110: ; } /* L120: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &nerrs); return 0; /* End of CCHKPT */ } /* cchkpt_ */
/* Subroutine */ int cerrgt_(char *path, integer *nunit) { /* System generated locals */ integer i__1; real r__1; /* Builtin functions */ integer s_wsle(cilist *), e_wsle(void); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ complex b[2]; real d__[2]; complex e[2]; integer i__; complex w[2], x[2]; char c2[2]; real r1[2], r2[2], df[2]; complex ef[2], dl[2]; integer ip[2]; complex du[2]; real rw[2]; complex du2[2], dlf[2], duf[2]; integer info; real rcond, anorm; extern /* Subroutine */ int alaesm_(char *, logical *, integer *), cgtcon_(char *, integer *, complex *, complex *, complex *, complex *, integer *, real *, real *, complex *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical *, logical *), cptcon_(integer *, real *, complex *, real *, real *, real *, integer *), cgtrfs_(char *, integer *, integer *, complex *, complex *, complex *, complex *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, real *, integer *), cgttrf_( integer *, complex *, complex *, complex *, complex *, integer *, integer *), cptrfs_(char *, integer *, integer *, real *, complex *, real *, complex *, complex *, integer *, complex *, integer *, real *, real *, complex *, real *, integer *), cpttrf_( integer *, real *, complex *, integer *), cgttrs_(char *, integer *, integer *, complex *, complex *, complex *, complex *, integer *, complex *, integer *, integer *), cpttrs_(char *, integer *, integer *, real *, complex *, complex *, integer *, integer *); /* Fortran I/O blocks */ static cilist io___1 = { 0, 0, 0, 0, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CERRGT tests the error exits for the COMPLEX tridiagonal */ /* routines. */ /* 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 .. */ /* .. */ /* .. 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); for (i__ = 1; i__ <= 2; ++i__) { d__[i__ - 1] = 1.f; i__1 = i__ - 1; e[i__1].r = 2.f, e[i__1].i = 0.f; i__1 = i__ - 1; dl[i__1].r = 3.f, dl[i__1].i = 0.f; i__1 = i__ - 1; du[i__1].r = 4.f, du[i__1].i = 0.f; /* L10: */ } anorm = 1.f; infoc_1.ok = TRUE_; if (lsamen_(&c__2, c2, "GT")) { /* Test error exits for the general tridiagonal routines. */ /* CGTTRF */ s_copy(srnamc_1.srnamt, "CGTTRF", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgttrf_(&c_n1, dl, e, du, du2, ip, &info); chkxer_("CGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGTTRS */ s_copy(srnamc_1.srnamt, "CGTTRS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgttrs_("/", &c__0, &c__0, dl, e, du, du2, ip, x, &c__1, &info); chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgttrs_("N", &c_n1, &c__0, dl, e, du, du2, ip, x, &c__1, &info); chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgttrs_("N", &c__0, &c_n1, dl, e, du, du2, ip, x, &c__1, &info); chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; cgttrs_("N", &c__2, &c__1, dl, e, du, du2, ip, x, &c__1, &info); chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGTRFS */ s_copy(srnamc_1.srnamt, "CGTRFS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgtrfs_("/", &c__0, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1, x, &c__1, r1, r2, w, rw, &info); chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgtrfs_("N", &c_n1, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1, x, &c__1, r1, r2, w, rw, &info); chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cgtrfs_("N", &c__0, &c_n1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1, x, &c__1, r1, r2, w, rw, &info); chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; cgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1, x, &c__2, r1, r2, w, rw, &info); chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 15; cgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__2, x, &c__1, r1, r2, w, rw, &info); chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGTCON */ s_copy(srnamc_1.srnamt, "CGTCON", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgtcon_("/", &c__0, dl, e, du, du2, ip, &anorm, &rcond, w, &info); chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgtcon_("I", &c_n1, dl, e, du, du2, ip, &anorm, &rcond, w, &info); chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; r__1 = -anorm; cgtcon_("I", &c__0, dl, e, du, du2, ip, &r__1, &rcond, w, &info); chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); } else if (lsamen_(&c__2, c2, "PT")) { /* Test error exits for the positive definite tridiagonal */ /* routines. */ /* CPTTRF */ s_copy(srnamc_1.srnamt, "CPTTRF", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cpttrf_(&c_n1, d__, e, &info); chkxer_("CPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CPTTRS */ s_copy(srnamc_1.srnamt, "CPTTRS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cpttrs_("/", &c__1, &c__0, d__, e, x, &c__1, &info); chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cpttrs_("U", &c_n1, &c__0, d__, e, x, &c__1, &info); chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cpttrs_("U", &c__0, &c_n1, d__, e, x, &c__1, &info); chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; cpttrs_("U", &c__2, &c__1, d__, e, x, &c__1, &info); chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CPTRFS */ s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cptrfs_("/", &c__1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, rw, &info); chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cptrfs_("U", &c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, rw, &info); chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; cptrfs_("U", &c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, rw, &info); chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; cptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2, w, rw, &info); chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; cptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2, w, rw, &info); chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CPTCON */ s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cptcon_(&c_n1, d__, e, &anorm, &rcond, rw, &info); chkxer_("CPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; r__1 = -anorm; cptcon_(&c__0, d__, e, &r__1, &rcond, rw, &info); chkxer_("CPTCON", &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 CERRGT */ } /* cerrgt_ */