/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n, complex *ap, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer ix, kase, kase1; real scale; extern logical lsame_(char *, char *); integer isave[3]; real anorm; logical upper; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); real xnorm; extern integer icamax_(integer *, complex *, integer *); extern real slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); extern real clantp_(char *, char *, char *, integer *, complex *, real *); extern /* Subroutine */ int clatps_(char *, char *, char *, char *, integer *, complex *, complex *, real *, real *, integer *); real ainvnm; extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer *); logical onenrm; char normin[1]; real smlnum; logical nounit; /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --rwork; --work; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CTPCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum") * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1]); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ 1], &scale, &rwork[1], info); } else { /* Multiply by inv(A**H). */ clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1], &work[1], &scale, &rwork[1], info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; xnorm = (r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& work[ix]), abs(r__2)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of CTPCON */ }
/* Subroutine */ int ctbcon_(char *norm, char *uplo, char *diag, integer *n, integer *kd, complex *ab, integer *ldab, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer ix, kase, kase1; real scale; extern logical lsame_(char *, char *); integer isave[3]; real anorm; logical upper; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); real xnorm; extern integer icamax_(integer *, complex *, integer *); extern doublereal clantb_(char *, char *, char *, integer *, integer *, complex *, integer *, real *), slamch_( char *); extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, integer *, integer *, complex *, integer *, complex *, real *, real *, integer *), xerbla_(char * , integer *); real ainvnm; extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer *); logical onenrm; char normin[1]; real smlnum; logical nounit; /* -- 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 */ /* ======= */ /* CTBCON estimates the reciprocal of the condition number of a */ /* triangular band matrix A, in either the 1-norm or the infinity-norm. */ /* The norm of A is computed and an estimate is obtained for */ /* norm(inv(A)), then the reciprocal of the condition number is */ /* computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KD (input) INTEGER */ /* The number of superdiagonals or subdiagonals of the */ /* triangular band matrix A. KD >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* The upper or lower triangular band matrix A, stored in the */ /* first kd+1 rows of the array. The j-th column of A is stored */ /* in the j-th column of the array AB as follows: */ /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ /* If DIAG = 'U', the diagonal elements of A are not referenced */ /* and are assumed to be 1. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KD+1. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic 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; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*kd < 0) { *info = -5; } else if (*ldab < *kd + 1) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("CTBCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum") * (real) max(*n,1); /* Compute the 1-norm of the triangular matrix A or A'. */ anorm = clantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the 1-norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ clatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scale, &rwork[1], info); } else { /* Multiply by inv(A'). */ clatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scale, &rwork[1], info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of CTBCON */ } /* ctbcon_ */
/* Subroutine */ int cppcon_(char *uplo, integer *n, complex *ap, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer i__1; real r__1, r__2; /* Local variables */ integer ix, kase; real scale; integer isave[3]; logical upper; real scalel; real scaleu; real ainvnm; char normin[1]; real smlnum; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* Purpose */ /* ======= */ /* CPPCON estimates the reciprocal of the condition number (in the */ /* 1-norm) of a complex Hermitian positive definite packed matrix using */ /* the Cholesky factorization A = U**H*U or A = L*L**H computed by */ /* CPPTRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**H*U or A = L*L**H, packed columnwise in a linear */ /* array. The j-th column of U or L is stored in the array AP */ /* as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ /* ANORM (input) REAL */ /* The 1-norm (or infinity-norm) of the Hermitian matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ /* estimate of the 1-norm of inv(A) computed in this routine. */ /* 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 */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --rwork; --work; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*anorm < 0.f) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CPPCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the 1-norm of the inverse. */ kase = 0; *(unsigned char *)normin = 'N'; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ clatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, & ap[1], &work[1], &scalel, &rwork[1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ clatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], & work[1], &scaleu, &rwork[1], info); } else { /* Multiply by inv(L). */ clatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], & work[1], &scalel, &rwork[1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ clatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, & ap[1], &work[1], &scaleu, &rwork[1], info); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CPPCON */ } /* cppcon_ */
/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CPBCON estimates the reciprocal of the condition number (in the 1-norm) of a complex Hermitian positive definite band matrix using the Cholesky factorization A = U**H*U or A = L*L**H computed by CPBTRF. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangular factor stored in AB; = 'L': Lower triangular factor stored in AB. N (input) INTEGER The order of the matrix A. N >= 0. KD (input) INTEGER The number of superdiagonals of the matrix A if UPLO = 'U', or the number of sub-diagonals if UPLO = 'L'. KD >= 0. AB (input) COMPLEX array, dimension (LDAB,N) The triangular factor U or L from the Cholesky factorization A = U**H*U or A = L*L**H of the band matrix A, stored in the first KD+1 rows of the array. The j-th column of U or L is stored in the j-th column of the array AB as follows: if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). LDAB (input) INTEGER The leading dimension of the array AB. LDAB >= KD+1. ANORM (input) REAL The 1-norm (or infinity-norm) of the Hermitian band matrix A. RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an estimate of the 1-norm of inv(A) computed in this routine. 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 ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer ab_dim1, ab_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer kase; static real scale; extern logical lsame_(char *, char *); static logical upper; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); static integer ix; extern integer icamax_(integer *, complex *, integer *); static real scalel; extern doublereal slamch_(char *); extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, integer *, integer *, complex *, integer *, complex *, real *, real *, integer *); static real scaleu; extern /* Subroutine */ int xerbla_(char *, integer *); static real ainvnm; extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer *); static char normin[1]; static real smlnum; #define WORK(I) work[(I)-1] #define RWORK(I) rwork[(I)-1] #define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)] *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kd < 0) { *info = -3; } else if (*ldab < *kd + 1) { *info = -5; } else if (*anorm < 0.f) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("CPBCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the 1-norm of the inverse. */ kase = 0; *(unsigned char *)normin = 'N'; L10: clacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info); } else { /* Multiply by inv(L). */ clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = icamax_(n, &WORK(1), &c__1); i__1 = ix; if (scale < ((r__1 = WORK(ix).r, dabs(r__1)) + (r__2 = r_imag(& WORK(ix)), dabs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &WORK(1), &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CPBCON */ } /* cpbcon_ */
/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info, ftnlen norm_len) { /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static real sl; static integer ix; static real su; static integer kase, kase1; static real scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); static real ainvnm; extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), csrscl_(integer *, real *, complex *, integer *); static logical onenrm; static char normin[1]; static real smlnum; /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* March 31, 1993 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGECON estimates the reciprocal of the condition number of a general */ /* complex matrix A, in either the 1-norm or the infinity-norm, using */ /* the LU factorization computed by CGETRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* The factors L and U from the factorization A = P*L*U */ /* as computed by CGETRF. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* ANORM (input) REAL */ /* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ /* If NORM = 'I', the infinity-norm of the original matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* WORK (workspace) COMPLEX array, dimension (2*N) */ /* RWORK (workspace) REAL array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; --rwork; /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, ( ftnlen)1); if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("CGECON", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum", (ftnlen)12); /* Estimate the norm of inv(A). */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(L). */ clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &rwork[1], info, (ftnlen)5, (ftnlen) 12, (ftnlen)4, (ftnlen)1); /* Multiply by inv(U). */ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info, ( ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); } else { /* Multiply by inv(U'). */ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info, ( ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1); /* Multiply by inv(L'). */ clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[ a_offset], lda, &work[1], &sl, &rwork[1], info, (ftnlen)5, (ftnlen)19, (ftnlen)4, (ftnlen)1); } /* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ scale = sl * su; *(unsigned char *)normin = 'Y'; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CGECON */ } /* cgecon_ */
/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n, complex *a, integer *lda, real *rcond, complex *work, real *rwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= CTRCON estimates the reciprocal of the condition number of a triangular matrix A, in either the 1-norm or the infinity-norm. The norm of A is computed and an estimate is obtained for norm(inv(A)), then the reciprocal of the condition number is computed as RCOND = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= NORM (input) CHARACTER*1 Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = '1' or 'O': 1-norm; = 'I': Infinity-norm. UPLO (input) CHARACTER*1 = 'U': A is upper triangular; = 'L': A is lower triangular. DIAG (input) CHARACTER*1 = 'N': A is non-unit triangular; = 'U': A is unit triangular. N (input) INTEGER The order of the matrix A. N >= 0. A (input) COMPLEX array, dimension (LDA,N) The triangular matrix A. If UPLO = 'U', the leading N-by-N upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If UPLO = 'L', the leading N-by-N lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If DIAG = 'U', the diagonal elements of A are also not referenced and are assumed to be 1. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(norm(A) * norm(inv(A))). 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 ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer kase, kase1; static real scale; extern logical lsame_(char *, char *); static real anorm; static logical upper; static real xnorm; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); static integer ix; extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); extern doublereal clantr_(char *, char *, char *, integer *, integer *, complex *, integer *, real *); static real ainvnm; extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *), csrscl_(integer *, real *, complex *, integer *); static logical onenrm; static char normin[1]; static real smlnum; static logical nounit; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*lda < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("CTRCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum") * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = clantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[1]); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ clatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &rwork[1], info); } else { /* Multiply by inv(A'). */ clatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[ a_offset], lda, &work[1], &scale, &rwork[1], info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of CTRCON */ } /* ctrcon_ */
/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n, complex *ap, real *rcond, complex *work, real *rwork, integer *info, ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len) { /* System generated locals */ integer i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer ix, kase, kase1; static real scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); static real anorm; static logical upper; static real xnorm; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern doublereal clantp_(char *, char *, char *, integer *, complex *, real *, ftnlen, ftnlen, ftnlen); extern /* Subroutine */ int clatps_(char *, char *, char *, char *, integer *, complex *, complex *, real *, real *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); static real ainvnm; extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer *); static logical onenrm; static char normin[1]; static real smlnum; static logical nounit; /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* March 31, 1993 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTPCON estimates the reciprocal of the condition number of a packed */ /* triangular matrix A, in either the 1-norm or the infinity-norm. */ /* The norm of A is computed and an estimate is obtained for */ /* norm(inv(A)), then the reciprocal of the condition number is */ /* computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The upper or lower triangular matrix A, packed columnwise in */ /* a linear array. The j-th column of A is stored in the array */ /* AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ /* If DIAG = 'U', the diagonal elements of A are not referenced */ /* and are assumed to be 1. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --rwork; --work; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, ( ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -2; } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { *info = -3; } else if (*n < 0) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CTPCON", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum", (ftnlen)12) * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1], (ftnlen)1, ( ftnlen)1, (ftnlen)1); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ 1], &scale, &rwork[1], info, (ftnlen)1, (ftnlen)12, ( ftnlen)1, (ftnlen)1); } else { /* Multiply by inv(A'). */ clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1], &work[1], &scale, &rwork[1], info, (ftnlen)1, (ftnlen) 19, (ftnlen)1, (ftnlen)1); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of CTPCON */ } /* ctpcon_ */
/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer ix, kase; static real scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); static logical upper; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); extern integer icamax_(integer *, complex *, integer *); static real scalel; extern doublereal slamch_(char *, ftnlen); static real scaleu; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); static real ainvnm; extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), csrscl_(integer *, real *, complex *, integer *); static char normin[1]; static real smlnum; /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* March 31, 1993 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPOCON estimates the reciprocal of the condition number (in the */ /* 1-norm) of a complex Hermitian positive definite matrix using the */ /* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**H*U or A = L*L**H, as computed by CPOTRF. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* ANORM (input) REAL */ /* The 1-norm (or infinity-norm) of the Hermitian matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ /* estimate of the 1-norm of inv(A) computed in this routine. */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("CPOCON", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum", (ftnlen)12); /* Estimate the 1-norm of inv(A). */ kase = 0; *(unsigned char *)normin = 'N'; L10: clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scalel, &rwork[1], info, ( ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scaleu, &rwork[1], info, ( ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); } else { /* Multiply by inv(L). */ clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scalel, &rwork[1], info, ( ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scaleu, &rwork[1], info, ( ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CPOCON */ } /* cpocon_ */
/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3; real r__1, r__2; complex q__1, q__2; /* Local variables */ integer j; complex t; integer kd, lm, jp, ix, kase, kase1; real scale; integer isave[3]; logical lnoti; real ainvnm; logical onenrm; char normin[1]; real smlnum; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* Purpose */ /* ======= */ /* CGBCON estimates the reciprocal of the condition number of a complex */ /* general band matrix A, in either the 1-norm or the infinity-norm, */ /* using the LU factorization computed by CGBTRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* 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. */ /* AB (input) COMPLEX array, dimension (LDAB,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. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices; for 1 <= i <= N, row i of the matrix was */ /* interchanged with row IPIV(i). */ /* ANORM (input) REAL */ /* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ /* If NORM = 'I', the infinity-norm of the original matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* 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 */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --ipiv; --work; --rwork; /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kl < 0) { *info = -3; } else if (*ku < 0) { *info = -4; } else if (*ldab < (*kl << 1) + *ku + 1) { *info = -6; } else if (*anorm < 0.f) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the norm of inv(A). */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kd = *kl + *ku + 1; lnoti = *kl > 0; kase = 0; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(L). */ if (lnoti) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *kl, i__3 = *n - j; lm = min(i__2,i__3); jp = ipiv[j]; i__2 = jp; t.r = work[i__2].r, t.i = work[i__2].i; if (jp != j) { i__2 = jp; i__3 = j; work[i__2].r = work[i__3].r, work[i__2].i = work[i__3] .i; i__2 = j; work[i__2].r = t.r, work[i__2].i = t.i; } q__1.r = -t.r, q__1.i = -t.i; caxpy_(&lm, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, & work[j + 1], &c__1); } } /* Multiply by inv(U). */ i__1 = *kl + *ku; clatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info); } else { /* Multiply by inv(U'). */ i__1 = *kl + *ku; clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, & i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info); /* Multiply by inv(L'). */ if (lnoti) { for (j = *n - 1; j >= 1; --j) { /* Computing MIN */ i__1 = *kl, i__2 = *n - j; lm = min(i__1,i__2); i__1 = j; i__2 = j; cdotc_(&q__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, & work[j + 1], &c__1); q__1.r = work[i__2].r - q__2.r, q__1.i = work[i__2].i - q__2.i; work[i__1].r = q__1.r, work[i__1].i = q__1.i; jp = ipiv[j]; if (jp != j) { i__1 = jp; t.r = work[i__1].r, t.i = work[i__1].i; i__1 = jp; i__2 = j; work[i__1].r = work[i__2].r, work[i__1].i = work[i__2] .i; i__1 = j; work[i__1].r = t.r, work[i__1].i = t.i; } } } } /* Divide X by 1/SCALE if doing so will not cause overflow. */ *(unsigned char *)normin = 'Y'; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L40; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L40: return 0; /* End of CGBCON */ } /* cgbcon_ */
/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select, integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer * m, complex *work, integer *ldwork, real *rwork, integer *info) { /* System generated locals */ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, work_dim1, work_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 *), r_imag(complex *); /* Local variables */ integer i__, j, k, ks, ix; real eps, est; integer kase, ierr; complex prod; real lnrm, rnrm, scale; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); integer isave[3]; complex dummy[1]; logical wants; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); real xnorm; extern doublereal scnrm2_(integer *, complex *, integer *); extern /* Subroutine */ int slabad_(real *, real *); extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); real bignum; logical wantbh; extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *), csrscl_(integer *, real *, complex *, integer *), ctrexc_(char *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, integer *); logical somcon; char normin[1]; real smlnum; logical wantsp; /* -- 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 */ /* ======= */ /* CTRSNA estimates reciprocal condition numbers for specified */ /* eigenvalues and/or right eigenvectors of a complex upper triangular */ /* matrix T (or of any matrix Q*T*Q**H with Q unitary). */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* Specifies whether condition numbers are required for */ /* eigenvalues (S) or eigenvectors (SEP): */ /* = 'E': for eigenvalues only (S); */ /* = 'V': for eigenvectors only (SEP); */ /* = 'B': for both eigenvalues and eigenvectors (S and SEP). */ /* HOWMNY (input) CHARACTER*1 */ /* = 'A': compute condition numbers for all eigenpairs; */ /* = 'S': compute condition numbers for selected eigenpairs */ /* specified by the array SELECT. */ /* SELECT (input) LOGICAL array, dimension (N) */ /* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ /* condition numbers are required. To select condition numbers */ /* for the j-th eigenpair, SELECT(j) must be set to .TRUE.. */ /* If HOWMNY = 'A', SELECT is not referenced. */ /* N (input) INTEGER */ /* The order of the matrix T. N >= 0. */ /* T (input) COMPLEX array, dimension (LDT,N) */ /* The upper triangular matrix T. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= max(1,N). */ /* VL (input) COMPLEX array, dimension (LDVL,M) */ /* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */ /* (or of any Q*T*Q**H with Q unitary), corresponding to the */ /* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ /* must be stored in consecutive columns of VL, as returned by */ /* CHSEIN or CTREVC. */ /* If JOB = 'V', VL is not referenced. */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. */ /* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */ /* VR (input) COMPLEX array, dimension (LDVR,M) */ /* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */ /* (or of any Q*T*Q**H with Q unitary), corresponding to the */ /* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ /* must be stored in consecutive columns of VR, as returned by */ /* CHSEIN or CTREVC. */ /* If JOB = 'V', VR is not referenced. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. */ /* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */ /* S (output) REAL array, dimension (MM) */ /* If JOB = 'E' or 'B', the reciprocal condition numbers of the */ /* selected eigenvalues, stored in consecutive elements of the */ /* array. Thus S(j), SEP(j), and the j-th columns of VL and VR */ /* all correspond to the same eigenpair (but not in general the */ /* j-th eigenpair, unless all eigenpairs are selected). */ /* If JOB = 'V', S is not referenced. */ /* SEP (output) REAL array, dimension (MM) */ /* If JOB = 'V' or 'B', the estimated reciprocal condition */ /* numbers of the selected eigenvectors, stored in consecutive */ /* elements of the array. */ /* If JOB = 'E', SEP is not referenced. */ /* MM (input) INTEGER */ /* The number of elements in the arrays S (if JOB = 'E' or 'B') */ /* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */ /* M (output) INTEGER */ /* The number of elements of the arrays S and/or SEP actually */ /* used to store the estimated condition numbers. */ /* If HOWMNY = 'A', M is set to N. */ /* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6) */ /* If JOB = 'E', WORK is not referenced. */ /* LDWORK (input) INTEGER */ /* The leading dimension of the array WORK. */ /* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */ /* RWORK (workspace) REAL array, dimension (N) */ /* If JOB = 'E', RWORK is not referenced. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The reciprocal of the condition number of an eigenvalue lambda is */ /* defined as */ /* S(lambda) = |v'*u| / (norm(u)*norm(v)) */ /* where u and v are the right and left eigenvectors of T corresponding */ /* to lambda; v' denotes the conjugate transpose of v, and norm(u) */ /* denotes the Euclidean norm. These reciprocal condition numbers always */ /* lie between zero (very badly conditioned) and one (very well */ /* conditioned). If n = 1, S(lambda) is defined to be 1. */ /* An approximate error bound for a computed eigenvalue W(i) is given by */ /* EPS * norm(T) / S(i) */ /* where EPS is the machine precision. */ /* The reciprocal of the condition number of the right eigenvector u */ /* corresponding to lambda is defined as follows. Suppose */ /* T = ( lambda c ) */ /* ( 0 T22 ) */ /* Then the reciprocal condition number is */ /* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */ /* where sigma-min denotes the smallest singular value. We approximate */ /* the smallest singular value by the reciprocal of an estimate of the */ /* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */ /* defined to be abs(T(1,1)). */ /* An approximate error bound for a computed right eigenvector VR(i) */ /* is given by */ /* EPS * norm(T) / SEP(i) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ --select; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --s; --sep; work_dim1 = *ldwork; work_offset = 1 + work_dim1; work -= work_offset; --rwork; /* Function Body */ wantbh = lsame_(job, "B"); wants = lsame_(job, "E") || wantbh; wantsp = lsame_(job, "V") || wantbh; somcon = lsame_(howmny, "S"); /* Set M to the number of eigenpairs for which condition numbers are */ /* to be computed. */ if (somcon) { *m = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (select[j]) { ++(*m); } /* L10: */ } } else { *m = *n; } *info = 0; if (! wants && ! wantsp) { *info = -1; } else if (! lsame_(howmny, "A") && ! somcon) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldvl < 1 || wants && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || wants && *ldvr < *n) { *info = -10; } else if (*mm < *m) { *info = -13; } else if (*ldwork < 1 || wantsp && *ldwork < *n) { *info = -16; } if (*info != 0) { i__1 = -(*info); xerbla_("CTRSNA", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { if (somcon) { if (! select[1]) { return 0; } } if (wants) { s[1] = 1.f; } if (wantsp) { sep[1] = c_abs(&t[t_dim1 + 1]); } return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S") / eps; bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); ks = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (somcon) { if (! select[k]) { goto L50; } } if (wants) { /* Compute the reciprocal condition number of the k-th */ /* eigenvalue. */ cdotc_(&q__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 + 1], &c__1); prod.r = q__1.r, prod.i = q__1.i; rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); s[ks] = c_abs(&prod) / (rnrm * lnrm); } if (wantsp) { /* Estimate the reciprocal condition number of the k-th */ /* eigenvector. */ /* Copy the matrix T to the array WORK and swap the k-th */ /* diagonal element to the (1,1) position. */ clacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], ldwork); ctrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, & c__1, &ierr); /* Form C = T22 - lambda*I in WORK(2:N,2:N). */ i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = i__ + i__ * work_dim1; i__4 = i__ + i__ * work_dim1; i__5 = work_dim1 + 1; q__1.r = work[i__4].r - work[i__5].r, q__1.i = work[i__4].i - work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L20: */ } /* Estimate a lower bound for the 1-norm of inv(C'). The 1st */ /* and (N+1)th columns of WORK are used to store work vectors. */ sep[ks] = 0.f; est = 0.f; kase = 0; *(unsigned char *)normin = 'N'; L30: i__2 = *n - 1; clacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset] , &est, &kase, isave); if (kase != 0) { if (kase == 1) { /* Solve C'*x = scale*b */ i__2 = *n - 1; clatrs_("Upper", "Conjugate transpose", "Nonunit", normin, &i__2, &work[(work_dim1 << 1) + 2], ldwork, & work[work_offset], &scale, &rwork[1], &ierr); } else { /* Solve C*x = scale*b */ i__2 = *n - 1; clatrs_("Upper", "No transpose", "Nonunit", normin, &i__2, &work[(work_dim1 << 1) + 2], ldwork, &work[ work_offset], &scale, &rwork[1], &ierr); } *(unsigned char *)normin = 'Y'; if (scale != 1.f) { /* Multiply by 1/SCALE if doing so will not cause */ /* overflow. */ i__2 = *n - 1; ix = icamax_(&i__2, &work[work_offset], &c__1); i__2 = ix + work_dim1; xnorm = (r__1 = work[i__2].r, dabs(r__1)) + (r__2 = r_imag(&work[ix + work_dim1]), dabs(r__2)); if (scale < xnorm * smlnum || scale == 0.f) { goto L40; } csrscl_(n, &scale, &work[work_offset], &c__1); } goto L30; } sep[ks] = 1.f / dmax(est,smlnum); } L40: ++ks; L50: ; } return 0; /* End of CTRSNA */ } /* ctrsna_ */
/* Subroutine */ int cgelss_(integer *m, integer *n, integer *nrhs, complex * a, integer *lda, complex *b, integer *ldb, real *s, real *rcond, integer *rank, complex *work, integer *lwork, real *rwork, integer * info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; real r__1; /* Local variables */ integer i__, bl, ie, il, mm; complex dum[1]; real eps, thr, anrm, bnrm; integer itau, lwork_cgebrd__, lwork_cgelqf__, lwork_cgeqrf__, lwork_cungbr__, lwork_cunmbr__, lwork_cunmlq__, lwork_cunmqr__; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); integer iascl, ibscl; extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *); integer chunk; real sfmin; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); integer minmn, maxmn, itaup, itauq, mnthr, iwork; extern /* Subroutine */ int cgebrd_(), slabad_(real *, real *); extern real clange_(char *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), clascl_( char *, integer *, integer *, real *, real *, integer *, integer * , complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); extern real slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *), cbdsqr_(char *, integer *, integer *, integer *, integer *, real *, real *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); real bignum; extern /* Subroutine */ int cungbr_(char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *), cunmbr_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), csrscl_(integer *, real *, complex *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *), cunmlq_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); integer ldwork; extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); integer minwrk, maxwrk; real smlnum; integer irwork; logical lquery; /* -- LAPACK driver routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --s; --work; --rwork; /* Function Body */ *info = 0; minmn = min(*m,*n); maxmn = max(*m,*n); lquery = *lwork == -1; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else if (*ldb < max(1,maxmn)) { *info = -7; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* CWorkspace refers to complex workspace, and RWorkspace refers */ /* to real workspace. NB refers to the optimal block size for the */ /* immediately following subroutine, as returned by ILAENV.) */ if (*info == 0) { minwrk = 1; maxwrk = 1; if (minmn > 0) { mm = *m; mnthr = ilaenv_(&c__6, "CGELSS", " ", m, n, nrhs, &c_n1); if (*m >= *n && *m >= mnthr) { /* Path 1a - overdetermined, with many more rows than */ /* columns */ /* Compute space needed for CGEQRF */ cgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); lwork_cgeqrf__ = dum[0].r; /* Compute space needed for CUNMQR */ cunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, dum, &b[ b_offset], ldb, dum, &c_n1, info); lwork_cunmqr__ = dum[0].r; mm = *n; /* Computing MAX */ i__1 = maxwrk; i__2 = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1); // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = *n + *nrhs * ilaenv_(&c__1, "CUNMQR", "LC", m, nrhs, n, &c_n1); // , expr subst maxwrk = max(i__1,i__2); } if (*m >= *n) { /* Path 1 - overdetermined or exactly determined */ /* Compute space needed for CGEBRD */ cgebrd_(&mm, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, info); lwork_cgebrd__ = dum[0].r; /* Compute space needed for CUNMBR */ cunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, dum, & b[b_offset], ldb, dum, &c_n1, info); lwork_cunmbr__ = dum[0].r; /* Compute space needed for CUNGBR */ cungbr_("P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, info); lwork_cungbr__ = dum[0].r; /* Compute total workspace needed */ /* Computing MAX */ i__1 = maxwrk; i__2 = (*n << 1) + lwork_cgebrd__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = (*n << 1) + lwork_cunmbr__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = (*n << 1) + lwork_cungbr__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = *n * *nrhs; // , expr subst maxwrk = max(i__1,i__2); minwrk = (*n << 1) + max(*nrhs,*m); } if (*n > *m) { minwrk = (*m << 1) + max(*nrhs,*n); if (*n >= mnthr) { /* Path 2a - underdetermined, with many more columns */ /* than rows */ /* Compute space needed for CGELQF */ cgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); lwork_cgelqf__ = dum[0].r; /* Compute space needed for CGEBRD */ cgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, info); lwork_cgebrd__ = dum[0].r; /* Compute space needed for CUNMBR */ cunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, dum, &b[b_offset], ldb, dum, &c_n1, info); lwork_cunmbr__ = dum[0].r; /* Compute space needed for CUNGBR */ cungbr_("P", m, m, m, &a[a_offset], lda, dum, dum, &c_n1, info); lwork_cungbr__ = dum[0].r; /* Compute space needed for CUNMLQ */ cunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, dum, &b[ b_offset], ldb, dum, &c_n1, info); lwork_cunmlq__ = dum[0].r; /* Compute total workspace needed */ maxwrk = *m + lwork_cgelqf__; /* Computing MAX */ i__1 = maxwrk; i__2 = *m * 3 + *m * *m + lwork_cgebrd__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = *m * 3 + *m * *m + lwork_cunmbr__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = *m * 3 + *m * *m + lwork_cungbr__; // , expr subst maxwrk = max(i__1,i__2); if (*nrhs > 1) { /* Computing MAX */ i__1 = maxwrk; i__2 = *m * *m + *m + *m * *nrhs; // , expr subst maxwrk = max(i__1,i__2); } else { /* Computing MAX */ i__1 = maxwrk; i__2 = *m * *m + (*m << 1); // , expr subst maxwrk = max(i__1,i__2); } /* Computing MAX */ i__1 = maxwrk; i__2 = *m + lwork_cunmlq__; // , expr subst maxwrk = max(i__1,i__2); } else { /* Path 2 - underdetermined */ /* Compute space needed for CGEBRD */ cgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, info); lwork_cgebrd__ = dum[0].r; /* Compute space needed for CUNMBR */ cunmbr_("Q", "L", "C", m, nrhs, m, &a[a_offset], lda, dum, &b[b_offset], ldb, dum, &c_n1, info); lwork_cunmbr__ = dum[0].r; /* Compute space needed for CUNGBR */ cungbr_("P", m, n, m, &a[a_offset], lda, dum, dum, &c_n1, info); lwork_cungbr__ = dum[0].r; maxwrk = (*m << 1) + lwork_cgebrd__; /* Computing MAX */ i__1 = maxwrk; i__2 = (*m << 1) + lwork_cunmbr__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = (*m << 1) + lwork_cungbr__; // , expr subst maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk; i__2 = *n * *nrhs; // , expr subst maxwrk = max(i__1,i__2); } } maxwrk = max(minwrk,maxwrk); } work[1].r = (real) maxwrk; work[1].i = 0.f; // , expr subst if (*lwork < minwrk && ! lquery) { *info = -12; } } if (*info != 0) { i__1 = -(*info); xerbla_("CGELSS", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { *rank = 0; return 0; } /* Get machine parameters */ eps = slamch_("P"); sfmin = slamch_("S"); smlnum = sfmin / eps; bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]); iascl = 0; if (anrm > 0.f && anrm < smlnum) { /* Scale matrix norm up to SMLNUM */ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info); iascl = 1; } else if (anrm > bignum) { /* Scale matrix norm down to BIGNUM */ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info); iascl = 2; } else if (anrm == 0.f) { /* Matrix all zero. Return zero solution. */ i__1 = max(*m,*n); claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); slaset_("F", &minmn, &c__1, &c_b59, &c_b59, &s[1], &minmn); *rank = 0; goto L70; } /* Scale B if max element outside range [SMLNUM,BIGNUM] */ bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]); ibscl = 0; if (bnrm > 0.f && bnrm < smlnum) { /* Scale matrix norm up to SMLNUM */ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info); ibscl = 1; } else if (bnrm > bignum) { /* Scale matrix norm down to BIGNUM */ clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info); ibscl = 2; } /* Overdetermined case */ if (*m >= *n) { /* Path 1 - overdetermined or exactly determined */ mm = *m; if (*m >= mnthr) { /* Path 1a - overdetermined, with many more rows than columns */ mm = *n; itau = 1; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, info); /* Multiply B by transpose(Q) */ /* (CWorkspace: need N+NRHS, prefer N+NRHS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ b_offset], ldb, &work[iwork], &i__1, info); /* Zero out below R */ if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; claset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda); } } ie = 1; itauq = 1; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in A */ /* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */ /* (RWorkspace: need N) */ i__1 = *lwork - iwork + 1; cgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], & work[itaup], &work[iwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors of R */ /* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, &work[iwork], &i__1, info); /* Generate right bidiagonalizing vectors of R in A */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & i__1, info); irwork = ie + *n; /* Perform bidiagonal QR iteration */ /* multiply B by transpose of left singular vectors */ /* compute right singular vectors in A */ /* (CWorkspace: none) */ /* (RWorkspace: need BDSPAC) */ cbdsqr_("U", n, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda, dum, &c__1, &b[b_offset], ldb, &rwork[irwork], info); if (*info != 0) { goto L70; } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ r__1 = *rcond * s[1]; thr = max(r__1,sfmin); if (*rcond < 0.f) { /* Computing MAX */ r__1 = eps * s[1]; thr = max(r__1,sfmin); } *rank = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (s[i__] > thr) { csrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); ++(*rank); } else { claset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb); } /* L10: */ } /* Multiply B by right singular vectors */ /* (CWorkspace: need N, prefer N*NRHS) */ /* (RWorkspace: none) */ if (*lwork >= *ldb * *nrhs && *nrhs > 1) { cgemm_("C", "N", n, nrhs, n, &c_b2, &a[a_offset], lda, &b[ b_offset], ldb, &c_b1, &work[1], ldb); clacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb) ; } else if (*nrhs > 1) { chunk = *lwork / *n; i__1 = *nrhs; i__2 = chunk; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = *nrhs - i__ + 1; bl = min(i__3,chunk); cgemm_("C", "N", n, &bl, n, &c_b2, &a[a_offset], lda, &b[i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n); clacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb); /* L20: */ } } else { cgemv_("C", n, n, &c_b2, &a[a_offset], lda, &b[b_offset], &c__1, & c_b1, &work[1], &c__1); ccopy_(n, &work[1], &c__1, &b[b_offset], &c__1); } } else /* if(complicated condition) */ { /* Computing MAX */ i__2 = max(*m,*nrhs); i__1 = *n - (*m << 1); // , expr subst if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) { /* Underdetermined case, M much less than N */ /* Path 2a - underdetermined, with many more columns than rows */ /* and sufficient workspace for an efficient algorithm */ ldwork = *m; /* Computing MAX */ i__2 = max(*m,*nrhs); i__1 = *n - (*m << 1); // , expr subst if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) { ldwork = *lda; } itau = 1; iwork = *m + 1; /* Compute A=L*Q */ /* (CWorkspace: need 2*M, prefer M+M*NB) */ /* (RWorkspace: none) */ i__2 = *lwork - iwork + 1; cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, info); il = iwork; /* Copy L to WORK(IL), zeroing out above it */ clacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); i__2 = *m - 1; i__1 = *m - 1; claset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwork], & ldwork); ie = 1; itauq = il + ldwork * *m; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IL) */ /* (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; cgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], &i__2, info); /* Multiply B by transpose of left bidiagonalizing vectors of L */ /* (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB) */ /* (RWorkspace: none) */ i__2 = *lwork - iwork + 1; cunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[ itauq], &b[b_offset], ldb, &work[iwork], &i__2, info); /* Generate right bidiagonalizing vectors of R in WORK(IL) */ /* (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ /* (RWorkspace: none) */ i__2 = *lwork - iwork + 1; cungbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ iwork], &i__2, info); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing right singular */ /* vectors of L in WORK(IL) and multiplying B by transpose of */ /* left singular vectors */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ cbdsqr_("U", m, m, &c__0, nrhs, &s[1], &rwork[ie], &work[il], & ldwork, &a[a_offset], lda, &b[b_offset], ldb, &rwork[ irwork], info); if (*info != 0) { goto L70; } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ r__1 = *rcond * s[1]; thr = max(r__1,sfmin); if (*rcond < 0.f) { /* Computing MAX */ r__1 = eps * s[1]; thr = max(r__1,sfmin); } *rank = 0; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { if (s[i__] > thr) { csrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); ++(*rank); } else { claset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb); } /* L30: */ } iwork = il + *m * ldwork; /* Multiply B by right singular vectors of L in WORK(IL) */ /* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ /* (RWorkspace: none) */ if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { cgemm_("C", "N", m, nrhs, m, &c_b2, &work[il], &ldwork, &b[ b_offset], ldb, &c_b1, &work[iwork], ldb); clacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb); } else if (*nrhs > 1) { chunk = (*lwork - iwork + 1) / *m; i__2 = *nrhs; i__1 = chunk; for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { /* Computing MIN */ i__3 = *nrhs - i__ + 1; bl = min(i__3,chunk); cgemm_("C", "N", m, &bl, m, &c_b2, &work[il], &ldwork, &b[ i__ * b_dim1 + 1], ldb, &c_b1, &work[iwork], m); clacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1] , ldb); /* L40: */ } } else { cgemv_("C", m, m, &c_b2, &work[il], &ldwork, &b[b_dim1 + 1], & c__1, &c_b1, &work[iwork], &c__1); ccopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); } /* Zero out below first M rows of B */ i__1 = *n - *m; claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb); iwork = itau + *m; /* Multiply transpose(Q) by B */ /* (CWorkspace: need M+NRHS, prefer M+NHRS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ b_offset], ldb, &work[iwork], &i__1, info); } else { /* Path 2 - remaining underdetermined cases */ ie = 1; itauq = 1; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize A */ /* (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB) */ /* (RWorkspace: need N) */ i__1 = *lwork - iwork + 1; cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors */ /* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq] , &b[b_offset], ldb, &work[iwork], &i__1, info); /* Generate right bidiagonalizing vectors in A */ /* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; cungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ iwork], &i__1, info); irwork = ie + *m; /* Perform bidiagonal QR iteration, */ /* computing right singular vectors of A in A and */ /* multiplying B by transpose of left singular vectors */ /* (CWorkspace: none) */ /* (RWorkspace: need BDSPAC) */ cbdsqr_("L", m, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda, dum, &c__1, &b[b_offset], ldb, &rwork[irwork], info); if (*info != 0) { goto L70; } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ r__1 = *rcond * s[1]; thr = max(r__1,sfmin); if (*rcond < 0.f) { /* Computing MAX */ r__1 = eps * s[1]; thr = max(r__1,sfmin); } *rank = 0; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (s[i__] > thr) { csrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); ++(*rank); } else { claset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb); } /* L50: */ } /* Multiply B by right singular vectors of A */ /* (CWorkspace: need N, prefer N*NRHS) */ /* (RWorkspace: none) */ if (*lwork >= *ldb * *nrhs && *nrhs > 1) { cgemm_("C", "N", n, nrhs, m, &c_b2, &a[a_offset], lda, &b[ b_offset], ldb, &c_b1, &work[1], ldb); clacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb); } else if (*nrhs > 1) { chunk = *lwork / *n; i__1 = *nrhs; i__2 = chunk; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = *nrhs - i__ + 1; bl = min(i__3,chunk); cgemm_("C", "N", n, &bl, m, &c_b2, &a[a_offset], lda, &b[ i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n); clacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb); /* L60: */ } } else { cgemv_("C", m, n, &c_b2, &a[a_offset], lda, &b[b_offset], & c__1, &c_b1, &work[1], &c__1); ccopy_(n, &work[1], &c__1, &b[b_offset], &c__1); } } } /* Undo scaling */ if (iascl == 1) { clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info); slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & minmn, info); } else if (iascl == 2) { clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info); slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & minmn, info); } if (ibscl == 1) { clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info); } else if (ibscl == 2) { clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info); } L70: work[1].r = (real) maxwrk; work[1].i = 0.f; // , expr subst return 0; /* End of CGELSS */ }
/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer ix, kase; real scale; extern logical lsame_(char *, char *); integer isave[3]; logical upper; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); extern integer icamax_(integer *, complex *, integer *); real scalel; extern real slamch_(char *); real scaleu; extern /* Subroutine */ int xerbla_(char *, integer *); real ainvnm; extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *), csrscl_(integer *, real *, complex *, integer *); char normin[1]; real smlnum; /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("CPOCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the 1-norm of inv(A). */ kase = 0; *(unsigned char *)normin = 'N'; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (upper) { /* Multiply by inv(U**H). */ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scalel, &rwork[1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scaleu, &rwork[1], info); } else { /* Multiply by inv(L). */ clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scalel, &rwork[1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L**H). */ clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scaleu, &rwork[1], info); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& work[ix]), abs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CPOCON */ }
int cpbcon_(char *uplo, int *n, int *kd, complex *ab, int *ldab, float *anorm, float *rcond, complex *work, float *rwork, int *info) { /* System generated locals */ int ab_dim1, ab_offset, i__1; float r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ int ix, kase; float scale; extern int lsame_(char *, char *); int isave[3]; int upper; extern int clacn2_(int *, complex *, complex *, float *, int *, int *); extern int icamax_(int *, complex *, int *); float scalel; extern double slamch_(char *); extern int clatbs_(char *, char *, char *, char *, int *, int *, complex *, int *, complex *, float *, float *, int *); float scaleu; extern int xerbla_(char *, int *); float ainvnm; extern int csrscl_(int *, float *, complex *, int *); char normin[1]; float smlnum; /* -- 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 */ /* ======= */ /* CPBCON estimates the reciprocal of the condition number (in the */ /* 1-norm) of a complex Hermitian positive definite band matrix using */ /* the Cholesky factorization A = U**H*U or A = L*L**H computed by */ /* CPBTRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangular factor stored in AB; */ /* = 'L': Lower triangular factor stored in AB. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KD (input) INTEGER */ /* The number of superdiagonals of the matrix A if UPLO = 'U', */ /* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**H*U or A = L*L**H of the band matrix A, stored in the */ /* first KD+1 rows of the array. The j-th column of U or L is */ /* stored in the j-th column of the array AB as follows: */ /* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for MAX(1,j-kd)<=i<=j; */ /* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=MIN(n,j+kd). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KD+1. */ /* ANORM (input) REAL */ /* The 1-norm (or infinity-norm) of the Hermitian band matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ /* estimate of the 1-norm of inv(A) computed in this routine. */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic 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; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kd < 0) { *info = -3; } else if (*ldab < *kd + 1) { *info = -5; } else if (*anorm < 0.f) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("CPBCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the 1-norm of the inverse. */ kase = 0; *(unsigned char *)normin = 'N'; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd, &ab[ab_offset], ldab, &work[1], &scalel, &rwork[1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scaleu, &rwork[1], info); } else { /* Multiply by inv(L). */ clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scalel, &rwork[1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd, &ab[ab_offset], ldab, &work[1], &scaleu, &rwork[1], info); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, ABS(r__1)) + (r__2 = r_imag(& work[ix]), ABS(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CPBCON */ } /* cpbcon_ */
/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1, r__2; /* Local variables */ real sl; integer ix; real su; integer kase, kase1; real scale; integer isave[3]; real ainvnm; logical onenrm; char normin[1]; real smlnum; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* Purpose */ /* ======= */ /* CGECON estimates the reciprocal of the condition number of a general */ /* complex matrix A, in either the 1-norm or the infinity-norm, using */ /* the LU factorization computed by CGETRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* The factors L and U from the factorization A = P*L*U */ /* as computed by CGETRF. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* ANORM (input) REAL */ /* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ /* If NORM = 'I', the infinity-norm of the original matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* WORK (workspace) COMPLEX array, dimension (2*N) */ /* RWORK (workspace) REAL array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; --rwork; /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("CGECON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the norm of inv(A). */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(L). */ clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &rwork[1], info); /* Multiply by inv(U). */ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info); } else { /* Multiply by inv(U'). */ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info); /* Multiply by inv(L'). */ clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[ a_offset], lda, &work[1], &sl, &rwork[1], info); } /* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ scale = sl * su; *(unsigned char *)normin = 'Y'; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CGECON */ } /* cgecon_ */