int
f2c_ctrmm(char* side, char* uplo, char* trans, char* diag,
integer* M, integer* N,
complex* alpha,
complex* A, integer* lda,
complex* B, integer* ldb)
{
ctrmm_(side, uplo, trans, diag,
M, N, alpha, A, lda, B, ldb);
return 0;
}
void
ctrmm(char side, char uplo, char transa, char diag, int m, int n, complex *alpha, complex *a, int lda, complex *b, int ldb)
{
ctrmm_(&side, &uplo, &transa, &diag, &m, &n, alpha, a, &lda, b, &ldb);
}
int cgehrd_(int *n, int *ilo, int *ihi, complex *
a, int *lda, complex *tau, complex *work, int *lwork, int
*info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
int i__, j;
complex t[4160] /* was [65][64] */;
int ib;
complex ei;
int nb, nh, nx, iws;
extern int cgemm_(char *, char *, int *, int *,
int *, complex *, complex *, int *, complex *, int *,
complex *, complex *, int *);
int nbmin, iinfo;
extern int ctrmm_(char *, char *, char *, char *,
int *, int *, complex *, complex *, int *, complex *,
int *), caxpy_(int *,
complex *, complex *, int *, complex *, int *), cgehd2_(
int *, int *, int *, complex *, int *, complex *,
complex *, int *), clahr2_(int *, int *, int *,
complex *, int *, complex *, complex *, int *, complex *,
int *), clarfb_(char *, char *, char *, char *, int *,
int *, int *, complex *, int *, complex *, int *,
complex *, int *, complex *, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int ldwork, lwkopt;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEHRD reduces a complex general matrix A to upper Hessenberg form H by */
/* an unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to CGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, 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,N). */
/* TAU (output) COMPLEX array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
/* zero. */
/* WORK (workspace/output) COMPLEX array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= MAX(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* 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(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's CGEHRD */
/* subroutine incorporating improvements proposed by Quintana-Orti and */
/* Van de Geijn (2005). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "CGEHRD", " ", n, ilo, ihi, &c_n1);
nb = MIN(i__1,i__2);
lwkopt = *n * nb;
work[1].r = (float) lwkopt, work[1].i = 0.f;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > MAX(1,*n)) {
*info = -2;
} else if (*ihi < MIN(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEHRD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0.f, tau[i__2].i = 0.f;
/* L10: */
}
i__1 = *n - 1;
for (i__ = MAX(1,*ihi); i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0.f, tau[i__2].i = 0.f;
/* L20: */
}
/* Quick return if possible */
nh = *ihi - *ilo + 1;
if (nh <= 1) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Determine the block size */
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "CGEHRD", " ", n, ilo, ihi, &c_n1);
nb = MIN(i__1,i__2);
nbmin = 2;
iws = 1;
if (nb > 1 && nb < nh) {
/* Determine when to cross over from blocked to unblocked code */
/* (last block is always handled by unblocked code) */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "CGEHRD", " ", n, ilo, ihi, &c_n1);
nx = MAX(i__1,i__2);
if (nx < nh) {
/* Determine if workspace is large enough for blocked code */
iws = *n * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: determine the */
/* minimum value of NB, and reduce NB or force use of */
/* unblocked code */
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "CGEHRD", " ", n, ilo, ihi, &
c_n1);
nbmin = MAX(i__1,i__2);
if (*lwork >= *n * nbmin) {
nb = *lwork / *n;
} else {
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh) {
/* Use unblocked code below */
i__ = *ilo;
} else {
/* Use blocked code */
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *ihi - i__;
ib = MIN(i__3,i__4);
/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
/* matrices V and T of the block reflector H = I - V*T*V' */
/* which performs the reduction, and also the matrix Y = A*V*T */
clahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
c__65, &work[1], &ldwork);
/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
/* to 1 */
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
ei.r = a[i__3].r, ei.i = a[i__3].i;
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = 1.f, a[i__3].i = 0.f;
i__3 = *ihi - i__ - ib + 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, &
q__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda,
&c_b2, &a[(i__ + ib) * a_dim1 + 1], lda);
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = ei.r, a[i__3].i = ei.i;
/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
/* right */
i__3 = ib - 1;
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, &
i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &
ldwork);
i__3 = ib - 2;
for (j = 0; j <= i__3; ++j) {
q__1.r = -1.f, q__1.i = -0.f;
caxpy_(&i__, &q__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j
+ 1) * a_dim1 + 1], &c__1);
/* L30: */
}
/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
/* left */
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
clarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", &
i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &
c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &
ldwork);
/* L40: */
}
}
/* Use unblocked code to reduce the rest of the matrix */
cgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1].r = (float) iws, work[1].i = 0.f;
return 0;
/* End of CGEHRD */
} /* cgehrd_ */
int ctftri_(char *transr, char *uplo, char *diag, int *n,
complex *a, int *info)
{
/* System generated locals */
int i__1, i__2;
complex q__1;
/* Local variables */
int k, n1, n2;
int normaltransr;
extern int lsame_(char *, char *);
extern int ctrmm_(char *, char *, char *, char *,
int *, int *, complex *, complex *, int *, complex *,
int *);
int lower;
extern int xerbla_(char *, int *);
int nisodd;
extern int ctrtri_(char *, char *, int *, complex *,
int *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTFTRI computes the inverse of a triangular matrix A stored in RFP */
/* format. */
/* This is a Level 3 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* TRANSR (input) CHARACTER */
/* = 'N': The Normal TRANSR of RFP A is stored; */
/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
/* UPLO (input) CHARACTER */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */
/* On entry, the triangular matrix A in RFP format. RFP format */
/* is described by TRANSR, UPLO, and N as follows: If TRANSR = */
/* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
/* the Conjugate-transpose of RFP A as defined when */
/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
/* upper packed A; If UPLO = 'L' the RFP A contains the nt */
/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */
/* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is */
/* even and N is odd. See the Note below for more details. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
/* matrix is singular and its inverse can not be computed. */
/* Notes: */
/* ====== */
/* We first consider Standard Packed Format when N is even. */
/* We give an example where N = 6. */
/* AP is Upper AP is Lower */
/* 00 01 02 03 04 05 00 */
/* 11 12 13 14 15 10 11 */
/* 22 23 24 25 20 21 22 */
/* 33 34 35 30 31 32 33 */
/* 44 45 40 41 42 43 44 */
/* 55 50 51 52 53 54 55 */
/* Let TRANSR = 'N'. RFP holds AP as follows: */
/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
/* conjugate-transpose of the first three columns of AP upper. */
/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
/* conjugate-transpose of the last three columns of AP lower. */
/* To denote conjugate we place -- above the element. This covers the */
/* case N even and TRANSR = 'N'. */
/* RFP A RFP A */
/* -- -- -- */
/* 03 04 05 33 43 53 */
/* -- -- */
/* 13 14 15 00 44 54 */
/* -- */
/* 23 24 25 10 11 55 */
/* 33 34 35 20 21 22 */
/* -- */
/* 00 44 45 30 31 32 */
/* -- -- */
/* 01 11 55 40 41 42 */
/* -- -- -- */
/* 02 12 22 50 51 52 */
/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
/* transpose of RFP A above. One therefore gets: */
/* RFP A RFP A */
/* -- -- -- -- -- -- -- -- -- -- */
/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
/* -- -- -- -- -- -- -- -- -- -- */
/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
/* -- -- -- -- -- -- -- -- -- -- */
/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
/* We next consider Standard Packed Format when N is odd. */
/* We give an example where N = 5. */
/* AP is Upper AP is Lower */
/* 00 01 02 03 04 00 */
/* 11 12 13 14 10 11 */
/* 22 23 24 20 21 22 */
/* 33 34 30 31 32 33 */
/* 44 40 41 42 43 44 */
/* Let TRANSR = 'N'. RFP holds AP as follows: */
/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
/* conjugate-transpose of the first two columns of AP upper. */
/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
/* conjugate-transpose of the last two columns of AP lower. */
/* To denote conjugate we place -- above the element. This covers the */
/* case N odd and TRANSR = 'N'. */
/* RFP A RFP A */
/* -- -- */
/* 02 03 04 00 33 43 */
/* -- */
/* 12 13 14 10 11 44 */
/* 22 23 24 20 21 22 */
/* -- */
/* 00 33 34 30 31 32 */
/* -- -- */
/* 01 11 44 40 41 42 */
/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
/* transpose of RFP A above. One therefore gets: */
/* RFP A RFP A */
/* -- -- -- -- -- -- -- -- -- */
/* 02 12 22 00 01 00 10 20 30 40 50 */
/* -- -- -- -- -- -- -- -- -- */
/* 03 13 23 33 11 33 11 21 31 41 51 */
/* -- -- -- -- -- -- -- -- -- */
/* 04 14 24 34 44 43 44 22 32 42 52 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
*info = 0;
normaltransr = lsame_(transr, "N");
lower = lsame_(uplo, "L");
if (! normaltransr && ! lsame_(transr, "C")) {
*info = -1;
} else if (! lower && ! lsame_(uplo, "U")) {
*info = -2;
} else if (! lsame_(diag, "N") && ! lsame_(diag,
"U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTFTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* If N is odd, set NISODD = .TRUE. */
/* If N is even, set K = N/2 and NISODD = .FALSE. */
if (*n % 2 == 0) {
k = *n / 2;
nisodd = FALSE;
} else {
nisodd = TRUE;
}
/* Set N1 and N2 depending on LOWER */
if (lower) {
n2 = *n / 2;
n1 = *n - n2;
} else {
n1 = *n / 2;
n2 = *n - n1;
}
/* start execution: there are eight cases */
if (nisodd) {
/* N is odd */
if (normaltransr) {
/* N is odd and TRANSR = 'N' */
if (lower) {
/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
ctrtri_("L", diag, &n1, a, n, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
ctrmm_("R", "L", "N", diag, &n2, &n1, &q__1, a, n, &a[n1], n);
ctrtri_("U", diag, &n2, &a[*n], n, info)
;
if (*info > 0) {
*info += n1;
}
if (*info > 0) {
return 0;
}
ctrmm_("L", "U", "C", diag, &n2, &n1, &c_b1, &a[*n], n, &a[n1]
, n);
} else {
/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
ctrtri_("L", diag, &n1, &a[n2], n, info)
;
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
ctrmm_("L", "L", "C", diag, &n1, &n2, &q__1, &a[n2], n, a, n);
ctrtri_("U", diag, &n2, &a[n1], n, info)
;
if (*info > 0) {
*info += n1;
}
if (*info > 0) {
return 0;
}
ctrmm_("R", "U", "N", diag, &n1, &n2, &c_b1, &a[n1], n, a, n);
}
} else {
/* N is odd and TRANSR = 'C' */
if (lower) {
/* SRPA for LOWER, TRANSPOSE and N is odd */
/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */
ctrtri_("U", diag, &n1, a, &n1, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
ctrmm_("L", "U", "N", diag, &n1, &n2, &q__1, a, &n1, &a[n1 *
n1], &n1);
ctrtri_("L", diag, &n2, &a[1], &n1, info);
if (*info > 0) {
*info += n1;
}
if (*info > 0) {
return 0;
}
ctrmm_("R", "L", "C", diag, &n1, &n2, &c_b1, &a[1], &n1, &a[
n1 * n1], &n1);
} else {
/* SRPA for UPPER, TRANSPOSE and N is odd */
/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */
ctrtri_("U", diag, &n1, &a[n2 * n2], &n2, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
ctrmm_("R", "U", "C", diag, &n2, &n1, &q__1, &a[n2 * n2], &n2,
a, &n2);
ctrtri_("L", diag, &n2, &a[n1 * n2], &n2, info);
if (*info > 0) {
*info += n1;
}
if (*info > 0) {
return 0;
}
ctrmm_("L", "L", "N", diag, &n2, &n1, &c_b1, &a[n1 * n2], &n2,
a, &n2);
}
}
} else {
/* N is even */
if (normaltransr) {
/* N is even and TRANSR = 'N' */
if (lower) {
/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
i__1 = *n + 1;
ctrtri_("L", diag, &k, &a[1], &i__1, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
i__1 = *n + 1;
i__2 = *n + 1;
ctrmm_("R", "L", "N", diag, &k, &k, &q__1, &a[1], &i__1, &a[k
+ 1], &i__2);
i__1 = *n + 1;
ctrtri_("U", diag, &k, a, &i__1, info);
if (*info > 0) {
*info += k;
}
if (*info > 0) {
return 0;
}
i__1 = *n + 1;
i__2 = *n + 1;
ctrmm_("L", "U", "C", diag, &k, &k, &c_b1, a, &i__1, &a[k + 1]
, &i__2);
} else {
/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
i__1 = *n + 1;
ctrtri_("L", diag, &k, &a[k + 1], &i__1, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
i__1 = *n + 1;
i__2 = *n + 1;
ctrmm_("L", "L", "C", diag, &k, &k, &q__1, &a[k + 1], &i__1,
a, &i__2);
i__1 = *n + 1;
ctrtri_("U", diag, &k, &a[k], &i__1, info);
if (*info > 0) {
*info += k;
}
if (*info > 0) {
return 0;
}
i__1 = *n + 1;
i__2 = *n + 1;
ctrmm_("R", "U", "N", diag, &k, &k, &c_b1, &a[k], &i__1, a, &
i__2);
}
} else {
/* N is even and TRANSR = 'C' */
if (lower) {
/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
ctrtri_("U", diag, &k, &a[k], &k, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
ctrmm_("L", "U", "N", diag, &k, &k, &q__1, &a[k], &k, &a[k * (
k + 1)], &k);
ctrtri_("L", diag, &k, a, &k, info);
if (*info > 0) {
*info += k;
}
if (*info > 0) {
return 0;
}
ctrmm_("R", "L", "C", diag, &k, &k, &c_b1, a, &k, &a[k * (k +
1)], &k);
} else {
/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
ctrtri_("U", diag, &k, &a[k * (k + 1)], &k, info);
if (*info > 0) {
return 0;
}
q__1.r = -1.f, q__1.i = -0.f;
ctrmm_("R", "U", "C", diag, &k, &k, &q__1, &a[k * (k + 1)], &
k, a, &k);
ctrtri_("L", diag, &k, &a[k * k], &k, info);
if (*info > 0) {
*info += k;
}
if (*info > 0) {
return 0;
}
ctrmm_("L", "L", "N", diag, &k, &k, &c_b1, &a[k * k], &k, a, &
k);
}
}
}
return 0;
/* End of CTFTRI */
} /* ctftri_ */
/* Subroutine */ int ctrtri_(char *uplo, char *diag, integer *n, complex *a,
integer *lda, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, i__1, i__2, i__3[2], i__4, i__5;
complex q__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer j, jb, nb, nn;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), ctrsm_(char *, char *,
char *, char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrti2_(char *, char *, integer *, complex *,
integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical nounit;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRTRI computes the inverse of a complex upper or lower triangular */
/* matrix A. */
/* This is the Level 3 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* 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/output) COMPLEX array, dimension (LDA,N) */
/* On entry, 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. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
/* matrix is singular and its inverse can not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check for singularity if non-unit. */
if (nounit) {
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = *info + *info * a_dim1;
if (a[i__2].r == 0.f && a[i__2].i == 0.f) {
return 0;
}
/* L10: */
}
*info = 0;
}
/* Determine the block size for this environment. */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = uplo;
i__3[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
nb = ilaenv_(&c__1, "CTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
ctrti2_(uplo, diag, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute inverse of upper triangular matrix */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *n - j + 1;
jb = min(i__4,i__5);
/* Compute rows 1:j-1 of current block column */
i__4 = j - 1;
ctrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
c_b1, &a[a_offset], lda, &a[j * a_dim1 + 1], lda);
i__4 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
ctrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
q__1, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1],
lda);
/* Compute inverse of current diagonal block */
ctrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info);
/* L20: */
}
} else {
/* Compute inverse of lower triangular matrix */
nn = (*n - 1) / nb * nb + 1;
i__2 = -nb;
for (j = nn; i__2 < 0 ? j >= 1 : j <= 1; j += i__2) {
/* Computing MIN */
i__1 = nb, i__4 = *n - j + 1;
jb = min(i__1,i__4);
if (j + jb <= *n) {
/* Compute rows j+jb:n of current block column */
i__1 = *n - j - jb + 1;
ctrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
&c_b1, &a[j + jb + (j + jb) * a_dim1], lda, &a[j
+ jb + j * a_dim1], lda);
i__1 = *n - j - jb + 1;
q__1.r = -1.f, q__1.i = -0.f;
ctrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
&q__1, &a[j + j * a_dim1], lda, &a[j + jb + j *
a_dim1], lda);
}
/* Compute inverse of current diagonal block */
ctrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info);
/* L30: */
}
}
}
return 0;
/* End of CTRTRI */
} /* ctrtri_ */
/* Subroutine */ int chegst_(integer *itype, char *uplo, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer k, kb, nb;
extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), ctrsm_(char *, char *,
char *, char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int chegs2_(integer *, char *, integer *, complex
*, integer *, complex *, integer *, integer *), cher2k_(
char *, char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *, real *, complex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by CPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the Hermitian 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 transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by CPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGST", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "CHEGST", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
chegs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
} else {
/* Use blocked code */
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = min(i__3,nb);
/* Update the upper triangle of A(k:n,k:n) */
chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
if (k + kb <= *n) {
i__3 = *n - k - kb + 1;
ctrsm_("Left", uplo, "Conjugate transpose", "Non-unit"
, &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb,
&a[k + (k + kb) * a_dim1], lda);
i__3 = *n - k - kb + 1;
q__1.r = -.5f, q__1.i = -0.f;
chemm_("Left", uplo, &kb, &i__3, &q__1, &a[k + k *
a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
&c_b1, &a[k + (k + kb) * a_dim1], lda);
i__3 = *n - k - kb + 1;
q__1.r = -1.f, q__1.i = -0.f;
cher2k_(uplo, "Conjugate transpose", &i__3, &kb, &
q__1, &a[k + (k + kb) * a_dim1], lda, &b[k + (
k + kb) * b_dim1], ldb, &c_b18, &a[k + kb + (
k + kb) * a_dim1], lda)
;
i__3 = *n - k - kb + 1;
q__1.r = -.5f, q__1.i = -0.f;
chemm_("Left", uplo, &kb, &i__3, &q__1, &a[k + k *
a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
&c_b1, &a[k + (k + kb) * a_dim1], lda);
i__3 = *n - k - kb + 1;
ctrsm_("Right", uplo, "No transpose", "Non-unit", &kb,
&i__3, &c_b1, &b[k + kb + (k + kb) * b_dim1],
ldb, &a[k + (k + kb) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = min(i__3,nb);
/* Update the lower triangle of A(k:n,k:n) */
chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
if (k + kb <= *n) {
i__3 = *n - k - kb + 1;
ctrsm_("Right", uplo, "Conjugate transpose", "Non-un"
"it", &i__3, &kb, &c_b1, &b[k + k * b_dim1],
ldb, &a[k + kb + k * a_dim1], lda);
i__3 = *n - k - kb + 1;
q__1.r = -.5f, q__1.i = -0.f;
chemm_("Right", uplo, &i__3, &kb, &q__1, &a[k + k *
a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
c_b1, &a[k + kb + k * a_dim1], lda);
i__3 = *n - k - kb + 1;
q__1.r = -1.f, q__1.i = -0.f;
cher2k_(uplo, "No transpose", &i__3, &kb, &q__1, &a[k
+ kb + k * a_dim1], lda, &b[k + kb + k *
b_dim1], ldb, &c_b18, &a[k + kb + (k + kb) *
a_dim1], lda);
i__3 = *n - k - kb + 1;
q__1.r = -.5f, q__1.i = -0.f;
chemm_("Right", uplo, &i__3, &kb, &q__1, &a[k + k *
a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
c_b1, &a[k + kb + k * a_dim1], lda);
i__3 = *n - k - kb + 1;
ctrsm_("Left", uplo, "No transpose", "Non-unit", &
i__3, &kb, &c_b1, &b[k + kb + (k + kb) *
b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = min(i__3,nb);
/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
i__3 = k - 1;
ctrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
kb, &c_b1, &b[b_offset], ldb, &a[k * a_dim1 + 1],
lda);
i__3 = k - 1;
chemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
k * a_dim1 + 1], lda);
i__3 = k - 1;
cher2k_(uplo, "No transpose", &i__3, &kb, &c_b1, &a[k *
a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b18,
&a[a_offset], lda);
i__3 = k - 1;
chemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
k * a_dim1 + 1], lda);
i__3 = k - 1;
ctrmm_("Right", uplo, "Conjugate transpose", "Non-unit", &
i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb, &a[k *
a_dim1 + 1], lda);
chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
/* Computing MIN */
i__3 = *n - k + 1;
kb = min(i__3,nb);
/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
i__3 = k - 1;
ctrmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
i__3, &c_b1, &b[b_offset], ldb, &a[k + a_dim1],
lda);
i__3 = k - 1;
chemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
lda);
i__3 = k - 1;
cher2k_(uplo, "Conjugate transpose", &i__3, &kb, &c_b1, &
a[k + a_dim1], lda, &b[k + b_dim1], ldb, &c_b18, &
a[a_offset], lda);
i__3 = k - 1;
chemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
lda);
i__3 = k - 1;
ctrmm_("Left", uplo, "Conjugate transpose", "Non-unit", &
kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb, &a[k +
a_dim1], lda);
chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
k * b_dim1], ldb, info);
/* L40: */
}
}
}
}
return 0;
/* End of CHEGST */
} /* chegst_ */
/* Subroutine */
int cgehrd_(integer *n, integer *ilo, integer *ihi, complex * a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
integer i__, j;
complex t[4160] /* was [65][64] */
;
integer ib;
complex ei;
integer nb, nh, nx, iws;
extern /* Subroutine */
int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *);
integer nbmin, iinfo;
extern /* Subroutine */
int ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), cgehd2_( integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *), clahr2_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *), clarfb_(char *, char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
integer ldwork, lwkopt;
logical lquery;
/* -- 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 Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/* Computing MIN */
i__1 = 64;
i__2 = ilaenv_(&c__1, "CGEHRD", " ", n, ilo, ihi, &c_n1); // , expr subst
nb = min(i__1,i__2);
lwkopt = *n * nb;
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
lquery = *lwork == -1;
if (*n < 0)
{
*info = -1;
}
else if (*ilo < 1 || *ilo > max(1,*n))
{
*info = -2;
}
else if (*ihi < min(*ilo,*n) || *ihi > *n)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
else if (*lwork < max(1,*n) && ! lquery)
{
*info = -8;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGEHRD", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
i__1 = *ilo - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
tau[i__2].r = 0.f;
tau[i__2].i = 0.f; // , expr subst
/* L10: */
}
i__1 = *n - 1;
for (i__ = max(1,*ihi);
i__ <= i__1;
++i__)
{
i__2 = i__;
tau[i__2].r = 0.f;
tau[i__2].i = 0.f; // , expr subst
/* L20: */
}
/* Quick return if possible */
nh = *ihi - *ilo + 1;
if (nh <= 1)
{
work[1].r = 1.f;
work[1].i = 0.f; // , expr subst
return 0;
}
/* Determine the block size */
/* Computing MIN */
i__1 = 64;
i__2 = ilaenv_(&c__1, "CGEHRD", " ", n, ilo, ihi, &c_n1); // , expr subst
nb = min(i__1,i__2);
nbmin = 2;
iws = 1;
if (nb > 1 && nb < nh)
{
/* Determine when to cross over from blocked to unblocked code */
/* (last block is always handled by unblocked code) */
/* Computing MAX */
i__1 = nb;
i__2 = ilaenv_(&c__3, "CGEHRD", " ", n, ilo, ihi, &c_n1); // , expr subst
nx = max(i__1,i__2);
if (nx < nh)
{
/* Determine if workspace is large enough for blocked code */
iws = *n * nb;
if (*lwork < iws)
{
/* Not enough workspace to use optimal NB: determine the */
/* minimum value of NB, and reduce NB or force use of */
/* unblocked code */
/* Computing MAX */
i__1 = 2;
i__2 = ilaenv_(&c__2, "CGEHRD", " ", n, ilo, ihi, & c_n1); // , expr subst
nbmin = max(i__1,i__2);
if (*lwork >= *n * nbmin)
{
nb = *lwork / *n;
}
else
{
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh)
{
/* Use unblocked code below */
i__ = *ilo;
}
else
{
/* Use blocked code */
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo;
i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
i__ += i__2)
{
/* Computing MIN */
i__3 = nb;
i__4 = *ihi - i__; // , expr subst
ib = min(i__3,i__4);
/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
/* matrices V and T of the block reflector H = I - V*T*V**H */
/* which performs the reduction, and also the matrix Y = A*V*T */
clahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, & c__65, &work[1], &ldwork);
/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
/* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set */
/* to 1 */
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
ei.r = a[i__3].r;
ei.i = a[i__3].i; // , expr subst
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = 1.f;
a[i__3].i = 0.f; // , expr subst
i__3 = *ihi - i__ - ib + 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, & q__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &c_b2, &a[(i__ + ib) * a_dim1 + 1], lda);
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = ei.r;
a[i__3].i = ei.i; // , expr subst
/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
/* right */
i__3 = ib - 1;
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, & i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], & ldwork);
i__3 = ib - 2;
for (j = 0;
j <= i__3;
++j)
{
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
caxpy_(&i__, &q__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j + 1) * a_dim1 + 1], &c__1);
/* L30: */
}
/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
/* left */
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
clarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", & i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, & c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], & ldwork);
/* L40: */
}
}
/* Use unblocked code to reduce the rest of the matrix */
cgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1].r = (real) iws;
work[1].i = 0.f; // , expr subst
return 0;
/* End of CGEHRD */
}
/* Subroutine */
int cpftri_(char *transr, char *uplo, integer *n, complex *a, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer k, n1, n2;
logical normaltransr;
extern /* Subroutine */
int cherk_(char *, char *, integer *, integer *, real *, complex *, integer *, real *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *);
logical lower;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical nisodd;
extern /* Subroutine */
int clauum_(char *, integer *, complex *, integer *, integer *), ctftri_(char *, char *, char *, integer *, complex *, integer *);
/* -- 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
*info = 0;
normaltransr = lsame_(transr, "N");
lower = lsame_(uplo, "L");
if (! normaltransr && ! lsame_(transr, "C"))
{
*info = -1;
}
else if (! lower && ! lsame_(uplo, "U"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CPFTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
ctftri_(transr, uplo, "N", n, a, info);
if (*info > 0)
{
return 0;
}
/* If N is odd, set NISODD = .TRUE. */
/* If N is even, set K = N/2 and NISODD = .FALSE. */
if (*n % 2 == 0)
{
k = *n / 2;
nisodd = FALSE_;
}
else
{
nisodd = TRUE_;
}
/* Set N1 and N2 depending on LOWER */
if (lower)
{
n2 = *n / 2;
n1 = *n - n2;
}
else
{
n1 = *n / 2;
n2 = *n - n1;
}
/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */
/* inv(L)^C*inv(L). There are eight cases. */
if (nisodd)
{
/* N is odd */
if (normaltransr)
{
/* N is odd and TRANSR = 'N' */
if (lower)
{
/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */
/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */
/* T1 -> a(0), T2 -> a(n), S -> a(N1) */
clauum_("L", &n1, a, n, info);
cherk_("L", "C", &n1, &n2, &c_b12, &a[n1], n, &c_b12, a, n);
ctrmm_("L", "U", "N", "N", &n2, &n1, &c_b1, &a[*n], n, &a[n1], n);
clauum_("U", &n2, &a[*n], n, info);
}
else
{
/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */
/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */
/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */
clauum_("L", &n1, &a[n2], n, info);
cherk_("L", "N", &n1, &n2, &c_b12, a, n, &c_b12, &a[n2], n);
ctrmm_("R", "U", "C", "N", &n1, &n2, &c_b1, &a[n1], n, a, n);
clauum_("U", &n2, &a[n1], n, info);
}
}
else
{
/* N is odd and TRANSR = 'C' */
if (lower)
{
/* SRPA for LOWER, TRANSPOSE, and N is odd */
/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */
clauum_("U", &n1, a, &n1, info);
cherk_("U", "N", &n1, &n2, &c_b12, &a[n1 * n1], &n1, &c_b12, a, &n1);
ctrmm_("R", "L", "N", "N", &n1, &n2, &c_b1, &a[1], &n1, &a[n1 * n1], &n1);
clauum_("L", &n2, &a[1], &n1, info);
}
else
{
/* SRPA for UPPER, TRANSPOSE, and N is odd */
/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */
clauum_("U", &n1, &a[n2 * n2], &n2, info);
cherk_("U", "C", &n1, &n2, &c_b12, a, &n2, &c_b12, &a[n2 * n2] , &n2);
ctrmm_("L", "L", "C", "N", &n2, &n1, &c_b1, &a[n1 * n2], &n2, a, &n2);
clauum_("L", &n2, &a[n1 * n2], &n2, info);
}
}
}
else
{
/* N is even */
if (normaltransr)
{
/* N is even and TRANSR = 'N' */
if (lower)
{
/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
i__1 = *n + 1;
clauum_("L", &k, &a[1], &i__1, info);
i__1 = *n + 1;
i__2 = *n + 1;
cherk_("L", "C", &k, &k, &c_b12, &a[k + 1], &i__1, &c_b12, &a[ 1], &i__2);
i__1 = *n + 1;
i__2 = *n + 1;
ctrmm_("L", "U", "N", "N", &k, &k, &c_b1, a, &i__1, &a[k + 1], &i__2);
i__1 = *n + 1;
clauum_("U", &k, a, &i__1, info);
}
else
{
/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
i__1 = *n + 1;
clauum_("L", &k, &a[k + 1], &i__1, info);
i__1 = *n + 1;
i__2 = *n + 1;
cherk_("L", "N", &k, &k, &c_b12, a, &i__1, &c_b12, &a[k + 1], &i__2);
i__1 = *n + 1;
i__2 = *n + 1;
ctrmm_("R", "U", "C", "N", &k, &k, &c_b1, &a[k], &i__1, a, & i__2);
i__1 = *n + 1;
clauum_("U", &k, &a[k], &i__1, info);
}
}
else
{
/* N is even and TRANSR = 'C' */
if (lower)
{
/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */
/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */
/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1));
lda=k */
clauum_("U", &k, &a[k], &k, info);
cherk_("U", "N", &k, &k, &c_b12, &a[k * (k + 1)], &k, &c_b12, &a[k], &k);
ctrmm_("R", "L", "N", "N", &k, &k, &c_b1, a, &k, &a[k * (k + 1)], &k);
clauum_("L", &k, a, &k, info);
}
else
{
/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */
/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */
/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0));
lda=k */
clauum_("U", &k, &a[k * (k + 1)], &k, info);
cherk_("U", "C", &k, &k, &c_b12, a, &k, &c_b12, &a[k * (k + 1) ], &k);
ctrmm_("L", "L", "C", "N", &k, &k, &c_b1, &a[k * k], &k, a, & k);
clauum_("L", &k, &a[k * k], &k, info);
}
}
}
return 0;
/* End of CPFTRI */
}
/* Subroutine */ int clahr2_(integer *n, integer *k, integer *nb, complex *a,
integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
complex q__1;
/* Local variables */
integer i__;
complex ei;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemm_(char *, char *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *), cgemv_(char *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), ccopy_(integer *,
complex *, integer *, complex *, integer *), ctrmm_(char *, char *
, char *, char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), ctrmv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *), clarfg_(
integer *, complex *, complex *, integer *, complex *), clacgv_(
integer *, complex *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an unitary similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by CGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) COMPLEX array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) COMPLEX array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* 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(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's CLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = i__ - 1;
clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = *n - *k;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 +
i__ * a_dim1], &c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ctrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ctrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - 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[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ctrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
caxpy_(&i__2, &q__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
clarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
i__2 = *k + i__ + i__ * a_dim1;
ei.r = a[i__2].r, ei.i = a[i__2].i;
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
cscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ctrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
/* Compute Y(1:K,1:NB) */
clacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
ctrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
cgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2,
&y[y_offset], ldy);
}
ctrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of CLAHR2 */
} /* clahr2_ */
int main( int argc, char** argv )
{
obj_t a, c;
obj_t c_save;
obj_t alpha;
dim_t m, n;
dim_t p;
dim_t p_begin, p_end, p_inc;
int m_input, n_input;
ind_t ind;
num_t dt;
char dt_ch;
int r, n_repeats;
side_t side;
uplo_t uploa;
trans_t transa;
diag_t diaga;
f77_char f77_side;
f77_char f77_uploa;
f77_char f77_transa;
f77_char f77_diaga;
double dtime;
double dtime_save;
double gflops;
//bli_init();
//bli_error_checking_level_set( BLIS_NO_ERROR_CHECKING );
n_repeats = 3;
dt = DT;
ind = IND;
p_begin = P_BEGIN;
p_end = P_END;
p_inc = P_INC;
m_input = -1;
n_input = -1;
// Supress compiler warnings about unused variable 'ind'.
( void )ind;
#if 0
cntx_t* cntx;
ind_t ind_mod = ind;
// A hack to use 3m1 as 1mpb (with 1m as 1mbp).
if ( ind == BLIS_3M1 ) ind_mod = BLIS_1M;
// Initialize a context for the current induced method and datatype.
cntx = bli_gks_query_ind_cntx( ind_mod, dt );
// Set k to the kc blocksize for the current datatype.
k_input = bli_cntx_get_blksz_def_dt( dt, BLIS_KC, cntx );
#elif 1
//k_input = 256;
#endif
// Choose the char corresponding to the requested datatype.
if ( bli_is_float( dt ) ) dt_ch = 's';
else if ( bli_is_double( dt ) ) dt_ch = 'd';
else if ( bli_is_scomplex( dt ) ) dt_ch = 'c';
else dt_ch = 'z';
#if 0
side = BLIS_LEFT;
#else
side = BLIS_RIGHT;
#endif
#if 0
uploa = BLIS_LOWER;
#else
uploa = BLIS_UPPER;
#endif
transa = BLIS_NO_TRANSPOSE;
diaga = BLIS_NONUNIT_DIAG;
bli_param_map_blis_to_netlib_side( side, &f77_side );
bli_param_map_blis_to_netlib_uplo( uploa, &f77_uploa );
bli_param_map_blis_to_netlib_trans( transa, &f77_transa );
bli_param_map_blis_to_netlib_diag( diaga, &f77_diaga );
// Begin with initializing the last entry to zero so that
// matlab allocates space for the entire array once up-front.
for ( p = p_begin; p + p_inc <= p_end; p += p_inc ) ;
#ifdef BLIS
printf( "data_%s_%ctrmm_%s_blis", THR_STR, dt_ch, STR );
#else
printf( "data_%s_%ctrmm_%s", THR_STR, dt_ch, STR );
#endif
printf( "( %2lu, 1:3 ) = [ %4lu %4lu %7.2f ];\n",
( unsigned long )(p - p_begin + 1)/p_inc + 1,
( unsigned long )0,
( unsigned long )0, 0.0 );
for ( p = p_begin; p <= p_end; p += p_inc )
{
if ( m_input < 0 ) m = p / ( dim_t )abs(m_input);
else m = ( dim_t ) m_input;
if ( n_input < 0 ) n = p / ( dim_t )abs(n_input);
else n = ( dim_t ) n_input;
bli_obj_create( dt, 1, 1, 0, 0, &alpha );
if ( bli_does_trans( side ) )
bli_obj_create( dt, m, m, 0, 0, &a );
else
bli_obj_create( dt, n, n, 0, 0, &a );
bli_obj_create( dt, m, n, 0, 0, &c );
bli_obj_create( dt, m, n, 0, 0, &c_save );
bli_randm( &a );
bli_randm( &c );
bli_obj_set_struc( BLIS_TRIANGULAR, &a );
bli_obj_set_uplo( uploa, &a );
bli_obj_set_conjtrans( transa, &a );
bli_obj_set_diag( diaga, &a );
bli_randm( &a );
bli_mktrim( &a );
bli_setsc( (2.0/1.0), 0.0, &alpha );
bli_copym( &c, &c_save );
#if 0 //def BLIS
bli_ind_disable_all_dt( dt );
bli_ind_enable_dt( ind, dt );
#endif
dtime_save = DBL_MAX;
for ( r = 0; r < n_repeats; ++r )
{
bli_copym( &c_save, &c );
dtime = bli_clock();
#ifdef PRINT
bli_printm( "a", &a, "%4.1f", "" );
bli_printm( "c", &c, "%4.1f", "" );
#endif
#ifdef BLIS
bli_trmm( side,
&alpha,
&a,
&c );
#else
if ( bli_is_float( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
float* alphap = bli_obj_buffer( &alpha );
float* ap = bli_obj_buffer( &a );
float* cp = bli_obj_buffer( &c );
strmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
else if ( bli_is_double( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
double* alphap = bli_obj_buffer( &alpha );
double* ap = bli_obj_buffer( &a );
double* cp = bli_obj_buffer( &c );
dtrmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
else if ( bli_is_scomplex( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
scomplex* alphap = bli_obj_buffer( &alpha );
scomplex* ap = bli_obj_buffer( &a );
scomplex* cp = bli_obj_buffer( &c );
ctrmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
else if ( bli_is_dcomplex( dt ) )
{
f77_int mm = bli_obj_length( &c );
f77_int kk = bli_obj_width( &c );
f77_int lda = bli_obj_col_stride( &a );
f77_int ldc = bli_obj_col_stride( &c );
dcomplex* alphap = bli_obj_buffer( &alpha );
dcomplex* ap = bli_obj_buffer( &a );
dcomplex* cp = bli_obj_buffer( &c );
ztrmm_( &f77_side,
&f77_uploa,
&f77_transa,
&f77_diaga,
&mm,
&kk,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#ifdef PRINT
bli_printm( "c after", &c, "%4.1f", "" );
exit(1);
#endif
dtime_save = bli_clock_min_diff( dtime_save, dtime );
}
if ( bli_is_left( side ) )
gflops = ( 1.0 * m * m * n ) / ( dtime_save * 1.0e9 );
else
gflops = ( 1.0 * m * n * n ) / ( dtime_save * 1.0e9 );
if ( bli_is_complex( dt ) ) gflops *= 4.0;
#ifdef BLIS
printf( "data_%s_%ctrmm_%s_blis", THR_STR, dt_ch, STR );
#else
printf( "data_%s_%ctrmm_%s", THR_STR, dt_ch, STR );
#endif
printf( "( %2lu, 1:3 ) = [ %4lu %4lu %7.2f ];\n",
( unsigned long )(p - p_begin + 1)/p_inc + 1,
( unsigned long )m,
( unsigned long )n, gflops );
bli_obj_free( &alpha );
bli_obj_free( &a );
bli_obj_free( &c );
bli_obj_free( &c_save );
}
//bli_finalize();
return 0;
}
/* Subroutine */ int chegvx_(integer *itype, char *jobz, char *range, char *
uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
m, real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
real *rwork, integer *iwork, integer *ifail, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CHEGVX computes selected eigenvalues, and optionally, eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
B are assumed to be Hermitian and B is also positive definite.
Eigenvalues and eigenvectors can be selected by specifying either a
range of values or a range of indices for the desired eigenvalues.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found.
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found.
= 'I': the IL-th through IU-th eigenvalues will be found.
*
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, the lower triangle (if UPLO='L') or the upper
triangle (if UPLO='U') of A, including the diagonal, is
destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the Hermitian matrix B. If UPLO = 'U', the
leading N-by-N upper triangular part of B contains the
upper triangular part of the matrix B. If UPLO = 'L',
the leading N-by-N lower triangular part of B contains
the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
VL (input) REAL
VU (input) REAL
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) REAL
The absolute error tolerance for the eigenvalues.
An approximate eigenvalue is accepted as converged
when it is determined to lie in an interval [a,b]
of width less than or equal to
ABSTOL + EPS * max( |a|,|b| ) ,
where EPS is the machine precision. If ABSTOL is less than
or equal to zero, then EPS*|T| will be used in its place,
where |T| is the 1-norm of the tridiagonal matrix obtained
by reducing A to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*SLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*SLAMCH('S').
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) REAL array, dimension (N)
The first M elements contain the selected
eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, max(1,M))
If JOBZ = 'N', then Z is not referenced.
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix A
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
The eigenvectors are normalized as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = I.
If an eigenvector fails to converge, then that column of Z
contains the latest approximation to the eigenvector, and the
index of the eigenvector is returned in IFAIL.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for CHETRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) REAL array, dimension (7*N)
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: CPOTRF or CHEEVX returned an error code:
<= N: if INFO = i, CHEEVX failed to converge;
i eigenvectors failed to converge. Their indices
are stored in array IFAIL.
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
/* Local variables */
static integer lopt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static char trans[1];
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper, wantz;
static integer nb;
static logical alleig, indeig, valeig;
extern /* Subroutine */ int chegst_(integer *, char *, integer *, complex
*, integer *, complex *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *), cheevx_(
char *, char *, char *, integer *, complex *, integer *, real *,
real *, integer *, integer *, real *, integer *, real *, complex *
, integer *, complex *, integer *, real *, integer *, integer *,
integer *), cpotrf_(char *, integer *,
complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (alleig || valeig || indeig)) {
*info = -3;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (valeig && *n > 0) {
if (*vu <= *vl) {
*info = -11;
}
} else if (indeig && *il < 1) {
*info = -12;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -13;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -20;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 1) * *n;
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &rwork[1], &iwork[
1], &ifail[1], info);
lopt = work[1].r;
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
if (*info > 0) {
*m = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
ldb, &z__[z_offset], ldz);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
ldb, &z__[z_offset], ldz);
}
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CHEGVX */
} /* chegvx_ */
/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
complex *a, integer *lda, complex *x, integer *ldx, complex *b,
integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
integer j;
char c1[1], c2[2];
integer mb, nx;
logical gen, tri, qrs, sym, band;
char diag[1];
logical tran;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), chemm_(char *,
char *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *), chbmv_(char *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ctbmv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *,
complex *, integer *, complex *, complex *, integer *),
ctrmm_(char *, char *, char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
*, complex *, integer *), xerbla_(char *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARHS chooses a set of NRHS random solution vectors and sets */
/* up the right hand sides for the linear system */
/* op( A ) * X = B, */
/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
/* transpose of A). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The type of the complex matrix A. PATH may be given in any */
/* combination of upper and lower case. Valid paths include */
/* xGE: General m x n matrix */
/* xGB: General banded matrix */
/* xPO: Hermitian positive definite, 2-D storage */
/* xPP: Hermitian positive definite packed */
/* xPB: Hermitian positive definite banded */
/* xHE: Hermitian indefinite, 2-D storage */
/* xHP: Hermitian indefinite packed */
/* xHB: Hermitian indefinite banded */
/* xSY: Symmetric indefinite, 2-D storage */
/* xSP: Symmetric indefinite packed */
/* xSB: Symmetric indefinite banded */
/* xTR: Triangular */
/* xTP: Triangular packed */
/* xTB: Triangular banded */
/* xQR: General m x n matrix */
/* xLQ: General m x n matrix */
/* xQL: General m x n matrix */
/* xRQ: General m x n matrix */
/* where the leading character indicates the precision. */
/* XTYPE (input) CHARACTER*1 */
/* Specifies how the exact solution X will be determined: */
/* = 'N': New solution; generate a random X. */
/* = 'C': Computed; use value of X on entry. */
/* UPLO (input) CHARACTER*1 */
/* Used only if A is symmetric or triangular; specifies whether */
/* the upper or lower triangular part of the matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Used only if A is nonsymmetric; specifies the operation */
/* applied to the matrix A. */
/* = 'N': B := A * X */
/* = 'T': B := A**T * X */
/* = 'C': B := A**H * X */
/* 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. */
/* KL (input) INTEGER */
/* Used only if A is a band matrix; specifies the number of */
/* subdiagonals of A if A is a general band matrix or if A is */
/* symmetric or triangular and UPLO = 'L'; specifies the number */
/* of superdiagonals of A if A is symmetric or triangular and */
/* UPLO = 'U'. 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* Used only if A is a general band matrix or if A is */
/* triangular. */
/* If PATH = xGB, specifies the number of superdiagonals of A, */
/* and 0 <= KU <= N-1. */
/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
/* matrix has unit diagonal: */
/* = 1: matrix has non-unit diagonal (default) */
/* = 2: matrix has unit diagonal */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors in the system A*X = B. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The test matrix whose type is given by PATH. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If PATH = xGB, LDA >= KL+KU+1. */
/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/* Otherwise, LDA >= max(1,M). */
/* X (input or output) COMPLEX array, dimension (LDX,NRHS) */
/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/* the exact solution to the system of linear equations. */
/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/* with random values. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
/* B (output) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side vector(s) for the system of equations, */
/* computed from B = op(A) * X, where op(A) is determined by */
/* TRANS. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. If TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* CLATMS). Modified on exit. */
/* 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 .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S") || lsame_(path + 1, "H");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Complex precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
clarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate */
/* matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
cgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
x_offset], ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "HE")) {
/* Hermitian matrix, 2-D storage */
chemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
csymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
cgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
c__2, c2, "HB")) {
/* Hermitian matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
chbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "SB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
csbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "HP")) {
/* Hermitian matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
chpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
cspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L60: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices, */
/* KU = 1 => non-unit triangular */
/* KU = 2 => unit triangular */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
ctrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ctpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
c__1);
/* L70: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ctbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ 1], &c__1);
/* L80: */
}
} else {
/* If none of the above, set INFO = -1 and return */
*info = -1;
i__1 = -(*info);
xerbla_("CLARHS", &i__1);
}
return 0;
/* End of CLARHS */
} /* clarhs_ */
/* Subroutine */ int ctrtri_(char *uplo, char *diag, integer *n, complex *a,
integer *lda, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CTRTRI computes the inverse of a complex upper or lower triangular
matrix A.
This is the Level 3 BLAS version of the algorithm.
Arguments
=========
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/output) COMPLEX array, dimension (LDA,N)
On entry, 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.
On exit, the (triangular) inverse of the original matrix, in
the same storage format.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, A(i,i) is exactly zero. The triangular
matrix is singular and its inverse can not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, i__1, i__2, i__3[2], i__4, i__5;
complex q__1;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), ctrsm_(char *, char *,
char *, char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrti2_(char *, char *, integer *, complex *,
integer *, integer *);
static integer jb, nb, nn;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static logical nounit;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check for singularity if non-unit. */
if (nounit) {
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = a_subscr(*info, *info);
if (a[i__2].r == 0.f && a[i__2].i == 0.f) {
return 0;
}
/* L10: */
}
*info = 0;
}
/* Determine the block size for this environment.
Writing concatenation */
i__3[0] = 1, a__1[0] = uplo;
i__3[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
nb = ilaenv_(&c__1, "CTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)2);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
ctrti2_(uplo, diag, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute inverse of upper triangular matrix */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *n - j + 1;
jb = min(i__4,i__5);
/* Compute rows 1:j-1 of current block column */
i__4 = j - 1;
ctrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
c_b1, &a[a_offset], lda, &a_ref(1, j), lda);
i__4 = j - 1;
q__1.r = -1.f, q__1.i = 0.f;
ctrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
q__1, &a_ref(j, j), lda, &a_ref(1, j), lda);
/* Compute inverse of current diagonal block */
ctrti2_("Upper", diag, &jb, &a_ref(j, j), lda, info);
/* L20: */
}
} else {
/* Compute inverse of lower triangular matrix */
nn = (*n - 1) / nb * nb + 1;
i__2 = -nb;
for (j = nn; i__2 < 0 ? j >= 1 : j <= 1; j += i__2) {
/* Computing MIN */
i__1 = nb, i__4 = *n - j + 1;
jb = min(i__1,i__4);
if (j + jb <= *n) {
/* Compute rows j+jb:n of current block column */
i__1 = *n - j - jb + 1;
ctrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
&c_b1, &a_ref(j + jb, j + jb), lda, &a_ref(j + jb,
j), lda);
i__1 = *n - j - jb + 1;
q__1.r = -1.f, q__1.i = 0.f;
ctrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
&q__1, &a_ref(j, j), lda, &a_ref(j + jb, j), lda);
}
/* Compute inverse of current diagonal block */
ctrti2_("Lower", diag, &jb, &a_ref(j, j), lda, info);
/* L30: */
}
}
}
return 0;
/* End of CTRTRI */
} /* ctrtri_ */
/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
iwork, integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CHEGVD computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
B are assumed to be Hermitian and B is also positive definite.
If eigenvectors are desired, it uses a divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
matrix Z of eigenvectors. The eigenvectors are normalized
as follows:
if ITYPE = 1 or 2, Z**H*B*Z = I;
if ITYPE = 3, Z**H*inv(B)*Z = I.
If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
or the lower triangle (if UPLO='L') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the Hermitian matrix B. If UPLO = 'U', the
leading N-by-N upper triangular part of B contains the
upper triangular part of the matrix B. If UPLO = 'L',
the leading N-by-N lower triangular part of B contains
the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK.
If N <= 1, LWORK >= 1.
If JOBZ = 'N' and N > 1, LWORK >= N + 1.
If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace/output) REAL array, dimension (LRWORK)
On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
LRWORK (input) INTEGER
The dimension of the array RWORK.
If N <= 1, LRWORK >= 1.
If JOBZ = 'N' and N > 1, LRWORK >= N.
If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
If LRWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the RWORK array,
returns this value as the first entry of the RWORK array, and
no error message related to LRWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If N <= 1, LIWORK >= 1.
If JOBZ = 'N' and N > 1, LIWORK >= 1.
If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: CPOTRF or CHEEVD returned an error code:
<= N: if INFO = i, CHEEVD failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
real r__1, r__2;
/* Local variables */
static integer neig, lopt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static integer lwmin;
static char trans[1];
static integer liopt;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper;
static integer lropt;
static logical wantz;
extern /* Subroutine */ int cheevd_(char *, char *, integer *, complex *,
integer *, real *, complex *, integer *, real *, integer *,
integer *, integer *, integer *), chegst_(integer
*, char *, integer *, complex *, integer *, complex *, integer *,
integer *), xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *);
static integer liwmin, lrwmin;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
} else {
if (wantz) {
lwmin = (*n << 1) + *n * *n;
lrwmin = *n * 5 + 1 + (*n << 1) * *n;
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
}
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
if (*info == 0) {
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
1], lrwork, &iwork[1], liwork, info);
/* Computing MAX */
r__1 = (real) lopt, r__2 = work[1].r;
lopt = dmax(r__1,r__2);
/* Computing MAX */
r__1 = (real) lropt;
lropt = dmax(r__1,rwork[1]);
/* Computing MAX */
r__1 = (real) liopt, r__2 = (real) iwork[1];
liopt = dmax(r__1,r__2);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
return 0;
/* End of CHEGVD */
} /* chegvd_ */
/* Subroutine */ int chegv_(integer *itype, char *jobz, char *uplo, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
complex *work, integer *lwork, real *rwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CHEGV computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
Here A and B are assumed to be Hermitian and B is also
positive definite.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
matrix Z of eigenvectors. The eigenvectors are normalized
as follows:
if ITYPE = 1 or 2, Z**H*B*Z = I;
if ITYPE = 3, Z**H*inv(B)*Z = I.
If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
or the lower triangle (if UPLO='L') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the Hermitian positive definite matrix B.
If UPLO = 'U', the leading N-by-N upper triangular part of B
contains the upper triangular part of the matrix B.
If UPLO = 'L', the leading N-by-N lower triangular part of B
contains the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for CHETRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: CPOTRF or CHEEV returned an error code:
<= N: if INFO = i, CHEEV failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer neig;
extern /* Subroutine */ int cheev_(char *, char *, integer *, complex *,
integer *, real *, complex *, integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static char trans[1];
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper, wantz;
static integer nb;
extern /* Subroutine */ int chegst_(integer *, char *, integer *, complex
*, integer *, complex *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 1) * *n;
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
, info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CHEGV */
} /* chegv_ */
/* Subroutine */ int clarzb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, integer *l, complex *v,
integer *ldv, complex *t, integer *ldt, complex *c__, integer *ldc,
complex *work, integer *ldwork, ftnlen side_len, ftnlen trans_len,
ftnlen direct_len, ftnlen storev_len)
{
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1;
/* Local variables */
static integer i__, j, info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen), clacgv_(integer *,
complex *, integer *), xerbla_(char *, integer *, ftnlen);
static char transt[1];
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* December 1, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARZB applies a complex block reflector H or its transpose H**H */
/* to a complex distributed M-by-N C from the left or the right. */
/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply H or H' from the Left */
/* = 'R': apply H or H' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply H (No transpose) */
/* = 'C': apply H' (Conjugate transpose) */
/* DIRECT (input) CHARACTER*1 */
/* Indicates how H is formed from a product of elementary */
/* reflectors */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Indicates how the vectors which define the elementary */
/* reflectors are stored: */
/* = 'C': Columnwise (not supported yet) */
/* = 'R': Rowwise */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* K (input) INTEGER */
/* The order of the matrix T (= the number of elementary */
/* reflectors whose product defines the block reflector). */
/* L (input) INTEGER */
/* The number of columns of the matrix V containing the */
/* meaningful part of the Householder reflectors. */
/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
/* V (input) COMPLEX array, dimension (LDV,NV). */
/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */
/* T (input) COMPLEX array, dimension (LDT,K) */
/* The triangular K-by-K matrix T in the representation of the */
/* block reflector. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX array, dimension (LDWORK,K) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* If SIDE = 'L', LDWORK >= max(1,N); */
/* if SIDE = 'R', LDWORK >= max(1,M). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
/* Check for currently supported options */
info = 0;
if (! lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
info = -3;
} else if (! lsame_(storev, "R", (ftnlen)1, (ftnlen)1)) {
info = -4;
}
if (info != 0) {
i__1 = -info;
xerbla_("CLARZB", &i__1, (ftnlen)6);
return 0;
}
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
/* Form H * C or H' * C */
/* W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
/* L10: */
}
/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */
/* conjg( C( m-l+1:m, 1:n )' ) * V( 1:k, 1:l )' */
if (*l > 0) {
cgemm_("Transpose", "Conjugate transpose", n, k, l, &c_b1, &c__[*
m - *l + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b1, &
work[work_offset], ldwork, (ftnlen)9, (ftnlen)19);
}
/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */
ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[t_offset]
, ldt, &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (
ftnlen)1, (ftnlen)8);
/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = j + i__ * work_dim1;
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i -
work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L20: */
}
/* L30: */
}
/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
/* conjg( V( 1:k, 1:l )' ) * conjg( W( 1:n, 1:k )' ) */
if (*l > 0) {
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("Transpose", "Transpose", l, n, k, &q__1, &v[v_offset],
ldv, &work[work_offset], ldwork, &c_b1, &c__[*m - *l + 1
+ c_dim1], ldc, (ftnlen)9, (ftnlen)9);
}
} else if (lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
/* Form C * H or C * H' */
/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
/* L40: */
}
/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */
/* C( 1:m, n-l+1:n ) * conjg( V( 1:k, 1:l )' ) */
if (*l > 0) {
cgemm_("No transpose", "Transpose", m, k, l, &c_b1, &c__[(*n - *l
+ 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b1, &work[
work_offset], ldwork, (ftnlen)12, (ftnlen)9);
}
/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or */
/* W( 1:m, 1:k ) * conjg( T' ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k - j + 1;
clacgv_(&i__2, &t[j + j * t_dim1], &c__1);
/* L50: */
}
ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[t_offset],
ldt, &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (
ftnlen)1, (ftnlen)8);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k - j + 1;
clacgv_(&i__2, &t[j + j * t_dim1], &c__1);
/* L60: */
}
/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i -
work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
/* W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) ) */
i__1 = *l;
for (j = 1; j <= i__1; ++j) {
clacgv_(k, &v[j * v_dim1 + 1], &c__1);
/* L90: */
}
if (*l > 0) {
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "No transpose", m, l, k, &q__1, &work[
work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[(*n
- *l + 1) * c_dim1 + 1], ldc, (ftnlen)12, (ftnlen)12);
}
i__1 = *l;
for (j = 1; j <= i__1; ++j) {
clacgv_(k, &v[j * v_dim1 + 1], &c__1);
/* L100: */
}
}
return 0;
/* End of CLARZB */
} /* clarzb_ */
/* Subroutine */ int clauum_(char *uplo, integer *n, complex *a, integer *lda,
integer *info)
{
/* -- LAPACK auxiliary 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
=======
CLAUUM computes the product U * U' or L' * L, where the triangular
factor U or L is stored in the upper or lower triangular part of
the array A.
If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
overwriting the factor U in A.
If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
overwriting the factor L in A.
This is the blocked form of the algorithm, calling Level 3 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the triangular factor stored in the array A
is upper or lower triangular:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the triangular factor U or L. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the triangular factor U or L.
On exit, if UPLO = 'U', the upper triangle of A is
overwritten with the upper triangle of the product U * U';
if UPLO = 'L', the lower triangle of A is overwritten with
the lower triangle of the product L' * L.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
static real c_b21 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper;
extern /* Subroutine */ int clauu2_(char *, integer *, complex *, integer
*, integer *);
static integer ib, nb;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*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_("CLAUUM", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "CLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, 6L, 1L);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
clauu2_(uplo, n, &A(1,1), lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
i__2 = nb;
for (i = 1; nb < 0 ? i >= *n : i <= *n; i += nb) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i + 1;
ib = min(i__3,i__4);
i__3 = i - 1;
ctrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", &
i__3, &ib, &c_b1, &A(i,i), lda, &A(1,i), lda);
clauu2_("Upper", &ib, &A(i,i), lda, info);
if (i + ib <= *n) {
i__3 = i - 1;
i__4 = *n - i - ib + 1;
cgemm_("No transpose", "Conjugate transpose", &i__3, &ib,
&i__4, &c_b1, &A(1,i+ib), lda, &A(i,i+ib), lda, &c_b1, &A(1,i), lda);
i__3 = *n - i - ib + 1;
cherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &A(i,i+ib), lda, &c_b21, &A(i,i), lda);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__2 = *n;
i__1 = nb;
for (i = 1; nb < 0 ? i >= *n : i <= *n; i += nb) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i + 1;
ib = min(i__3,i__4);
i__3 = i - 1;
ctrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", &
ib, &i__3, &c_b1, &A(i,i), lda, &A(i,1), lda);
clauu2_("Lower", &ib, &A(i,i), lda, info);
if (i + ib <= *n) {
i__3 = i - 1;
i__4 = *n - i - ib + 1;
cgemm_("Conjugate transpose", "No transpose", &ib, &i__3,
&i__4, &c_b1, &A(i+ib,i), lda, &A(i+ib,1), lda, &c_b1, &A(i,1), lda);
i__3 = *n - i - ib + 1;
cherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21,
&A(i+ib,i), lda, &c_b21, &A(i,i), lda);
}
/* L20: */
}
}
}
return 0;
/* End of CLAUUM */
} /* clauum_ */
/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
real r__1, r__2;
/* Local variables */
integer lopt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
integer lwmin;
char trans[1];
integer liopt;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
logical upper;
integer lropt;
logical wantz;
extern /* Subroutine */ int cheevd_(char *, char *, integer *, complex *,
integer *, real *, complex *, integer *, real *, integer *,
integer *, integer *, integer *), chegst_(integer
*, char *, integer *, complex *, integer *, complex *, integer *,
integer *), xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *);
integer liwmin, lrwmin;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a complex generalized Hermitian-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
/* B are assumed to be Hermitian and B is also positive definite. */
/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
/* matrix Z of eigenvectors. The eigenvectors are normalized */
/* as follows: */
/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
/* or the lower triangle (if UPLO='L') of A, including the */
/* diagonal, is destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB, N) */
/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of B contains the */
/* upper triangular part of the matrix B. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of B contains */
/* the lower triangular part of the matrix B. */
/* On exit, if INFO <= N, the part of B containing the matrix is */
/* overwritten by the triangular factor U or L from the Cholesky */
/* factorization B = U**H*U or B = L*L**H. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= N + 1. */
/* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of the array RWORK. */
/* If N <= 1, LRWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If N <= 1, LIWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: CPOTRF or CHEEVD returned an error code: */
/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
/* failed to converge; i off-diagonal elements of an */
/* intermediate tridiagonal form did not converge to */
/* zero; */
/* if INFO = i and JOBZ = 'V', then the algorithm */
/* failed to compute an eigenvalue while working on */
/* the submatrix lying in rows and columns INFO/(N+1) */
/* through mod(INFO,N+1); */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* Modified so that no backsubstitution is performed if CHEEVD fails to */
/* converge (NEIG in old code could be greater than N causing out of */
/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
} else if (wantz) {
lwmin = (*n << 1) + *n * *n;
lrwmin = *n * 5 + 1 + (*n << 1) * *n;
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info == 0) {
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
1], lrwork, &iwork[1], liwork, info);
/* Computing MAX */
r__1 = (real) lopt, r__2 = work[1].r;
lopt = dmax(r__1,r__2);
/* Computing MAX */
r__1 = (real) lropt;
lropt = dmax(r__1,rwork[1]);
/* Computing MAX */
r__1 = (real) liopt, r__2 = (real) iwork[1];
liopt = dmax(r__1,r__2);
if (wantz && *info == 0) {
/* Backtransform eigenvectors to the original problem. */
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
ldb, &a[a_offset], lda);
}
}
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
return 0;
/* End of CHEGVD */
} /* chegvd_ */
/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, complex *v, integer *ldv,
complex *t, integer *ldt, complex *c__, integer *ldc, complex *work,
integer *ldwork)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLARFB applies a complex block reflector H or its transpose H' to a
complex M-by-N matrix C, from either the left or the right.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply H or H' from the Left
= 'R': apply H or H' from the Right
TRANS (input) CHARACTER*1
= 'N': apply H (No transpose)
= 'C': apply H' (Conjugate transpose)
DIRECT (input) CHARACTER*1
Indicates how H is formed from a product of elementary
reflectors
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Indicates how the vectors which define the elementary
reflectors are stored:
= 'C': Columnwise
= 'R': Rowwise
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
K (input) INTEGER
The order of the matrix T (= the number of elementary
reflectors whose product defines the block reflector).
V (input) COMPLEX array, dimension
(LDV,K) if STOREV = 'C'
(LDV,M) if STOREV = 'R' and SIDE = 'L'
(LDV,N) if STOREV = 'R' and SIDE = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
if STOREV = 'R', LDV >= K.
T (input) COMPLEX array, dimension (LDT,K)
The triangular K-by-K matrix T in the representation of the
block reflector.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) COMPLEX array, dimension (LDWORK,K)
LDWORK (input) INTEGER
The leading dimension of the array WORK.
If SIDE = 'L', LDWORK >= max(1,N);
if SIDE = 'R', LDWORK >= max(1,M).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), clacgv_(integer *,
complex *, integer *);
static char transt[1];
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N")) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 ) (first K rows)
( V2 )
where V1 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L10: */
}
/* W := W * V1 */
ctrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
if (*m > *k) {
/* W := W + C2'*V2 */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "No transpose", n, k, &i__1,
&c_b1, &c___ref(*k + 1, 1), ldc, &v_ref(*k + 1,
1), ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", &i__1, n, k,
&q__1, &v_ref(*k + 1, 1), ldv, &work[work_offset]
, ldwork, &c_b1, &c___ref(*k + 1, 1), ldc);
}
/* W := W * V1' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(j, i__);
i__4 = c___subscr(j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V = (C1*V1 + C2*V2) (stored in WORK)
W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
/* L40: */
}
/* W := W * V1 */
ctrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
if (*n > *k) {
/* W := W + C2 * V2 */
i__1 = *n - *k;
cgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1,
&c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1), ldv,
&c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ctrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (*n > *k) {
/* C2 := C2 - W * V2' */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", m, &i__1, k,
&q__1, &work[work_offset], ldwork, &v_ref(*k + 1,
1), ldv, &c_b1, &c___ref(1, *k + 1), ldc);
}
/* W := W * V1' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 )
( V2 ) (last K rows)
where V2 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j),
&c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L70: */
}
/* W := W * V2 */
ctrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1,
&v_ref(*m - *k + 1, 1), ldv, &work[work_offset],
ldwork);
if (*m > *k) {
/* W := W + C1'*V1 */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "No transpose", n, k, &i__1,
&c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C1 := C1 - V1 * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", &i__1, n, k,
&q__1, &v[v_offset], ldv, &work[work_offset],
ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k,
&c_b1, &v_ref(*m - *k + 1, 1), ldv, &work[work_offset]
, ldwork)
;
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(*m - *k + j, i__);
i__4 = c___subscr(*m - *k + j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V = (C1*V1 + C2*V2) (stored in WORK)
W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
, &c__1);
/* L100: */
}
/* W := W * V2 */
ctrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1,
&v_ref(*n - *k + 1, 1), ldv, &work[work_offset],
ldwork);
if (*n > *k) {
/* W := W + C1 * V1 */
i__1 = *n - *k;
cgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1,
&c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &
work[work_offset], ldwork)
;
}
/* W := W * T or W * T' */
ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (*n > *k) {
/* C1 := C1 - W * V1' */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", m, &i__1, k,
&q__1, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k,
&c_b1, &v_ref(*n - *k + 1, 1), ldv, &work[work_offset]
, ldwork)
;
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, *n - *k + j);
i__4 = c___subscr(i__, *n - *k + j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 V2 ) (V1: first K columns)
where V1 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L130: */
}
/* W := W * V1' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*m > *k) {
/* W := W + C2'*V2' */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "Conjugate transpose", n, k,
&i__1, &c_b1, &c___ref(*k + 1, 1), ldc, &v_ref(1,
*k + 1), ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (*m > *k) {
/* C2 := C2 - V2' * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, n, k, &q__1, &v_ref(1, *k + 1), ldv, &work[
work_offset], ldwork, &c_b1, &c___ref(*k + 1, 1),
ldc);
}
/* W := W * V1 */
ctrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(j, i__);
i__4 = c___subscr(j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
/* L160: */
}
/* W := W * V1' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*n > *k) {
/* W := W + C2 * V2' */
i__1 = *n - *k;
cgemm_("No transpose", "Conjugate transpose", m, k, &i__1,
&c_b1, &c___ref(1, *k + 1), ldc, &v_ref(1, *k +
1), ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ctrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (*n > *k) {
/* C2 := C2 - W * V2 */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "No transpose", m, &i__1, k, &q__1,
&work[work_offset], ldwork, &v_ref(1, *k + 1),
ldv, &c_b1, &c___ref(1, *k + 1), ldc);
}
/* W := W * V1 */
ctrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns)
where V2 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j),
&c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L190: */
}
/* W := W * V2' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k,
&c_b1, &v_ref(1, *m - *k + 1), ldv, &work[work_offset]
, ldwork)
;
if (*m > *k) {
/* W := W + C1'*V1' */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "Conjugate transpose", n, k,
&i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (*m > *k) {
/* C1 := C1 - V1' * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, n, k, &q__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ctrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1,
&v_ref(1, *m - *k + 1), ldv, &work[work_offset],
ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(*m - *k + j, i__);
i__4 = c___subscr(*m - *k + j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
, &c__1);
/* L220: */
}
/* W := W * V2' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k,
&c_b1, &v_ref(1, *n - *k + 1), ldv, &work[work_offset]
, ldwork)
;
if (*n > *k) {
/* W := W + C1 * V1' */
i__1 = *n - *k;
cgemm_("No transpose", "Conjugate transpose", m, k, &i__1,
&c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (*n > *k) {
/* C1 := C1 - W * V1 */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "No transpose", m, &i__1, k, &q__1,
&work[work_offset], ldwork, &v[v_offset], ldv, &
c_b1, &c__[c_offset], ldc)
;
}
/* W := W * V2 */
ctrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1,
&v_ref(1, *n - *k + 1), ldv, &work[work_offset],
ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, *n - *k + j);
i__4 = c___subscr(i__, *n - *k + j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of CLARFB */
} /* clarfb_ */
