/* Subroutine */ int cpstf2_(char *uplo, integer *n, complex *a, integer *lda, integer *piv, integer *rank, real *tol, real *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; real r__1; complex q__1, q__2; /* Builtin functions */ void r_cnjg(complex *, complex *); double sqrt(doublereal); /* Local variables */ integer i__, j, maxlocval; real ajj; integer pvt; extern logical lsame_(char *, char *); extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *); complex ctemp; extern /* Subroutine */ int cswap_(integer *, complex *, integer *, complex *, integer *); integer itemp; real stemp; logical upper; real sstop; extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *); extern logical sisnan_(real *); extern integer smaxloc_(real *, integer *); /* -- LAPACK PROTOTYPE routine (version 3.2) -- */ /* Craig Lucas, University of Manchester / NAG Ltd. */ /* October, 2008 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPSTF2 computes the Cholesky factorization with complete */ /* pivoting of a complex Hermitian positive semidefinite matrix A. */ /* The factorization has the form */ /* P' * A * P = U' * U , if UPLO = 'U', */ /* P' * A * P = L * L', if UPLO = 'L', */ /* where U is an upper triangular matrix and L is lower triangular, and */ /* P is stored as vector PIV. */ /* This algorithm does not attempt to check that A is positive */ /* semidefinite. This version of the algorithm calls level 2 BLAS. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* symmetric matrix A is stored. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ /* n by n upper triangular part of A contains the upper */ /* triangular part of the matrix A, and the strictly lower */ /* triangular part of A is not referenced. If UPLO = 'L', the */ /* leading n by n lower triangular part of A contains the lower */ /* triangular part of the matrix A, and the strictly upper */ /* triangular part of A is not referenced. */ /* On exit, if INFO = 0, the factor U or L from the Cholesky */ /* factorization as above. */ /* PIV (output) INTEGER array, dimension (N) */ /* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ /* RANK (output) INTEGER */ /* The rank of A given by the number of steps the algorithm */ /* completed. */ /* TOL (input) REAL */ /* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */ /* will be used. The algorithm terminates at the (K-1)st step */ /* if the pivot <= TOL. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* WORK REAL array, dimension (2*N) */ /* Work space. */ /* INFO (output) INTEGER */ /* < 0: If INFO = -K, the K-th argument had an illegal value, */ /* = 0: algorithm completed successfully, and */ /* > 0: the matrix A is either rank deficient with computed rank */ /* as returned in RANK, or is indefinite. See Section 7 of */ /* LAPACK Working Note #161 for further information. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ --work; --piv; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; /* 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; } if (*info != 0) { i__1 = -(*info); xerbla_("CPSTF2", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Initialize PIV */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { piv[i__] = i__; /* L100: */ } /* Compute stopping value */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * a_dim1; work[i__] = a[i__2].r; /* L110: */ } pvt = smaxloc_(&work[1], n); i__1 = pvt + pvt * a_dim1; ajj = a[i__1].r; if (ajj == 0.f || sisnan_(&ajj)) { *rank = 0; *info = 1; goto L200; } /* Compute stopping value if not supplied */ if (*tol < 0.f) { sstop = *n * slamch_("Epsilon") * ajj; } else { sstop = *tol; } /* Set first half of WORK to zero, holds dot products */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L120: */ } if (upper) { /* Compute the Cholesky factorization P' * A * P = U' * U */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Find pivot, test for exit, else swap rows and columns */ /* Update dot products, compute possible pivots which are */ /* stored in the second half of WORK */ i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { if (j > 1) { r_cnjg(&q__2, &a[j - 1 + i__ * a_dim1]); i__3 = j - 1 + i__ * a_dim1; q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i = q__2.r * a[i__3].i + q__2.i * a[i__3].r; work[i__] += q__1.r; } i__3 = i__ + i__ * a_dim1; work[*n + i__] = a[i__3].r - work[i__]; /* L130: */ } if (j > 1) { maxlocval = (*n << 1) - (*n + j) + 1; itemp = smaxloc_(&work[*n + j], &maxlocval); pvt = itemp + j - 1; ajj = work[*n + pvt]; if (ajj <= sstop || sisnan_(&ajj)) { i__2 = j + j * a_dim1; a[i__2].r = ajj, a[i__2].i = 0.f; goto L190; } } if (j != pvt) { /* Pivot OK, so can now swap pivot rows and columns */ i__2 = pvt + pvt * a_dim1; i__3 = j + j * a_dim1; a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; i__2 = j - 1; cswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1], &c__1); if (pvt < *n) { i__2 = *n - pvt; cswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + ( pvt + 1) * a_dim1], lda); } i__2 = pvt - 1; for (i__ = j + 1; i__ <= i__2; ++i__) { r_cnjg(&q__1, &a[j + i__ * a_dim1]); ctemp.r = q__1.r, ctemp.i = q__1.i; i__3 = j + i__ * a_dim1; r_cnjg(&q__1, &a[i__ + pvt * a_dim1]); a[i__3].r = q__1.r, a[i__3].i = q__1.i; i__3 = i__ + pvt * a_dim1; a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; /* L140: */ } i__2 = j + pvt * a_dim1; r_cnjg(&q__1, &a[j + pvt * a_dim1]); a[i__2].r = q__1.r, a[i__2].i = q__1.i; /* Swap dot products and PIV */ stemp = work[j]; work[j] = work[pvt]; work[pvt] = stemp; itemp = piv[pvt]; piv[pvt] = piv[j]; piv[j] = itemp; } ajj = sqrt(ajj); i__2 = j + j * a_dim1; a[i__2].r = ajj, a[i__2].i = 0.f; /* Compute elements J+1:N of row J */ if (j < *n) { i__2 = j - 1; clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1); i__2 = j - 1; i__3 = *n - j; q__1.r = -1.f, q__1.i = -0.f; cgemv_("Trans", &i__2, &i__3, &q__1, &a[(j + 1) * a_dim1 + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (j + 1) * a_dim1], lda); i__2 = j - 1; clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1); i__2 = *n - j; r__1 = 1.f / ajj; csscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda); } /* L150: */ } } else { /* Compute the Cholesky factorization P' * A * P = L * L' */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Find pivot, test for exit, else swap rows and columns */ /* Update dot products, compute possible pivots which are */ /* stored in the second half of WORK */ i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { if (j > 1) { r_cnjg(&q__2, &a[i__ + (j - 1) * a_dim1]); i__3 = i__ + (j - 1) * a_dim1; q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i = q__2.r * a[i__3].i + q__2.i * a[i__3].r; work[i__] += q__1.r; } i__3 = i__ + i__ * a_dim1; work[*n + i__] = a[i__3].r - work[i__]; /* L160: */ } if (j > 1) { maxlocval = (*n << 1) - (*n + j) + 1; itemp = smaxloc_(&work[*n + j], &maxlocval); pvt = itemp + j - 1; ajj = work[*n + pvt]; if (ajj <= sstop || sisnan_(&ajj)) { i__2 = j + j * a_dim1; a[i__2].r = ajj, a[i__2].i = 0.f; goto L190; } } if (j != pvt) { /* Pivot OK, so can now swap pivot rows and columns */ i__2 = pvt + pvt * a_dim1; i__3 = j + j * a_dim1; a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; i__2 = j - 1; cswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda); if (pvt < *n) { i__2 = *n - pvt; cswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1 + pvt * a_dim1], &c__1); } i__2 = pvt - 1; for (i__ = j + 1; i__ <= i__2; ++i__) { r_cnjg(&q__1, &a[i__ + j * a_dim1]); ctemp.r = q__1.r, ctemp.i = q__1.i; i__3 = i__ + j * a_dim1; r_cnjg(&q__1, &a[pvt + i__ * a_dim1]); a[i__3].r = q__1.r, a[i__3].i = q__1.i; i__3 = pvt + i__ * a_dim1; a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; /* L170: */ } i__2 = pvt + j * a_dim1; r_cnjg(&q__1, &a[pvt + j * a_dim1]); a[i__2].r = q__1.r, a[i__2].i = q__1.i; /* Swap dot products and PIV */ stemp = work[j]; work[j] = work[pvt]; work[pvt] = stemp; itemp = piv[pvt]; piv[pvt] = piv[j]; piv[j] = itemp; } ajj = sqrt(ajj); i__2 = j + j * a_dim1; a[i__2].r = ajj, a[i__2].i = 0.f; /* Compute elements J+1:N of column J */ if (j < *n) { i__2 = j - 1; clacgv_(&i__2, &a[j + a_dim1], lda); i__2 = *n - j; i__3 = j - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No Trans", &i__2, &i__3, &q__1, &a[j + 1 + a_dim1], lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j * a_dim1], &c__1); i__2 = j - 1; clacgv_(&i__2, &a[j + a_dim1], lda); i__2 = *n - j; r__1 = 1.f / ajj; csscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1); } /* L180: */ } } /* Ran to completion, A has full rank */ *rank = *n; goto L200; L190: /* Rank is number of steps completed. Set INFO = 1 to signal */ /* that the factorization cannot be used to solve a system. */ *rank = j - 1; *info = 1; L200: return 0; /* End of CPSTF2 */ } /* cpstf2_ */
/* Subroutine */ int clatme_(integer *n, char *dist, integer *iseed, complex * d__, integer *mode, real *cond, complex *dmax__, char *ei, char * rsign, char *upper, char *sim, real *ds, integer *modes, real *conds, integer *kl, integer *ku, real *anorm, complex *a, integer *lda, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real r__1, r__2; complex q__1, q__2; /* Builtin functions */ double c_abs(complex *); void r_cnjg(complex *, complex *); /* Local variables */ integer i__, j, ic, jc, ir, jcr; complex tau; logical bads; integer isim; real temp; extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *); complex alpha; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *); integer iinfo; real tempa[1]; integer icols, idist; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); integer irows; extern /* Subroutine */ int clatm1_(integer *, real *, integer *, integer *, integer *, complex *, integer *, integer *), slatm1_(integer *, real *, integer *, integer *, integer *, real *, integer *, integer *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int clarge_(integer *, complex *, integer *, integer *, complex *, integer *), clarfg_(integer *, complex *, complex *, integer *, complex *), clacgv_(integer *, complex *, integer *); extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); real ralpha; extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *), clarnv_(integer *, integer *, integer *, complex *); integer irsign, iupper; complex xnorms; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLATME generates random non-symmetric square matrices with */ /* specified eigenvalues for testing LAPACK programs. */ /* CLATME operates by applying the following sequence of */ /* operations: */ /* 1. Set the diagonal to D, where D may be input or */ /* computed according to MODE, COND, DMAX, and RSIGN */ /* as described below. */ /* 2. If UPPER='T', the upper triangle of A is set to random values */ /* out of distribution DIST. */ /* 3. If SIM='T', A is multiplied on the left by a random matrix */ /* X, whose singular values are specified by DS, MODES, and */ /* CONDS, and on the right by X inverse. */ /* 4. If KL < N-1, the lower bandwidth is reduced to KL using */ /* Householder transformations. If KU < N-1, the upper */ /* bandwidth is reduced to KU. */ /* 5. If ANORM is not negative, the matrix is scaled to have */ /* maximum-element-norm ANORM. */ /* (Note: since the matrix cannot be reduced beyond Hessenberg form, */ /* no packing options are available.) */ /* Arguments */ /* ========= */ /* N - INTEGER */ /* The number of columns (or rows) of A. Not modified. */ /* DIST - CHARACTER*1 */ /* On entry, DIST specifies the type of distribution to be used */ /* to generate the random eigen-/singular values, and on the */ /* upper triangle (see UPPER). */ /* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ /* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ /* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ /* 'D' => uniform on the complex disc |z| < 1. */ /* Not modified. */ /* ISEED - INTEGER array, dimension ( 4 ) */ /* On entry ISEED specifies the seed of the random number */ /* generator. They should lie between 0 and 4095 inclusive, */ /* and ISEED(4) should be odd. The random number generator */ /* uses a linear congruential sequence limited to small */ /* integers, and so should produce machine independent */ /* random numbers. The values of ISEED are changed on */ /* exit, and can be used in the next call to CLATME */ /* to continue the same random number sequence. */ /* Changed on exit. */ /* D - COMPLEX array, dimension ( N ) */ /* This array is used to specify the eigenvalues of A. If */ /* MODE=0, then D is assumed to contain the eigenvalues */ /* otherwise they will be computed according to MODE, COND, */ /* DMAX, and RSIGN and placed in D. */ /* Modified if MODE is nonzero. */ /* MODE - INTEGER */ /* On entry this describes how the eigenvalues are to */ /* be specified: */ /* MODE = 0 means use D as input */ /* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ /* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ /* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ /* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ /* MODE = 5 sets D to random numbers in the range */ /* ( 1/COND , 1 ) such that their logarithms */ /* are uniformly distributed. */ /* MODE = 6 set D to random numbers from same distribution */ /* as the rest of the matrix. */ /* MODE < 0 has the same meaning as ABS(MODE), except that */ /* the order of the elements of D is reversed. */ /* Thus if MODE is between 1 and 4, D has entries ranging */ /* from 1 to 1/COND, if between -1 and -4, D has entries */ /* ranging from 1/COND to 1, */ /* Not modified. */ /* COND - REAL */ /* On entry, this is used as described under MODE above. */ /* If used, it must be >= 1. Not modified. */ /* DMAX - COMPLEX */ /* If MODE is neither -6, 0 nor 6, the contents of D, as */ /* computed according to MODE and COND, will be scaled by */ /* DMAX / max(abs(D(i))). Note that DMAX need not be */ /* positive or real: if DMAX is negative or complex (or zero), */ /* D will be scaled by a negative or complex number (or zero). */ /* If RSIGN='F' then the largest (absolute) eigenvalue will be */ /* equal to DMAX. */ /* Not modified. */ /* EI - CHARACTER*1 (ignored) */ /* Not modified. */ /* RSIGN - CHARACTER*1 */ /* If MODE is not 0, 6, or -6, and RSIGN='T', then the */ /* elements of D, as computed according to MODE and COND, will */ /* be multiplied by a random complex number from the unit */ /* circle |z| = 1. If RSIGN='F', they will not be. RSIGN may */ /* only have the values 'T' or 'F'. */ /* Not modified. */ /* UPPER - CHARACTER*1 */ /* If UPPER='T', then the elements of A above the diagonal */ /* will be set to random numbers out of DIST. If UPPER='F', */ /* they will not. UPPER may only have the values 'T' or 'F'. */ /* Not modified. */ /* SIM - CHARACTER*1 */ /* If SIM='T', then A will be operated on by a "similarity */ /* transform", i.e., multiplied on the left by a matrix X and */ /* on the right by X inverse. X = U S V, where U and V are */ /* random unitary matrices and S is a (diagonal) matrix of */ /* singular values specified by DS, MODES, and CONDS. If */ /* SIM='F', then A will not be transformed. */ /* Not modified. */ /* DS - REAL array, dimension ( N ) */ /* This array is used to specify the singular values of X, */ /* in the same way that D specifies the eigenvalues of A. */ /* If MODE=0, the DS contains the singular values, which */ /* may not be zero. */ /* Modified if MODE is nonzero. */ /* MODES - INTEGER */ /* CONDS - REAL */ /* Similar to MODE and COND, but for specifying the diagonal */ /* of S. MODES=-6 and +6 are not allowed (since they would */ /* result in randomly ill-conditioned eigenvalues.) */ /* KL - INTEGER */ /* This specifies the lower bandwidth of the matrix. KL=1 */ /* specifies upper Hessenberg form. If KL is at least N-1, */ /* then A will have full lower bandwidth. */ /* Not modified. */ /* KU - INTEGER */ /* This specifies the upper bandwidth of the matrix. KU=1 */ /* specifies lower Hessenberg form. If KU is at least N-1, */ /* then A will have full upper bandwidth; if KU and KL */ /* are both at least N-1, then A will be dense. Only one of */ /* KU and KL may be less than N-1. */ /* Not modified. */ /* ANORM - REAL */ /* If ANORM is not negative, then A will be scaled by a non- */ /* negative real number to make the maximum-element-norm of A */ /* to be ANORM. */ /* Not modified. */ /* A - COMPLEX array, dimension ( LDA, N ) */ /* On exit A is the desired test matrix. */ /* Modified. */ /* LDA - INTEGER */ /* LDA specifies the first dimension of A as declared in the */ /* calling program. LDA must be at least M. */ /* Not modified. */ /* WORK - COMPLEX array, dimension ( 3*N ) */ /* Workspace. */ /* Modified. */ /* INFO - INTEGER */ /* Error code. On exit, INFO will be set to one of the */ /* following values: */ /* 0 => normal return */ /* -1 => N negative */ /* -2 => DIST illegal string */ /* -5 => MODE not in range -6 to 6 */ /* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ /* -9 => RSIGN is not 'T' or 'F' */ /* -10 => UPPER is not 'T' or 'F' */ /* -11 => SIM is not 'T' or 'F' */ /* -12 => MODES=0 and DS has a zero singular value. */ /* -13 => MODES is not in the range -5 to 5. */ /* -14 => MODES is nonzero and CONDS is less than 1. */ /* -15 => KL is less than 1. */ /* -16 => KU is less than 1, or KL and KU are both less than */ /* N-1. */ /* -19 => LDA is less than M. */ /* 1 => Error return from CLATM1 (computing D) */ /* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */ /* 3 => Error return from SLATM1 (computing DS) */ /* 4 => Error return from CLARGE */ /* 5 => Zero singular value from SLATM1. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* 1) Decode and Test the input parameters. */ /* Initialize flags & seed. */ /* Parameter adjustments */ --iseed; --d__; --ds; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n == 0) { return 0; } /* Decode DIST */ if (lsame_(dist, "U")) { idist = 1; } else if (lsame_(dist, "S")) { idist = 2; } else if (lsame_(dist, "N")) { idist = 3; } else if (lsame_(dist, "D")) { idist = 4; } else { idist = -1; } /* Decode RSIGN */ if (lsame_(rsign, "T")) { irsign = 1; } else if (lsame_(rsign, "F")) { irsign = 0; } else { irsign = -1; } /* Decode UPPER */ if (lsame_(upper, "T")) { iupper = 1; } else if (lsame_(upper, "F")) { iupper = 0; } else { iupper = -1; } /* Decode SIM */ if (lsame_(sim, "T")) { isim = 1; } else if (lsame_(sim, "F")) { isim = 0; } else { isim = -1; } /* Check DS, if MODES=0 and ISIM=1 */ bads = FALSE_; if (*modes == 0 && isim == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (ds[j] == 0.f) { bads = TRUE_; } /* L10: */ } } /* Set INFO if an error */ if (*n < 0) { *info = -1; } else if (idist == -1) { *info = -2; } else if (abs(*mode) > 6) { *info = -5; } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { *info = -6; } else if (irsign == -1) { *info = -9; } else if (iupper == -1) { *info = -10; } else if (isim == -1) { *info = -11; } else if (bads) { *info = -12; } else if (isim == 1 && abs(*modes) > 5) { *info = -13; } else if (isim == 1 && *modes != 0 && *conds < 1.f) { *info = -14; } else if (*kl < 1) { *info = -15; } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) { *info = -16; } else if (*lda < max(1,*n)) { *info = -19; } if (*info != 0) { i__1 = -(*info); xerbla_("CLATME", &i__1); return 0; } /* Initialize random number generator */ for (i__ = 1; i__ <= 4; ++i__) { iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; /* L20: */ } if (iseed[4] % 2 != 1) { ++iseed[4]; } /* 2) Set up diagonal of A */ /* Compute D according to COND and MODE */ clatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo); if (iinfo != 0) { *info = 1; return 0; } if (*mode != 0 && abs(*mode) != 6) { /* Scale by DMAX */ temp = c_abs(&d__[1]); i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = temp, r__2 = c_abs(&d__[i__]); temp = dmax(r__1,r__2); /* L30: */ } if (temp > 0.f) { q__1.r = dmax__->r / temp, q__1.i = dmax__->i / temp; alpha.r = q__1.r, alpha.i = q__1.i; } else { *info = 2; return 0; } cscal_(n, &alpha, &d__[1], &c__1); } claset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda); i__1 = *lda + 1; ccopy_(n, &d__[1], &c__1, &a[a_offset], &i__1); /* 3) If UPPER='T', set upper triangle of A to random numbers. */ if (iupper != 0) { i__1 = *n; for (jc = 2; jc <= i__1; ++jc) { i__2 = jc - 1; clarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]); /* L40: */ } } /* 4) If SIM='T', apply similarity transformation. */ /* -1 */ /* Transform is X A X , where X = U S V, thus */ /* it is U S V A V' (1/S) U' */ if (isim != 0) { /* Compute S (singular values of the eigenvector matrix) */ /* according to CONDS and MODES */ slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo); if (iinfo != 0) { *info = 3; return 0; } /* Multiply by V and V' */ clarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); if (iinfo != 0) { *info = 4; return 0; } /* Multiply by S and (1/S) */ i__1 = *n; for (j = 1; j <= i__1; ++j) { csscal_(n, &ds[j], &a[j + a_dim1], lda); if (ds[j] != 0.f) { r__1 = 1.f / ds[j]; csscal_(n, &r__1, &a[j * a_dim1 + 1], &c__1); } else { *info = 5; return 0; } /* L50: */ } /* Multiply by U and U' */ clarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); if (iinfo != 0) { *info = 4; return 0; } } /* 5) Reduce the bandwidth. */ if (*kl < *n - 1) { /* Reduce bandwidth -- kill column */ i__1 = *n - 1; for (jcr = *kl + 1; jcr <= i__1; ++jcr) { ic = jcr - *kl; irows = *n + 1 - jcr; icols = *n + *kl - jcr; ccopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1); xnorms.r = work[1].r, xnorms.i = work[1].i; clarfg_(&irows, &xnorms, &work[2], &c__1, &tau); r_cnjg(&q__1, &tau); tau.r = q__1.r, tau.i = q__1.i; work[1].r = 1.f, work[1].i = 0.f; clarnd_(&q__1, &c__5, &iseed[1]); alpha.r = q__1.r, alpha.i = q__1.i; cgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1], lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1); q__1.r = -tau.r, q__1.i = -tau.i; cgerc_(&irows, &icols, &q__1, &work[1], &c__1, &work[irows + 1], & c__1, &a[jcr + (ic + 1) * a_dim1], lda); cgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1); r_cnjg(&q__2, &tau); q__1.r = -q__2.r, q__1.i = -q__2.i; cgerc_(n, &irows, &q__1, &work[irows + 1], &c__1, &work[1], &c__1, &a[jcr * a_dim1 + 1], lda); i__2 = jcr + ic * a_dim1; a[i__2].r = xnorms.r, a[i__2].i = xnorms.i; i__2 = irows - 1; claset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic * a_dim1], lda); i__2 = icols + 1; cscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda); r_cnjg(&q__1, &alpha); cscal_(n, &q__1, &a[jcr * a_dim1 + 1], &c__1); /* L60: */ } } else if (*ku < *n - 1) { /* Reduce upper bandwidth -- kill a row at a time. */ i__1 = *n - 1; for (jcr = *ku + 1; jcr <= i__1; ++jcr) { ir = jcr - *ku; irows = *n + *ku - jcr; icols = *n + 1 - jcr; ccopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1); xnorms.r = work[1].r, xnorms.i = work[1].i; clarfg_(&icols, &xnorms, &work[2], &c__1, &tau); r_cnjg(&q__1, &tau); tau.r = q__1.r, tau.i = q__1.i; work[1].r = 1.f, work[1].i = 0.f; i__2 = icols - 1; clacgv_(&i__2, &work[2], &c__1); clarnd_(&q__1, &c__5, &iseed[1]); alpha.r = q__1.r, alpha.i = q__1.i; cgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda, &work[1], &c__1, &c_b1, &work[icols + 1], &c__1); q__1.r = -tau.r, q__1.i = -tau.i; cgerc_(&irows, &icols, &q__1, &work[icols + 1], &c__1, &work[1], & c__1, &a[ir + 1 + jcr * a_dim1], lda); cgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], & c__1, &c_b1, &work[icols + 1], &c__1); r_cnjg(&q__2, &tau); q__1.r = -q__2.r, q__1.i = -q__2.i; cgerc_(&icols, n, &q__1, &work[1], &c__1, &work[icols + 1], &c__1, &a[jcr + a_dim1], lda); i__2 = ir + jcr * a_dim1; a[i__2].r = xnorms.r, a[i__2].i = xnorms.i; i__2 = icols - 1; claset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) * a_dim1], lda); i__2 = irows + 1; cscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1); r_cnjg(&q__1, &alpha); cscal_(n, &q__1, &a[jcr + a_dim1], lda); /* L70: */ } } /* Scale the matrix to have norm ANORM */ if (*anorm >= 0.f) { temp = clange_("M", n, n, &a[a_offset], lda, tempa); if (temp > 0.f) { ralpha = *anorm / temp; i__1 = *n; for (j = 1; j <= i__1; ++j) { csscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1); /* L80: */ } } } return 0; /* End of CLATME */ } /* clatme_ */
/* Subroutine */ int cungl2_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; complex q__1, q__2; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ integer i__, j, l; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *), clarf_(char *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *), clacgv_(integer *, complex *, integer *), xerbla_(char *, integer *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */ /* which is defined as the first m rows of a product of k elementary */ /* reflectors of order n */ /* Q = H(k)' . . . H(2)' H(1)' */ /* as returned by CGELQF. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix Q. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q. N >= M. */ /* K (input) INTEGER */ /* The number of elementary reflectors whose product defines the */ /* matrix Q. M >= K >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the i-th row must contain the vector which defines */ /* the elementary reflector H(i), for i = 1,2,...,k, as returned */ /* by CGELQF in the first k rows of its array argument A. */ /* On exit, the m by n matrix Q. */ /* LDA (input) INTEGER */ /* The first dimension of the array A. LDA >= max(1,M). */ /* TAU (input) COMPLEX array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by CGELQF. */ /* WORK (workspace) COMPLEX array, dimension (M) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument has an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < *m) { *info = -2; } else if (*k < 0 || *k > *m) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("CUNGL2", &i__1); return 0; } /* Quick return if possible */ if (*m <= 0) { return 0; } if (*k < *m) { /* Initialise rows k+1:m to rows of the unit matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (l = *k + 1; l <= i__2; ++l) { i__3 = l + j * a_dim1; a[i__3].r = 0.f, a[i__3].i = 0.f; /* L10: */ } if (j > *k && j <= *m) { i__2 = j + j * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; } /* L20: */ } } for (i__ = *k; i__ >= 1; --i__) { /* Apply H(i)' to A(i:m,i:n) from the right */ if (i__ < *n) { i__1 = *n - i__; clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); if (i__ < *m) { i__1 = i__ + i__ * a_dim1; a[i__1].r = 1.f, a[i__1].i = 0.f; i__1 = *m - i__; i__2 = *n - i__ + 1; r_cnjg(&q__1, &tau[i__]); clarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & q__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); } i__1 = *n - i__; i__2 = i__; q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i; cscal_(&i__1, &q__1, &a[i__ + (i__ + 1) * a_dim1], lda); i__1 = *n - i__; clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); } i__1 = i__ + i__ * a_dim1; r_cnjg(&q__2, &tau[i__]); q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* Set A(i,1:i-1,i) to zero */ i__1 = i__ - 1; for (l = 1; l <= i__1; ++l) { i__2 = i__ + l * a_dim1; a[i__2].r = 0.f, a[i__2].i = 0.f; /* L30: */ } /* L40: */ } return 0; /* End of CUNGL2 */ } /* cungl2_ */
/* Subroutine */ int clabrd_(integer *m, integer *n, integer *nb, complex *a, integer *lda, real *d__, real *e, complex *tauq, complex *taup, complex *x, integer *ldx, complex *y, integer *ldy) { /* System generated locals */ integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, i__3; complex q__1; /* Local variables */ integer i__; complex alpha; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CLABRD reduces the first NB rows and columns of a complex general */ /* m by n matrix A to upper or lower real bidiagonal form by a unitary */ /* transformation Q' * A * P, and returns the matrices X and Y which */ /* are needed to apply the transformation to the unreduced part of A. */ /* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */ /* bidiagonal form. */ /* This is an auxiliary routine called by CGEBRD */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows in the matrix A. */ /* N (input) INTEGER */ /* The number of columns in the matrix A. */ /* NB (input) INTEGER */ /* The number of leading rows and columns of A to be reduced. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the m by n general matrix to be reduced. */ /* On exit, the first NB rows and columns of the matrix are */ /* overwritten; the rest of the array is unchanged. */ /* If m >= n, elements on and below the diagonal in the first NB */ /* columns, with the array TAUQ, represent the unitary */ /* matrix Q as a product of elementary reflectors; and */ /* elements above the diagonal in the first NB rows, with the */ /* array TAUP, represent the unitary matrix P as a product */ /* of elementary reflectors. */ /* If m < n, elements below the diagonal in the first NB */ /* columns, with the array TAUQ, represent the unitary */ /* matrix Q as a product of elementary reflectors, and */ /* elements on and above the diagonal in the first NB rows, */ /* with the array TAUP, represent the unitary matrix P as */ /* a product of elementary reflectors. */ /* See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* D (output) REAL array, dimension (NB) */ /* The diagonal elements of the first NB rows and columns of */ /* the reduced matrix. D(i) = A(i,i). */ /* E (output) REAL array, dimension (NB) */ /* The off-diagonal elements of the first NB rows and columns of */ /* the reduced matrix. */ /* TAUQ (output) COMPLEX array dimension (NB) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix Q. See Further Details. */ /* TAUP (output) COMPLEX array, dimension (NB) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix P. See Further Details. */ /* X (output) COMPLEX array, dimension (LDX,NB) */ /* The m-by-nb matrix X required to update the unreduced part */ /* of A. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,M). */ /* Y (output) COMPLEX array, dimension (LDY,NB) */ /* The n-by-nb matrix Y required to update the unreduced part */ /* of A. */ /* LDY (input) INTEGER */ /* The leading dimension of the array Y. LDY >= max(1,N). */ /* Further Details */ /* =============== */ /* The matrices Q and P are represented as products of elementary */ /* reflectors: */ /* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */ /* Each H(i) and G(i) has the form: */ /* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ /* where tauq and taup are complex scalars, and v and u are complex */ /* vectors. */ /* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */ /* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */ /* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */ /* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */ /* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* The elements of the vectors v and u together form the m-by-nb matrix */ /* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */ /* the transformation to the unreduced part of the matrix, using a block */ /* update of the form: A := A - V*Y' - X*U'. */ /* The contents of A on exit are illustrated by the following examples */ /* with nb = 2: */ /* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ /* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */ /* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */ /* ( v1 v2 a a a ) ( v1 1 a a a a ) */ /* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ /* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ /* ( v1 v2 a a a ) */ /* where a denotes an element of the original matrix which is unchanged, */ /* vi denotes an element of the vector defining H(i), and ui an element */ /* of the vector defining G(i). */ /* ===================================================================== */ /* Quick return if possible */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --d__; --e; --tauq; --taup; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; y_dim1 = *ldy; y_offset = 1 + y_dim1; y -= y_offset; /* Function Body */ if (*m <= 0 || *n <= 0) { return 0; } if (*m >= *n) { /* Reduce to upper bidiagonal form */ i__1 = *nb; for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i:m,i) */ i__2 = i__ - 1; clacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__ + 1; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], & c__1); i__2 = i__ - 1; clacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__ + 1; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ * a_dim1], &c__1); /* Generate reflection Q(i) to annihilate A(i+1:m,i) */ i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *m - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, & tauq[i__]); i__2 = i__; d__[i__2] = alpha.r; if (i__ < *n) { i__2 = i__ + i__ * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; /* Compute Y(i+1:n,i) */ i__2 = *m - i__ + 1; i__3 = *n - i__; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + ( i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], & c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1); i__2 = *m - i__ + 1; i__3 = i__ - 1; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, & y[i__ * y_dim1 + 1], &c__1); i__2 = *n - i__; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + 1 + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[ i__ + 1 + i__ * y_dim1], &c__1); i__2 = *m - i__ + 1; i__3 = i__ - 1; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ + x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, & y[i__ * y_dim1 + 1], &c__1); i__2 = i__ - 1; i__3 = *n - i__; q__1.r = -1.f, q__1.i = -0.f; cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, & c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1); i__2 = *n - i__; cscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); /* Update A(i,i+1:n) */ i__2 = *n - i__; clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); clacgv_(&i__, &a[i__ + a_dim1], lda); i__2 = *n - i__; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__, &q__1, &y[i__ + 1 + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + ( i__ + 1) * a_dim1], lda); clacgv_(&i__, &a[i__ + a_dim1], lda); i__2 = i__ - 1; clacgv_(&i__2, &x[i__ + x_dim1], ldx); i__2 = i__ - 1; i__3 = *n - i__; q__1.r = -1.f, q__1.i = -0.f; cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, & a[i__ + (i__ + 1) * a_dim1], lda); i__2 = i__ - 1; clacgv_(&i__2, &x[i__ + x_dim1], ldx); /* Generate reflection P(i) to annihilate A(i,i+2:n) */ i__2 = i__ + (i__ + 1) * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__; /* Computing MIN */ i__3 = i__ + 2; clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, & taup[i__]); i__2 = i__; e[i__2] = alpha.r; i__2 = i__ + (i__ + 1) * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; /* Compute X(i+1:m,i) */ i__2 = *m - i__; i__3 = *n - i__; cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1); i__2 = *n - i__; cgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1 + y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b1, &x[i__ * x_dim1 + 1], &c__1); i__2 = *m - i__; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__, &q__1, &a[i__ + 1 + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1); i__2 = i__ - 1; i__3 = *n - i__; cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) * a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b1, &x[i__ * x_dim1 + 1], &c__1); i__2 = *m - i__; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + 1 + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1); i__2 = *m - i__; cscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); i__2 = *n - i__; clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); } } } else { /* Reduce to lower bidiagonal form */ i__1 = *nb; for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i,i:n) */ i__2 = *n - i__ + 1; clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ - 1; clacgv_(&i__2, &a[i__ + a_dim1], lda); i__2 = *n - i__ + 1; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ - 1; clacgv_(&i__2, &a[i__ + a_dim1], lda); i__2 = i__ - 1; clacgv_(&i__2, &x[i__ + x_dim1], ldx); i__2 = i__ - 1; i__3 = *n - i__ + 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[i__ * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ - 1; clacgv_(&i__2, &x[i__ + x_dim1], ldx); /* Generate reflection P(i) to annihilate A(i,i+1:n) */ i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, & taup[i__]); i__2 = i__; d__[i__2] = alpha.r; if (i__ < *m) { i__2 = i__ + i__ * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; /* Compute X(i+1:m,i) */ i__2 = *m - i__; i__3 = *n - i__ + 1; cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[ i__ + 1 + i__ * x_dim1], &c__1); i__2 = *n - i__ + 1; i__3 = i__ - 1; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ + y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[ i__ * x_dim1 + 1], &c__1); i__2 = *m - i__; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1); i__2 = i__ - 1; i__3 = *n - i__ + 1; cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 + 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ * x_dim1 + 1], &c__1); i__2 = *m - i__; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + 1 + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1); i__2 = *m - i__; cscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); i__2 = *n - i__ + 1; clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); /* Update A(i+1:m,i) */ i__2 = i__ - 1; clacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + 1 + i__ * a_dim1], &c__1); i__2 = i__ - 1; clacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__, &q__1, &x[i__ + 1 + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[ i__ + 1 + i__ * a_dim1], &c__1); /* Generate reflection Q(i) to annihilate A(i+2:m,i) */ i__2 = i__ + 1 + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *m - i__; /* Computing MIN */ i__3 = i__ + 2; clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &tauq[i__]); i__2 = i__; e[i__2] = alpha.r; i__2 = i__ + 1 + i__ * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; /* Compute Y(i+1:n,i) */ i__2 = *m - i__; i__3 = *n - i__; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1] , &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1); i__2 = *m - i__; i__3 = i__ - 1; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &y[i__ * y_dim1 + 1], &c__1); i__2 = *n - i__; i__3 = i__ - 1; q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + 1 + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[ i__ + 1 + i__ * y_dim1], &c__1); i__2 = *m - i__; cgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1 + x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &y[i__ * y_dim1 + 1], &c__1); i__2 = *n - i__; q__1.r = -1.f, q__1.i = -0.f; cgemv_("Conjugate transpose", &i__, &i__2, &q__1, &a[(i__ + 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, & c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1); i__2 = *n - i__; cscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); } else { i__2 = *n - i__ + 1; clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); } } } return 0; /* End of CLABRD */ } /* clabrd_ */
/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; /* Local variables */ integer i__, k; complex alpha; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CGERQ2 computes an RQ factorization of a complex m by n matrix A: */ /* A = R * Q. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, if m <= n, the upper triangle of the subarray */ /* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */ /* if m >= n, the elements on and above the (m-n)-th subdiagonal */ /* contain the m by n upper trapezoidal matrix R; the remaining */ /* elements, with the array TAU, represent the unitary matrix */ /* Q as a product of elementary reflectors (see Further */ /* Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX array, dimension (M) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */ /* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */ /* ===================================================================== */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CGERQ2", &i__1); return 0; } k = min(*m,*n); for (i__ = k; i__ >= 1; --i__) { /* Generate elementary reflector H(i) to annihilate */ /* A(m-k+i,1:n-k+i-1) */ i__1 = *n - k + i__; clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda); i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; alpha.r = a[i__1].r, alpha.i = a[i__1].i; i__1 = *n - k + i__; clarfp_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]); /* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; a[i__1].r = 1.f, a[i__1].i = 0.f; i__1 = *m - k + i__ - 1; i__2 = *n - k + i__; clarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[ i__], &a[a_offset], lda, &work[1]); i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; a[i__1].r = alpha.r, a[i__1].i = alpha.i; i__1 = *n - k + i__ - 1; clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda); } return 0; /* End of CGERQ2 */ } /* cgerq2_ */