int zggglm_(int *n, int *m, int *p, doublecomplex *a, int *lda, doublecomplex *b, int *ldb, doublecomplex *d__, doublecomplex *x, doublecomplex *y, doublecomplex *work, int *lwork, int *info) { /* System generated locals */ int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; doublecomplex z__1; /* Local variables */ int i__, nb, np, nb1, nb2, nb3, nb4, lopt; extern int zgemv_(char *, int *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *), zcopy_(int *, doublecomplex *, int *, doublecomplex *, int *), xerbla_(char *, int *); extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); extern int zggqrf_(int *, int *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, int *) ; int lwkmin, lwkopt; int lquery; extern int zunmqr_(char *, char *, int *, int *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, int *), zunmrq_(char *, char *, int *, int *, int *, doublecomplex *, int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *, int *), ztrtrs_(char *, char *, char *, int *, int *, doublecomplex *, int *, doublecomplex *, int *, int *); /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGGGLM solves a general Gauss-Markov linear model (GLM) problem: */ /* minimize || y ||_2 subject to d = A*x + B*y */ /* x */ /* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */ /* given N-vector. It is assumed that M <= N <= M+P, and */ /* rank(A) = M and rank( A B ) = N. */ /* Under these assumptions, the constrained equation is always */ /* consistent, and there is a unique solution x and a minimal 2-norm */ /* solution y, which is obtained using a generalized QR factorization */ /* of the matrices (A, B) given by */ /* A = Q*(R), B = Q*T*Z. */ /* (0) */ /* In particular, if matrix B is square nonsingular, then the problem */ /* GLM is equivalent to the following weighted linear least squares */ /* problem */ /* minimize || inv(B)*(d-A*x) ||_2 */ /* x */ /* where inv(B) denotes the inverse of B. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of rows of the matrices A and B. N >= 0. */ /* M (input) INTEGER */ /* The number of columns of the matrix A. 0 <= M <= N. */ /* P (input) INTEGER */ /* The number of columns of the matrix B. P >= N-M. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,M) */ /* On entry, the N-by-M matrix A. */ /* On exit, the upper triangular part of the array A contains */ /* the M-by-M upper triangular matrix R. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(1,N). */ /* B (input/output) COMPLEX*16 array, dimension (LDB,P) */ /* On entry, the N-by-P matrix B. */ /* On exit, if N <= P, the upper triangle of the subarray */ /* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ /* if N > P, the elements on and above the (N-P)th subdiagonal */ /* contain the N-by-P upper trapezoidal matrix T. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= MAX(1,N). */ /* D (input/output) COMPLEX*16 array, dimension (N) */ /* On entry, D is the left hand side of the GLM equation. */ /* On exit, D is destroyed. */ /* X (output) COMPLEX*16 array, dimension (M) */ /* Y (output) COMPLEX*16 array, dimension (P) */ /* On exit, X and Y are the solutions of the GLM problem. */ /* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= MAX(1,N+M+P). */ /* For optimum performance, LWORK >= M+MIN(N,P)+MAX(N,P)*NB, */ /* where NB is an upper bound for the optimal blocksizes for */ /* ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* = 1: the upper triangular factor R associated with A in the */ /* generalized QR factorization of the pair (A, B) is */ /* singular, so that rank(A) < M; the least squares */ /* solution could not be computed. */ /* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */ /* factor T associated with B in the generalized QR */ /* factorization of the pair (A, B) is singular, so that */ /* rank( A B ) < N; the least squares solution could not */ /* be computed. */ /* =================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --d__; --x; --y; --work; /* Function Body */ *info = 0; np = MIN(*n,*p); lquery = *lwork == -1; if (*n < 0) { *info = -1; } else if (*m < 0 || *m > *n) { *info = -2; } else if (*p < 0 || *p < *n - *m) { *info = -3; } else if (*lda < MAX(1,*n)) { *info = -5; } else if (*ldb < MAX(1,*n)) { *info = -7; } /* Calculate workspace */ if (*info == 0) { if (*n == 0) { lwkmin = 1; lwkopt = 1; } else { nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, m, &c_n1, &c_n1); nb2 = ilaenv_(&c__1, "ZGERQF", " ", n, m, &c_n1, &c_n1); nb3 = ilaenv_(&c__1, "ZUNMQR", " ", n, m, p, &c_n1); nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", n, m, p, &c_n1); /* Computing MAX */ i__1 = MAX(nb1,nb2), i__1 = MAX(i__1,nb3); nb = MAX(i__1,nb4); lwkmin = *m + *n + *p; lwkopt = *m + np + MAX(*n,*p) * nb; } work[1].r = (double) lwkopt, work[1].i = 0.; if (*lwork < lwkmin && ! lquery) { *info = -12; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZGGGLM", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Compute the GQR factorization of matrices A and B: */ /* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */ /* ( 0 ) N-M ( 0 T22 ) N-M */ /* M M+P-N N-M */ /* where R11 and T22 are upper triangular, and Q and Z are */ /* unitary. */ i__1 = *lwork - *m - np; zggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m + 1], &work[*m + np + 1], &i__1, info); i__1 = *m + np + 1; lopt = (int) work[i__1].r; /* Update left-hand-side vector d = Q'*d = ( d1 ) M */ /* ( d2 ) N-M */ i__1 = MAX(1,*n); i__2 = *lwork - *m - np; zunmqr_("Left", "Conjugate transpose", n, &c__1, m, &a[a_offset], lda, & work[1], &d__[1], &i__1, &work[*m + np + 1], &i__2, info); /* Computing MAX */ i__3 = *m + np + 1; i__1 = lopt, i__2 = (int) work[i__3].r; lopt = MAX(i__1,i__2); /* Solve T22*y2 = d2 for y2 */ if (*n > *m) { i__1 = *n - *m; i__2 = *n - *m; ztrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1 + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2, info); if (*info > 0) { *info = 1; return 0; } i__1 = *n - *m; zcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1); } /* Set y1 = 0 */ i__1 = *m + *p - *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; y[i__2].r = 0., y[i__2].i = 0.; /* L10: */ } /* Update d1 = d1 - T12*y2 */ i__1 = *n - *m; z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", m, &i__1, &z__1, &b[(*m + *p - *n + 1) * b_dim1 + 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b2, &d__[1], &c__1); /* Solve triangular system: R11*x = d1 */ if (*m > 0) { ztrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset], lda, &d__[1], m, info); if (*info > 0) { *info = 2; return 0; } /* Copy D to X */ zcopy_(m, &d__[1], &c__1, &x[1], &c__1); } /* Backward transformation y = Z'*y */ /* Computing MAX */ i__1 = 1, i__2 = *n - *p + 1; i__3 = MAX(1,*p); i__4 = *lwork - *m - np; zunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &b[MAX(i__1, i__2)+ b_dim1], ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], & i__4, info); /* Computing MAX */ i__4 = *m + np + 1; i__2 = lopt, i__3 = (int) work[i__4].r; i__1 = *m + np + MAX(i__2,i__3); work[1].r = (double) i__1, work[1].i = 0.; return 0; /* End of ZGGGLM */ } /* zggglm_ */
/* Subroutine */ int zchktr_(logical *dotype, integer *nn, integer *nval, integer *nnb, integer *nbval, integer *nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a, doublecomplex *ainv, doublecomplex *b, doublecomplex *x, doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer * nout) { /* Initialized data */ static integer iseedy[4] = { 1988,1989,1990,1991 }; static char uplos[1*2] = "U" "L"; static char transs[1*3] = "N" "T" "C"; /* Format strings */ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'" ", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002," "i2,\002)= \002,g12.5)"; static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002" "', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type" " \002,i2,\002, test(\002,i2,\002)= \002,g12" ".5)"; static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002" "', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2" ",\002)=\002,g12.5)"; static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', " "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2," "\002, test(\002,i2,\002)=\002,g12.5)"; /* System generated locals */ address a__1[2], a__2[3], a__3[4]; integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4]; char ch__1[2], ch__2[3], ch__3[4]; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, char **, integer *, integer *, ftnlen); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ integer i__, k, n, nb, in, lda, inb; char diag[1]; integer imat, info; char path[3]; integer irhs, nrhs; char norm[1], uplo[1]; integer nrun; extern /* Subroutine */ int alahd_(integer *, char *); integer idiag; doublereal scale; integer nfail, iseed[4]; extern logical lsame_(char *, char *); doublereal rcond, anorm; integer itran; extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal * ); char trans[1]; integer iuplo, nerrs; doublereal dummy; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztrt01_(char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *), ztrt02_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *), ztrt03_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *); char xtype[1]; extern /* Subroutine */ int ztrt05_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *), ztrt06_(doublereal *, doublereal *, char *, char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *), alaerh_(char *, char *, integer *, integer *, char *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *); doublereal rcondc, rcondi; extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer *, integer *); doublereal rcondo, ainvnm; extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex * , integer *), zlarhs_(char *, char *, char *, char *, integer *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *); extern doublereal zlantr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublereal *); doublereal result[9]; extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *, integer *), zlattr_(integer *, char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublereal *, integer *), ztrcon_(char *, char *, char *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, doublereal *, integer *), zerrtr_(char *, integer *), ztrrfs_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, integer *), ztrtri_(char *, char *, integer *, doublecomplex *, integer *, integer *), ztrtrs_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); /* Fortran I/O blocks */ static cilist io___27 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___36 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___38 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___40 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___41 = { 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 */ /* ======= */ /* ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS */ /* 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. */ /* NNB (input) INTEGER */ /* The number of values of NB contained in the vector NBVAL. */ /* NBVAL (input) INTEGER array, dimension (NNB) */ /* The values of the blocksize NB. */ /* 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) DOUBLE PRECISION */ /* 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. */ /* NMAX (input) INTEGER */ /* The leading dimension of the work arrays. */ /* NMAX >= the maximum value of N in NVAL. */ /* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */ /* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */ /* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */ /* where NSMAX is the largest entry in NSVAL. */ /* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */ /* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */ /* WORK (workspace) COMPLEX*16 array, dimension */ /* (NMAX*max(3,NSMAX)) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension */ /* (max(NMAX,2*NSMAX)) */ /* NOUT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --rwork; --work; --xact; --x; --b; --ainv; --a; --nsval; --nbval; --nval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Initialize constants and the random number seed. */ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "TR", (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) { zerrtr_(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); *(unsigned char *)xtype = 'N'; for (imat = 1; imat <= 10; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat]) { goto L80; } for (iuplo = 1; iuplo <= 2; ++iuplo) { /* Do first for UPLO = 'U', then for UPLO = 'L' */ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1]; /* Call ZLATTR to generate a triangular test matrix. */ s_copy(srnamc_1.srnamt, "ZLATTR", (ftnlen)32, (ftnlen)6); zlattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], & lda, &x[1], &work[1], &rwork[1], &info); /* Set IDIAG = 1 for non-unit matrices, 2 for unit. */ if (lsame_(diag, "N")) { idiag = 1; } else { idiag = 2; } i__2 = *nnb; for (inb = 1; inb <= i__2; ++inb) { /* Do for each blocksize in NBVAL */ nb = nbval[inb]; xlaenv_(&c__1, &nb); /* + TEST 1 */ /* Form the inverse of A. */ zlacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda); s_copy(srnamc_1.srnamt, "ZTRTRI", (ftnlen)32, (ftnlen)6); ztrtri_(uplo, diag, &n, &ainv[1], &lda, &info); /* Check error code from ZTRTRI. */ if (info != 0) { /* Writing concatenation */ i__3[0] = 1, a__1[0] = uplo; i__3[1] = 1, a__1[1] = diag; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); alaerh_(path, "ZTRTRI", &info, &c__0, ch__1, &n, &n, & c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout); } /* Compute the infinity-norm condition number of A. */ anorm = zlantr_("I", uplo, diag, &n, &n, &a[1], &lda, & rwork[1]); ainvnm = zlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda, &rwork[1]); if (anorm <= 0. || ainvnm <= 0.) { rcondi = 1.; } else { rcondi = 1. / anorm / ainvnm; } /* Compute the residual for the triangular matrix times */ /* its inverse. Also compute the 1-norm condition number */ /* of A. */ ztrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, & rcondo, &rwork[1], result); /* Print the test ratio if it is .GE. THRESH. */ if (result[0] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___27.ciunit = *nout; s_wsfe(&io___27); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nb, (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( doublereal)); e_wsfe(); ++nfail; } ++nrun; /* Skip remaining tests if not the first block size. */ if (inb != 1) { goto L60; } i__4 = *nns; for (irhs = 1; irhs <= i__4; ++irhs) { nrhs = nsval[irhs]; *(unsigned char *)xtype = 'N'; for (itran = 1; itran <= 3; ++itran) { /* Do for op(A) = A, A**T, or A**H. */ *(unsigned char *)trans = *(unsigned char *)& transs[itran - 1]; if (itran == 1) { *(unsigned char *)norm = 'O'; rcondc = rcondo; } else { *(unsigned char *)norm = 'I'; rcondc = rcondi; } /* + TEST 2 */ /* Solve and compute residual for op(A)*x = b. */ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, ( ftnlen)6); zlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, & idiag, &nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &info); *(unsigned char *)xtype = 'C'; zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], & lda); s_copy(srnamc_1.srnamt, "ZTRTRS", (ftnlen)32, ( ftnlen)6); ztrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda, &x[1], &lda, &info); /* Check error code from ZTRTRS. */ if (info != 0) { /* Writing concatenation */ i__5[0] = 1, a__2[0] = uplo; i__5[1] = 1, a__2[1] = trans; i__5[2] = 1, a__2[2] = diag; s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3); alaerh_(path, "ZTRTRS", &info, &c__0, ch__2, & n, &n, &c_n1, &c_n1, &nrhs, &imat, & nfail, &nerrs, nout); } /* This line is needed on a Sun SPARCstation. */ if (n > 0) { dummy = a[1].r; } ztrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda, &x[1], &lda, &b[1], &lda, &work[1], & rwork[1], &result[1]); /* + TEST 3 */ /* Check solution from generated exact solution. */ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, & rcondc, &result[2]); /* + TESTS 4, 5, and 6 */ /* Use iterative refinement to improve the solution */ /* and compute error bounds. */ s_copy(srnamc_1.srnamt, "ZTRRFS", (ftnlen)32, ( ftnlen)6); ztrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[1], &lda, &rwork[1], & rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1], &info); /* Check error code from ZTRRFS. */ if (info != 0) { /* Writing concatenation */ i__5[0] = 1, a__2[0] = uplo; i__5[1] = 1, a__2[1] = trans; i__5[2] = 1, a__2[2] = diag; s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3); alaerh_(path, "ZTRRFS", &info, &c__0, ch__2, & n, &n, &c_n1, &c_n1, &nrhs, &imat, & nfail, &nerrs, nout); } zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, & rcondc, &result[3]); ztrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda, &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___36.ciunit = *nout; s_wsfe(&io___36); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, diag, (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(doublereal)); e_wsfe(); ++nfail; } /* L20: */ } nrun += 5; /* L30: */ } /* L40: */ } /* + TEST 7 */ /* Get an estimate of RCOND = 1/CNDNUM. */ for (itran = 1; itran <= 2; ++itran) { if (itran == 1) { *(unsigned char *)norm = 'O'; rcondc = rcondo; } else { *(unsigned char *)norm = 'I'; rcondc = rcondi; } s_copy(srnamc_1.srnamt, "ZTRCON", (ftnlen)32, (ftnlen) 6); ztrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, & work[1], &rwork[1], &info); /* Check error code from ZTRCON. */ if (info != 0) { /* Writing concatenation */ i__5[0] = 1, a__2[0] = norm; i__5[1] = 1, a__2[1] = uplo; i__5[2] = 1, a__2[2] = diag; s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3); alaerh_(path, "ZTRCON", &info, &c__0, ch__2, &n, & n, &c_n1, &c_n1, &c_n1, &imat, &nfail, & nerrs, nout); } ztrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda, &rwork[1], &result[6]); /* Print the test ratio if it is .GE. THRESH. */ if (result[6] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___38.ciunit = *nout; s_wsfe(&io___38); do_fio(&c__1, norm, (ftnlen)1); do_fio(&c__1, uplo, (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 *)&c__7, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof( doublereal)); e_wsfe(); ++nfail; } ++nrun; /* L50: */ } L60: ; } /* L70: */ } L80: ; } /* Use pathological test matrices to test ZLATRS. */ for (imat = 11; imat <= 18; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat]) { goto L110; } for (iuplo = 1; iuplo <= 2; ++iuplo) { /* Do first for UPLO = 'U', then for UPLO = 'L' */ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1]; for (itran = 1; itran <= 3; ++itran) { /* Do for op(A) = A, A**T, and A**H. */ *(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]; /* Call ZLATTR to generate a triangular test matrix. */ s_copy(srnamc_1.srnamt, "ZLATTR", (ftnlen)32, (ftnlen)6); zlattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda, &x[1], &work[1], &rwork[1], &info); /* + TEST 8 */ /* Solve the system op(A)*x = b. */ s_copy(srnamc_1.srnamt, "ZLATRS", (ftnlen)32, (ftnlen)6); zcopy_(&n, &x[1], &c__1, &b[1], &c__1); zlatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], & scale, &rwork[1], &info); /* Check error code from ZLATRS. */ if (info != 0) { /* Writing concatenation */ i__6[0] = 1, a__3[0] = uplo; i__6[1] = 1, a__3[1] = trans; i__6[2] = 1, a__3[2] = diag; i__6[3] = 1, a__3[3] = "N"; s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4); alaerh_(path, "ZLATRS", &info, &c__0, ch__3, &n, &n, & c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout); } ztrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale, &rwork[1], &c_b99, &b[1], &lda, &x[1], &lda, & work[1], &result[7]); /* + TEST 9 */ /* Solve op(A)*X = b again with NORMIN = 'Y'. */ zcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1); zlatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1] , &scale, &rwork[1], &info); /* Check error code from ZLATRS. */ if (info != 0) { /* Writing concatenation */ i__6[0] = 1, a__3[0] = uplo; i__6[1] = 1, a__3[1] = trans; i__6[2] = 1, a__3[2] = diag; i__6[3] = 1, a__3[3] = "Y"; s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4); alaerh_(path, "ZLATRS", &info, &c__0, ch__3, &n, &n, & c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout); } ztrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale, &rwork[1], &c_b99, &b[n + 1], &lda, &x[1], &lda, &work[1], &result[8]); /* Print information about the tests that did not pass */ /* the threshold. */ if (result[7] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___40.ciunit = *nout; s_wsfe(&io___40); do_fio(&c__1, "ZLATRS", (ftnlen)6); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, "N", (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 *)&c__8, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof( doublereal)); e_wsfe(); ++nfail; } if (result[8] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___41.ciunit = *nout; s_wsfe(&io___41); do_fio(&c__1, "ZLATRS", (ftnlen)6); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, "Y", (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 *)&c__9, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof( doublereal)); e_wsfe(); ++nfail; } nrun += 2; /* L90: */ } /* L100: */ } L110: ; } /* L120: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &nerrs); return 0; /* End of ZCHKTR */ } /* zchktr_ */