int
f2c_zherk(char* uplo, char* trans, integer* N, integer* K,
doublereal* alpha,
doublecomplex* A, integer* lda,
doublereal* beta,
doublecomplex* C, integer* ldc)
{
zherk_(uplo, trans, N, K,
alpha, A, lda, beta, C, ldc);
return 0;
}
PyObject* rk(PyObject *self, PyObject *args)
{
double alpha;
PyArrayObject* a;
double beta;
PyArrayObject* c;
if (!PyArg_ParseTuple(args, "dOdO", &alpha, &a, &beta, &c))
return NULL;
int n = PyArray_DIMS(a)[0];
int k = PyArray_DIMS(a)[1];
for (int d = 2; d < PyArray_NDIM(a); d++)
k *= PyArray_DIMS(a)[d];
int ldc = PyArray_STRIDES(c)[0] / PyArray_STRIDES(c)[1];
if (PyArray_DESCR(a)->type_num == NPY_DOUBLE)
dsyrk_("u", "t", &n, &k,
&alpha, DOUBLEP(a), &k, &beta,
DOUBLEP(c), &ldc);
else
zherk_("u", "c", &n, &k,
&alpha, (void*)COMPLEXP(a), &k, &beta,
(void*)COMPLEXP(c), &ldc);
Py_RETURN_NONE;
}
/* Subroutine */ int zpftrf_(char *transr, char *uplo, integer *n,
doublecomplex *a, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer k, n1, n2;
logical normaltransr;
logical lower;
logical nisodd;
/* -- 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, -- */
/* Purpose */
/* ======= */
/* ZPFTRF computes the Cholesky factorization of a complex Hermitian */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U**H * U, if UPLO = 'U', or */
/* A = L * L**H, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the block version of the algorithm, calling Level 3 BLAS. */
/* 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': Upper triangle of RFP A is stored; */
/* = 'L': Lower triangle of RFP A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */
/* On entry, the Hermitian 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 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, if INFO = 0, the factor U or L from the Cholesky */
/* factorization RFP A = U**H*U or RFP A = L*L**H. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Notes on RFP Format: */
/* ============================ */
/* 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 */
/* ===================================================================== */
/* 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_("ZPFTRF", &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) */
zpotrf_("L", &n1, a, n, info);
if (*info > 0) {
return 0;
}
ztrsm_("R", "L", "C", "N", &n2, &n1, &c_b1, a, n, &a[n1], n);
zherk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b16, &a[*n],
n);
zpotrf_("U", &n2, &a[*n], n, info);
if (*info > 0) {
*info += n1;
}
} 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) */
zpotrf_("L", &n1, &a[n2], n, info);
if (*info > 0) {
return 0;
}
ztrsm_("L", "L", "N", "N", &n1, &n2, &c_b1, &a[n2], n, a, n);
zherk_("U", "C", &n2, &n1, &c_b15, a, n, &c_b16, &a[n1], n);
zpotrf_("U", &n2, &a[n1], n, info);
if (*info > 0) {
*info += n1;
}
}
} else {
/* N is odd and TRANSR = 'C' */
if (lower) {
/* SRPA for LOWER, TRANSPOSE and N is odd */
/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
zpotrf_("U", &n1, a, &n1, info);
if (*info > 0) {
return 0;
}
ztrsm_("L", "U", "C", "N", &n1, &n2, &c_b1, a, &n1, &a[n1 *
n1], &n1);
zherk_("L", "C", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b16, &
a[1], &n1);
zpotrf_("L", &n2, &a[1], &n1, info);
if (*info > 0) {
*info += n1;
}
} else {
/* SRPA for UPPER, TRANSPOSE and N is odd */
/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
zpotrf_("U", &n1, &a[n2 * n2], &n2, info);
if (*info > 0) {
return 0;
}
ztrsm_("R", "U", "N", "N", &n2, &n1, &c_b1, &a[n2 * n2], &n2,
a, &n2);
zherk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b16, &a[n1 * n2]
, &n2);
zpotrf_("L", &n2, &a[n1 * n2], &n2, info);
if (*info > 0) {
*info += n1;
}
}
}
} 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;
zpotrf_("L", &k, &a[1], &i__1, info);
if (*info > 0) {
return 0;
}
i__1 = *n + 1;
i__2 = *n + 1;
ztrsm_("R", "L", "C", "N", &k, &k, &c_b1, &a[1], &i__1, &a[k
+ 1], &i__2);
i__1 = *n + 1;
i__2 = *n + 1;
zherk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b16, a,
&i__2);
i__1 = *n + 1;
zpotrf_("U", &k, a, &i__1, info);
if (*info > 0) {
*info += k;
}
} 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;
zpotrf_("L", &k, &a[k + 1], &i__1, info);
if (*info > 0) {
return 0;
}
i__1 = *n + 1;
i__2 = *n + 1;
ztrsm_("L", "L", "N", "N", &k, &k, &c_b1, &a[k + 1], &i__1, a,
&i__2);
i__1 = *n + 1;
i__2 = *n + 1;
zherk_("U", "C", &k, &k, &c_b15, a, &i__1, &c_b16, &a[k], &
i__2);
i__1 = *n + 1;
zpotrf_("U", &k, &a[k], &i__1, info);
if (*info > 0) {
*info += k;
}
}
} 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 */
zpotrf_("U", &k, &a[k], &k, info);
if (*info > 0) {
return 0;
}
ztrsm_("L", "U", "C", "N", &k, &k, &c_b1, &a[k], &n1, &a[k * (
k + 1)], &k);
zherk_("L", "C", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b16,
a, &k);
zpotrf_("L", &k, a, &k, info);
if (*info > 0) {
*info += 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 */
zpotrf_("U", &k, &a[k * (k + 1)], &k, info);
if (*info > 0) {
return 0;
}
ztrsm_("R", "U", "N", "N", &k, &k, &c_b1, &a[k * (k + 1)], &k,
a, &k);
zherk_("L", "N", &k, &k, &c_b15, a, &k, &c_b16, &a[k * k], &k);
zpotrf_("L", &k, &a[k * k], &k, info);
if (*info > 0) {
*info += k;
}
}
}
}
return 0;
/* End of ZPFTRF */
} /* zpftrf_ */
/* Subroutine */ int zrqt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
r__, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZRQT02 tests ZUNGRQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the RQ factorization of an m-by-n matrix A, ZRQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by ZRQT01. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by ZGERQF. */
/* See ZGERQF for further details. */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* R (workspace) COMPLEX*16 array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.;
result[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
/* Copy the last k rows of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
zlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
zlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the last n rows of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
zungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
info);
/* Copy R(m-k+1:m,n-m+1:n) */
zlaset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
zlacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k
+ 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 +
(*n - *m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = zlange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZRQT02 */
} /* zrqt02_ */
/* Subroutine */ int zgrqts_(integer *m, integer *p, integer *n,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
r__, integer *lda, doublecomplex *taua, doublecomplex *b,
doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
static integer info;
static doublereal unfl, resid, anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *),
zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zggrqf_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zungqr_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zungrq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal ulp;
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1
#define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
#define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1
#define bf_ref(a_1,a_2) bf[bf_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZGRQTS tests ZGGRQF, which computes the GRQ factorization of an
M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The M-by-N matrix A.
AF (output) COMPLEX*16 array, dimension (LDA,N)
Details of the GRQ factorization of A and B, as returned
by ZGGRQF, see CGGRQF for further details.
Q (output) COMPLEX*16 array, dimension (LDA,N)
The N-by-N unitary matrix Q.
R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, R and Q.
LDA >= max(M,N).
TAUA (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by DGGQRC.
B (input) COMPLEX*16 array, dimension (LDB,N)
On entry, the P-by-N matrix A.
BF (output) COMPLEX*16 array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by ZGGRQF, see CGGRQF for further details.
Z (output) DOUBLE PRECISION array, dimension (LDB,P)
The P-by-P unitary matrix Z.
T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N))
BWK (workspace) COMPLEX*16 array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the arrays B, BF, Z and T.
LDB >= max(P,N).
TAUB (output) COMPLEX*16 array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by DGGRQF.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK, LWORK >= max(M,P,N)**2.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION array, dimension (4)
The test ratios:
RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
=====================================================================
Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--taua;
bwk_dim1 = *ldb;
bwk_offset = 1 + bwk_dim1 * 1;
bwk -= bwk_offset;
t_dim1 = *ldb;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
z_dim1 = *ldb;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1 * 1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--taub;
--work;
--rwork;
--result;
/* Function Body */
ulp = dlamch_("Precision");
unfl = dlamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Computing MAX */
d__1 = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = max(d__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
zggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q_ref(*n - *m + 1,
1), lda);
}
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
zlacpy_("Lower", &i__1, &i__2, &af_ref(2, *n - *m + 1), lda, &
q_ref(*n - *m + 2, *n - *m + 1), lda);
}
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, &
q_ref(2, 1), lda);
}
}
i__1 = min(*m,*n);
zungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*p > 1) {
i__1 = *p - 1;
zlacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb);
}
i__1 = min(*p,*n);
zungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
zlaset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
if (*m <= *n) {
zlacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n -
*m + 1), lda);
} else {
i__1 = *m - *n;
zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
zlacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n
+ 1, 1), lda);
}
/* Copy T */
zlaset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
zlacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
/* Compute R - A*Q' */
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", m, n, n, &z__1, &a[a_offset]
, lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);
/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.;
}
/* Compute T*Q - Z'*B */
zgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
&q[q_offset], lda, &z__1, &bwk[bwk_offset], ldb);
/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = zlange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (doublereal) max(i__1,*m) / bnorm / ulp;
} else {
result[2] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
zherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (doublereal) max(1,*n) / ulp;
/* Compute I - Z'*Z */
zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
&c_b35, &t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (doublereal) max(1,*p) / ulp;
return 0;
/* End of ZGRQTS */
} /* zgrqts_ */
/* Subroutine */ int zqlt01_(integer *m, integer *n, doublecomplex *a,
doublecomplex *af, doublecomplex *q, doublecomplex *l, integer *lda,
doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal resid, anorm;
static integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zgeqlf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal eps;
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZQLT01 tests ZGEQLF, which computes the QL factorization of an m-by-n
matrix A, and partially tests ZUNGQL which forms the m-by-m
orthogonal matrix Q.
ZQLT01 compares L with Q'*A, and checks that Q is orthogonal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The m-by-n matrix A.
AF (output) COMPLEX*16 array, dimension (LDA,N)
Details of the QL factorization of A, as returned by ZGEQLF.
See ZGEQLF for further details.
Q (output) COMPLEX*16 array, dimension (LDA,M)
The m-by-m orthogonal matrix Q.
L (workspace) COMPLEX*16 array, dimension (LDA,max(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and R.
LDA >= max(M,N).
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by ZGEQLF.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "ZGEQLF", (ftnlen)6, (ftnlen)6);
zgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
zlacpy_("Full", &i__1, n, &af[af_offset], lda, &q_ref(1, *m - *n
+ 1), lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(*m - *n + 1, 2), lda, &
q_ref(*m - *n + 1, *m - *n + 2), lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(1, *n - *m + 2), lda, &
q_ref(1, 2), lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)6, (ftnlen)6);
zungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
zlaset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
zlacpy_("Lower", n, n, &af_ref(*m - *n + 1, 1), lda, &l_ref(*m - *
n + 1, 1), lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
zlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
zlacpy_("Lower", m, m, &af_ref(1, *n - *m + 1), lda, &l_ref(1, *n
- *m + 1), lda);
}
}
/* Compute L - Q'*A */
zgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
zlaset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
zherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of ZQLT01 */
} /* zqlt01_ */
int main( int argc, char** argv )
{
obj_t a, c;
obj_t c_save;
obj_t alpha, beta;
dim_t m, k;
dim_t p;
dim_t p_begin, p_end, p_inc;
int m_input, k_input;
num_t dt;
int r, n_repeats;
uplo_t uploc;
trans_t transa;
f77_char f77_uploc;
f77_char f77_transa;
double dtime;
double dtime_save;
double gflops;
bli_init();
//bli_error_checking_level_set( BLIS_NO_ERROR_CHECKING );
n_repeats = 3;
#ifndef PRINT
p_begin = 200;
p_end = 2000;
p_inc = 200;
m_input = -1;
k_input = -1;
#else
p_begin = 16;
p_end = 16;
p_inc = 1;
m_input = 3;
k_input = 1;
#endif
#if 1
//dt = BLIS_FLOAT;
dt = BLIS_DOUBLE;
#else
//dt = BLIS_SCOMPLEX;
dt = BLIS_DCOMPLEX;
#endif
uploc = BLIS_LOWER;
//uploc = BLIS_UPPER;
transa = BLIS_NO_TRANSPOSE;
bli_param_map_blis_to_netlib_uplo( uploc, &f77_uploc );
bli_param_map_blis_to_netlib_trans( transa, &f77_transa );
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 ( k_input < 0 ) k = p * ( dim_t )abs(k_input);
else k = ( dim_t ) k_input;
bli_obj_create( dt, 1, 1, 0, 0, &alpha );
bli_obj_create( dt, 1, 1, 0, 0, &beta );
if ( bli_does_trans( transa ) )
bli_obj_create( dt, k, m, 0, 0, &a );
else
bli_obj_create( dt, m, k, 0, 0, &a );
bli_obj_create( dt, m, m, 0, 0, &c );
bli_obj_create( dt, m, m, 0, 0, &c_save );
bli_randm( &a );
bli_randm( &c );
bli_obj_set_struc( BLIS_HERMITIAN, c );
bli_obj_set_uplo( uploc, c );
bli_obj_set_conjtrans( transa, a );
bli_setsc( (2.0/1.0), 0.0, &alpha );
bli_setsc( -(1.0/1.0), 0.0, &beta );
bli_copym( &c, &c_save );
dtime_save = 1.0e9;
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_herk( &alpha,
&a,
&beta,
&c );
#else
if ( bli_is_float( dt ) )
{
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
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* betap = bli_obj_buffer( beta );
float* cp = bli_obj_buffer( c );
ssyrk_( &f77_uploc,
&f77_transa,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
else if ( bli_is_double( dt ) )
{
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
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* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsyrk_( &f77_uploc,
&f77_transa,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
else if ( bli_is_scomplex( dt ) )
{
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
float* alphap = bli_obj_buffer( alpha );
scomplex* ap = bli_obj_buffer( a );
float* betap = bli_obj_buffer( beta );
scomplex* cp = bli_obj_buffer( c );
cherk_( &f77_uploc,
&f77_transa,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
else if ( bli_is_dcomplex( dt ) )
{
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
double* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zherk_( &f77_uploc,
&f77_transa,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
#endif
#ifdef PRINT
bli_printm( "c after", &c, "%4.1f", "" );
exit(1);
#endif
dtime_save = bli_clock_min_diff( dtime_save, dtime );
}
gflops = ( 1.0 * m * k * m ) / ( dtime_save * 1.0e9 );
if ( bli_is_complex( dt ) ) gflops *= 4.0;
#ifdef BLIS
printf( "data_herk_blis" );
#else
printf( "data_herk_%s", BLAS );
#endif
printf( "( %2lu, 1:4 ) = [ %4lu %4lu %10.3e %6.3f ];\n",
( unsigned long )(p - p_begin + 1)/p_inc + 1,
( unsigned long )m,
( unsigned long )k, dtime_save, gflops );
bli_obj_free( &alpha );
bli_obj_free( &beta );
bli_obj_free( &a );
bli_obj_free( &c );
bli_obj_free( &c_save );
}
bli_finalize();
return 0;
}
/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, 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
=======
ZPBTRF computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**H*U or A = L*L**H of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
Contributed by
Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b21 = -1.;
static doublereal c_b22 = 1.;
static integer c__33 = 33;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1;
/* Local variables */
static doublecomplex work[1056] /* was [33][32] */;
static integer i__, j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
static integer i2, i3;
extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zpbtf2_(char *, integer *, integer *, doublecomplex *, integer *,
integer *);
static integer ib, nb, ii, jj;
extern /* Subroutine */ int zpotf2_(char *, integer *, doublecomplex *,
integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define work_subscr(a_1,a_2) (a_2)*33 + a_1 - 34
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "ZPBTRF", uplo, n, kd, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
/* The block size must not exceed the semi-bandwidth KD, and must not
exceed the limit set by the size of the local array WORK. */
nb = min(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
zpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a Hermitian band
matrix, given the upper triangle of the matrix in band
storage.
Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0., work[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
/* Process the band matrix one diagonal block at a time. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab_ref(*kd + 1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11 A12 A13
A22 A23
A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A12, A22 and
A23 are empty if IB = KD. The upper triangle of A13
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i2, &c_b1, &ab_ref(*kd + 1, i__),
&i__3, &ab_ref(*kd + 1 - ib, i__ + ib), &
i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i2, &ib, &
c_b21, &ab_ref(*kd + 1 - ib, i__ + ib), &i__3,
&c_b22, &ab_ref(*kd + 1, i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 into the work array. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = work_subscr(ii, jj);
i__6 = ab_subscr(ii - jj + 1, jj + i__ + *kd
- 1);
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L30: */
}
/* L40: */
}
/* Update A13 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i3, &c_b1, &ab_ref(*kd + 1, i__),
&i__3, work, &c__33);
/* Update A23 */
if (i2 > 0) {
z__1.r = -1., z__1.i = 0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("Conjugate transpose", "No transpose", &i2,
&i3, &ib, &z__1, &ab_ref(*kd + 1 - ib,
i__ + ib), &i__3, work, &c__33, &c_b1, &
ab_ref(ib + 1, i__ + *kd), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i3, &ib, &
c_b21, work, &c__33, &c_b22, &ab_ref(*kd + 1,
i__ + *kd), &i__3);
/* Copy the lower triangle of A13 back into place. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ab_subscr(ii - jj + 1, jj + i__ + *kd
- 1);
i__6 = work_subscr(ii, jj);
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L50: */
}
/* L60: */
}
}
}
/* L70: */
}
} else {
/* Compute the Cholesky factorization of a Hermitian band
matrix, given the lower triangle of the matrix in band
storage.
Zero the lower triangle of the work array. */
i__2 = nb;
for (j = 1; j <= i__2; ++j) {
i__1 = nb;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0., work[i__3].i = 0.;
/* L80: */
}
/* L90: */
}
/* Process the band matrix one diagonal block at a time. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab_ref(1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11
A21 A22
A31 A32 A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A21, A22 and
A32 are empty if IB = KD. The lower triangle of A31
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A21 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i2, &ib, &c_b1, &ab_ref(1, i__), &
i__3, &ab_ref(ib + 1, i__), &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Lower", "No transpose", &i2, &ib, &c_b21, &
ab_ref(ib + 1, i__), &i__3, &c_b22, &ab_ref(1,
i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the upper triangle of A31 into the work array. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = work_subscr(ii, jj);
i__6 = ab_subscr(*kd + 1 - jj + ii, jj + i__
- 1);
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L100: */
}
/* L110: */
}
/* Update A31 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i3, &ib, &c_b1, &ab_ref(1, i__), &
i__3, work, &c__33);
/* Update A32 */
if (i2 > 0) {
z__1.r = -1., z__1.i = 0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("No transpose", "Conjugate transpose", &i3,
&i2, &ib, &z__1, work, &c__33, &ab_ref(
ib + 1, i__), &i__3, &c_b1, &ab_ref(*kd +
1 - ib, i__ + ib), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Lower", "No transpose", &i3, &ib, &c_b21,
work, &c__33, &c_b22, &ab_ref(1, i__ + *kd), &
i__3);
/* Copy the upper triangle of A31 back into place. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = ab_subscr(*kd + 1 - jj + ii, jj + i__
- 1);
i__6 = work_subscr(ii, jj);
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L120: */
}
/* L130: */
}
}
}
/* L140: */
}
}
}
return 0;
L150:
return 0;
/* End of ZPBTRF */
} /* zpbtrf_ */
/* Subroutine */ int zhfrk_(char *transr, char *uplo, char *trans, integer *n,
integer *k, doublereal *alpha, doublecomplex *a, integer *lda,
doublereal *beta, doublecomplex *c__)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Local variables */
integer j, n1, n2, nk, info;
doublecomplex cbeta;
logical normaltransr;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
integer nrowa;
logical lower;
doublecomplex calpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
logical nisodd, notrans;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
/* -- 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 */
/* ======= */
/* Level 3 BLAS like routine for C in RFP Format. */
/* ZHFRK performs one of the Hermitian rank--k operations */
/* C := alpha*A*conjg( A' ) + beta*C, */
/* or */
/* C := alpha*conjg( A' )*A + beta*C, */
/* where alpha and beta are real scalars, C is an n--by--n Hermitian */
/* matrix and A is an n--by--k matrix in the first case and a k--by--n */
/* matrix in the second case. */
/* Arguments */
/* ========== */
/* TRANSR (input) CHARACTER. */
/* = 'N': The Normal Form of RFP A is stored; */
/* = 'C': The Conjugate-transpose Form of RFP A is stored. */
/* UPLO - (input) CHARACTER. */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the array C is to be referenced as */
/* follows: */
/* UPLO = 'U' or 'u' Only the upper triangular part of C */
/* is to be referenced. */
/* UPLO = 'L' or 'l' Only the lower triangular part of C */
/* is to be referenced. */
/* Unchanged on exit. */
/* TRANS - (input) CHARACTER. */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
/* Unchanged on exit. */
/* N - (input) INTEGER. */
/* On entry, N specifies the order of the matrix C. N must be */
/* at least zero. */
/* Unchanged on exit. */
/* K - (input) INTEGER. */
/* On entry with TRANS = 'N' or 'n', K specifies the number */
/* of columns of the matrix A, and on entry with */
/* TRANS = 'C' or 'c', K specifies the number of rows of the */
/* matrix A. K must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - (input) DOUBLE PRECISION. */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - (input) COMPLEX*16 array of DIMENSION ( LDA, ka ), where KA */
/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */
/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */
/* the array A must contain the matrix A, otherwise the leading */
/* K--by--N part of the array A must contain the matrix A. */
/* Unchanged on exit. */
/* LDA - (input) INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. When TRANS = 'N' or 'n' */
/* then LDA must be at least max( 1, n ), otherwise LDA must */
/* be at least max( 1, k ). */
/* Unchanged on exit. */
/* BETA - (input) DOUBLE PRECISION. */
/* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */
/* C - (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ). */
/* On entry, the matrix A in RFP Format. RFP Format is */
/* described by TRANSR, UPLO and N. Note that the imaginary */
/* parts of the diagonal elements need not be set, they are */
/* assumed to be zero, and on exit they are set to zero. */
/* Arguments */
/* ========== */
/* .. */
/* .. 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;
--c__;
/* Function Body */
info = 0;
normaltransr = lsame_(transr, "N");
lower = lsame_(uplo, "L");
notrans = lsame_(trans, "N");
if (notrans) {
nrowa = *n;
} else {
nrowa = *k;
}
if (! normaltransr && ! lsame_(transr, "C")) {
info = -1;
} else if (! lower && ! lsame_(uplo, "U")) {
info = -2;
} else if (! notrans && ! lsame_(trans, "C")) {
info = -3;
} else if (*n < 0) {
info = -4;
} else if (*k < 0) {
info = -5;
} else if (*lda < max(1,nrowa)) {
info = -8;
}
if (info != 0) {
i__1 = -info;
xerbla_("ZHFRK ", &i__1);
return 0;
}
/* Quick return if possible. */
/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
/* done (it is in ZHERK for example) and left in the general case. */
if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
return 0;
}
if (*alpha == 0. && *beta == 0.) {
i__1 = *n * (*n + 1) / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
c__[i__2].r = 0., c__[i__2].i = 0.;
}
return 0;
}
z__1.r = *alpha, z__1.i = 0.;
calpha.r = z__1.r, calpha.i = z__1.i;
z__1.r = *beta, z__1.i = 0.;
cbeta.r = z__1.r, cbeta.i = z__1.i;
/* C is N-by-N. */
/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
/* If N is even, NISODD = .FALSE., and NK. */
if (*n % 2 == 0) {
nisodd = FALSE_;
nk = *n / 2;
} else {
nisodd = TRUE_;
if (lower) {
n2 = *n / 2;
n1 = *n - n2;
} else {
n1 = *n / 2;
n2 = *n - n1;
}
}
if (nisodd) {
/* N is odd */
if (normaltransr) {
/* N is odd and TRANSR = 'N' */
if (lower) {
/* N is odd, TRANSR = 'N', and UPLO = 'L' */
if (notrans) {
/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], n);
zherk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
beta, &c__[*n + 1], n);
zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[n1 + 1],
n);
} else {
/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], n);
zherk_("U", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
lda, beta, &c__[*n + 1], n)
;
zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[n1 + 1], n);
}
} else {
/* N is odd, TRANSR = 'N', and UPLO = 'U' */
if (notrans) {
/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 + 1], n);
zherk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda,
beta, &c__[n1 + 1], n);
zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[n2 + a_dim1], lda, &cbeta, &c__[1], n);
} else {
/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 + 1], n);
zherk_("U", "C", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda,
beta, &c__[n1 + 1], n);
zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[n2 * a_dim1 + 1], lda, &cbeta, &c__[1], n);
}
}
} else {
/* N is odd, and TRANSR = 'C' */
if (lower) {
/* N is odd, TRANSR = 'C', and UPLO = 'L' */
if (notrans) {
/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], &n1);
zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
beta, &c__[2], &n1);
zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[n1 + 1 + a_dim1], lda, &cbeta, &c__[n1 *
n1 + 1], &n1);
} else {
/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[1], &n1);
zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
lda, beta, &c__[2], &n1);
zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
lda, &a[(n1 + 1) * a_dim1 + 1], lda, &cbeta, &c__[
n1 * n1 + 1], &n1);
}
} else {
/* N is odd, TRANSR = 'C', and UPLO = 'U' */
if (notrans) {
/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 * n2 + 1], &n2);
zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
beta, &c__[n1 * n2 + 1], &n2);
zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &n2);
} else {
/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[n2 * n2 + 1], &n2);
zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
lda, beta, &c__[n1 * n2 + 1], &n2);
zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[1], &n2);
}
}
}
} else {
/* N is even */
if (normaltransr) {
/* N is even and TRANSR = 'N' */
if (lower) {
/* N is even, TRANSR = 'N', and UPLO = 'L' */
if (notrans) {
/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
i__1 = *n + 1;
zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[2], &i__1);
i__1 = *n + 1;
zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[1], &i__1);
i__1 = *n + 1;
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[nk + 2],
&i__1);
} else {
/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
i__1 = *n + 1;
zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[2], &i__1);
i__1 = *n + 1;
zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[1], &i__1);
i__1 = *n + 1;
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[nk + 2], &i__1);
}
} else {
/* N is even, TRANSR = 'N', and UPLO = 'U' */
if (notrans) {
/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
i__1 = *n + 1;
zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 2], &i__1);
i__1 = *n + 1;
zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[nk + 1], &i__1);
i__1 = *n + 1;
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[1], &
i__1);
} else {
/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
i__1 = *n + 1;
zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 2], &i__1);
i__1 = *n + 1;
zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[nk + 1], &i__1);
i__1 = *n + 1;
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
1], &i__1);
}
}
} else {
/* N is even, and TRANSR = 'C' */
if (lower) {
/* N is even, TRANSR = 'C', and UPLO = 'L' */
if (notrans) {
/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 1], &nk);
zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[1], &nk);
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[(nk +
1) * nk + 1], &nk);
} else {
/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk + 1], &nk);
zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[1], &nk);
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
(nk + 1) * nk + 1], &nk);
}
} else {
/* N is even, TRANSR = 'C', and UPLO = 'U' */
if (notrans) {
/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk * (nk + 1) + 1], &nk);
zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
beta, &c__[nk * nk + 1], &nk);
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &nk);
} else {
/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
&c__[nk * (nk + 1) + 1], &nk);
zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
lda, beta, &c__[nk * nk + 1], &nk);
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
c__[1], &nk);
}
}
}
}
return 0;
/* End of ZHFRK */
} /* zhfrk_ */
/* Subroutine */
int zhfrk_(char *transr, char *uplo, char *trans, integer *n, integer *k, doublereal *alpha, doublecomplex *a, integer *lda, doublereal *beta, doublecomplex *c__)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Local variables */
integer j, n1, n2, nk, info;
doublecomplex cbeta;
logical normaltransr;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zherk_(char *, char *, integer *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *);
integer nrowa;
logical lower;
doublecomplex calpha;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical nisodd, notrans;
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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;
--c__;
/* Function Body */
info = 0;
normaltransr = lsame_(transr, "N");
lower = lsame_(uplo, "L");
notrans = lsame_(trans, "N");
if (notrans)
{
nrowa = *n;
}
else
{
nrowa = *k;
}
if (! normaltransr && ! lsame_(transr, "C"))
{
info = -1;
}
else if (! lower && ! lsame_(uplo, "U"))
{
info = -2;
}
else if (! notrans && ! lsame_(trans, "C"))
{
info = -3;
}
else if (*n < 0)
{
info = -4;
}
else if (*k < 0)
{
info = -5;
}
else if (*lda < max(1,nrowa))
{
info = -8;
}
if (info != 0)
{
i__1 = -info;
xerbla_("ZHFRK ", &i__1);
return 0;
}
/* Quick return if possible. */
/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
/* done (it is in ZHERK for example) and left in the general case. */
if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.)
{
return 0;
}
if (*alpha == 0. && *beta == 0.)
{
i__1 = *n * (*n + 1) / 2;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
c__[i__2].r = 0.;
c__[i__2].i = 0.; // , expr subst
}
return 0;
}
z__1.r = *alpha;
z__1.i = 0.; // , expr subst
calpha.r = z__1.r;
calpha.i = z__1.i; // , expr subst
z__1.r = *beta;
z__1.i = 0.; // , expr subst
cbeta.r = z__1.r;
cbeta.i = z__1.i; // , expr subst
/* C is N-by-N. */
/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
/* If N is even, NISODD = .FALSE., and NK. */
if (*n % 2 == 0)
{
nisodd = FALSE_;
nk = *n / 2;
}
else
{
nisodd = TRUE_;
if (lower)
{
n2 = *n / 2;
n1 = *n - n2;
}
else
{
n1 = *n / 2;
n2 = *n - n1;
}
}
if (nisodd)
{
/* N is odd */
if (normaltransr)
{
/* N is odd and TRANSR = 'N' */
if (lower)
{
/* N is odd, TRANSR = 'N', and UPLO = 'L' */
if (notrans)
{
/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[1], n);
zherk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, beta, &c__[*n + 1], n);
zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1] , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[n1 + 1], n);
}
else
{
/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[1], n);
zherk_("U", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[*n + 1], n) ;
zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) * a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & c__[n1 + 1], n);
}
}
else
{
/* N is odd, TRANSR = 'N', and UPLO = 'U' */
if (notrans)
{
/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[n2 + 1], n);
zherk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda, beta, &c__[n1 + 1], n);
zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1], lda, &a[n2 + a_dim1], lda, &cbeta, &c__[1], n);
}
else
{
/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[n2 + 1], n);
zherk_("U", "C", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda, beta, &c__[n1 + 1], n);
zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1], lda, &a[n2 * a_dim1 + 1], lda, &cbeta, &c__[1], n);
}
}
}
else
{
/* N is odd, and TRANSR = 'C' */
if (lower)
{
/* N is odd, TRANSR = 'C', and UPLO = 'L' */
if (notrans)
{
/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[1], &n1);
zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, beta, &c__[2], &n1);
zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1], lda, &a[n1 + 1 + a_dim1], lda, &cbeta, &c__[n1 * n1 + 1], &n1);
}
else
{
/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[1], &n1);
zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[2], &n1);
zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1], lda, &a[(n1 + 1) * a_dim1 + 1], lda, &cbeta, &c__[ n1 * n1 + 1], &n1);
}
}
else
{
/* N is odd, TRANSR = 'C', and UPLO = 'U' */
if (notrans)
{
/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[n2 * n2 + 1], &n2);
zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n2 + 1], &n2);
zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1] , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &n2);
}
else
{
/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[n2 * n2 + 1], &n2);
zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 * n2 + 1], &n2);
zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) * a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & c__[1], &n2);
}
}
}
}
else
{
/* N is even */
if (normaltransr)
{
/* N is even and TRANSR = 'N' */
if (lower)
{
/* N is even, TRANSR = 'N', and UPLO = 'L' */
if (notrans)
{
/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
i__1 = *n + 1;
zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[2], &i__1);
i__1 = *n + 1;
zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1);
i__1 = *n + 1;
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1] , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[nk + 2], &i__1);
}
else
{
/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
i__1 = *n + 1;
zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[2], &i__1);
i__1 = *n + 1;
zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], &i__1);
i__1 = *n + 1;
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) * a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & c__[nk + 2], &i__1);
}
}
else
{
/* N is even, TRANSR = 'N', and UPLO = 'U' */
if (notrans)
{
/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
i__1 = *n + 1;
zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], &i__1);
i__1 = *n + 1;
zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, beta, &c__[nk + 1], &i__1);
i__1 = *n + 1;
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1], lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[1], & i__1);
}
else
{
/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
i__1 = *n + 1;
zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], &i__1);
i__1 = *n + 1;
zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[nk + 1], &i__1);
i__1 = *n + 1;
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1], lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[ 1], &i__1);
}
}
}
else
{
/* N is even, and TRANSR = 'C' */
if (lower)
{
/* N is even, TRANSR = 'C', and UPLO = 'L' */
if (notrans)
{
/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[nk + 1], &nk);
zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, beta, &c__[1], &nk);
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1], lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[(nk + 1) * nk + 1], &nk);
}
else
{
/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[nk + 1], &nk);
zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], &nk);
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1], lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[ (nk + 1) * nk + 1], &nk);
}
}
else
{
/* N is even, TRANSR = 'C', and UPLO = 'U' */
if (notrans)
{
/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[nk * (nk + 1) + 1], &nk);
zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, beta, &c__[nk * nk + 1], &nk);
zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1] , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &nk);
}
else
{
/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, &c__[nk * (nk + 1) + 1], &nk);
zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[nk * nk + 1], &nk);
zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) * a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & c__[1], &nk);
}
}
}
}
return 0;
/* End of ZHFRK */
}
/* Subroutine */ int zqlt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal resid, anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal eps;
#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)]
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZQLT02 tests ZUNGQL, which generates an m-by-n matrix Q with
orthonornmal columns that is defined as the product of k elementary
reflectors.
Given the QL factorization of an m-by-n matrix A, ZQLT02 generates
the orthogonal matrix Q defined by the factorization of the last k
columns of A; it compares L(m-n+1:m,n-k+1:n) with
Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The m-by-n matrix A which was factorized by ZQLT01.
AF (input) COMPLEX*16 array, dimension (LDA,N)
Details of the QL factorization of A, as returned by ZGEQLF.
See ZGEQLF for further details.
Q (workspace) COMPLEX*16 array, dimension (LDA,N)
L (workspace) COMPLEX*16 array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= M.
TAU (input) COMPLEX*16 array, dimension (N)
The scalar factors of the elementary reflectors corresponding
to the QL factorization in AF.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Quick return if possible
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.;
result[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
/* Copy the last k columns of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *m) {
i__1 = *m - *k;
zlacpy_("Full", &i__1, k, &af_ref(1, *n - *k + 1), lda, &q_ref(1, *n
- *k + 1), lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(*m - *k + 1, *n - *k + 2), lda,
&q_ref(*m - *k + 1, *n - *k + 2), lda);
}
/* Generate the last n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)6, (ftnlen)6);
zungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
info);
/* Copy L(m-n+1:m,n-k+1:n) */
zlaset_("Full", n, k, &c_b9, &c_b9, &l_ref(*m - *n + 1, *n - *k + 1), lda);
zlacpy_("Lower", k, k, &af_ref(*m - *k + 1, *n - *k + 1), lda, &l_ref(*m
- *k + 1, *n - *k + 1), lda);
/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
zgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[
q_offset], lda, &a_ref(1, *n - *k + 1), lda, &c_b15, &l_ref(*m - *
n + 1, *n - *k + 1), lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = zlange_("1", m, k, &a_ref(1, *n - *k + 1), lda, &rwork[1]);
resid = zlange_("1", n, k, &l_ref(*m - *n + 1, *n - *k + 1), lda, &rwork[
1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
zlaset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda);
zherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, &
c_b24, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of ZQLT02 */
} /* zqlt02_ */
int main( int argc, char** argv )
{
obj_t a, b, c;
obj_t x, y;
obj_t alpha, beta;
dim_t m;
num_t dt_a, dt_b, dt_c;
num_t dt_alpha, dt_beta;
int ii;
#ifdef NBLIS
bli_init();
#endif
m = 4000;
dt_a = BLIS_DOUBLE;
dt_b = BLIS_DOUBLE;
dt_c = BLIS_DOUBLE;
dt_alpha = BLIS_DOUBLE;
dt_beta = BLIS_DOUBLE;
{
#ifdef NBLIS
bli_obj_create( dt_alpha, 1, 1, 0, 0, &alpha );
bli_obj_create( dt_beta, 1, 1, 0, 0, &beta );
bli_obj_create( dt_a, m, 1, 0, 0, &x );
bli_obj_create( dt_a, m, 1, 0, 0, &y );
bli_obj_create( dt_a, m, m, 0, 0, &a );
bli_obj_create( dt_b, m, m, 0, 0, &b );
bli_obj_create( dt_c, m, m, 0, 0, &c );
bli_randm( &a );
bli_randm( &b );
bli_randm( &c );
bli_setsc( (2.0/1.0), 0.0, &alpha );
bli_setsc( -(1.0/1.0), 0.0, &beta );
#endif
#ifdef NBLAS
x.buffer = malloc( m * 1 * sizeof( double ) );
y.buffer = malloc( m * 1 * sizeof( double ) );
alpha.buffer = malloc( 1 * sizeof( double ) );
beta.buffer = malloc( 1 * sizeof( double ) );
a.buffer = malloc( m * m * sizeof( double ) );
a.m = m;
a.n = m;
a.cs = m;
b.buffer = malloc( m * m * sizeof( double ) );
b.m = m;
b.n = m;
b.cs = m;
c.buffer = malloc( m * m * sizeof( double ) );
c.m = m;
c.n = m;
c.cs = m;
*((double*)alpha.buffer) = 2.0;
*((double*)beta.buffer) = -1.0;
#endif
#ifdef NBLIS
#if NBLIS >= 1
for ( ii = 0; ii < 2000000000; ++ii )
{
bli_gemm( &BLIS_ONE,
&a,
&b,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 2
{
bli_hemm( BLIS_LEFT,
&BLIS_ONE,
&a,
&b,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 3
{
bli_herk( &BLIS_ONE,
&a,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 4
{
bli_her2k( &BLIS_ONE,
&a,
&b,
&BLIS_ONE,
&c );
}
#endif
#if NBLIS >= 5
{
bli_trmm( BLIS_LEFT,
&BLIS_ONE,
&a,
&c );
}
#endif
#if NBLIS >= 6
{
bli_trsm( BLIS_LEFT,
&BLIS_ONE,
&a,
&c );
}
#endif
#endif
#ifdef NBLAS
#if NBLAS >= 1
for ( ii = 0; ii < 2000000000; ++ii )
{
f77_char transa = 'N';
f77_char transb = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dgemm_( &transa,
&transb,
&mm,
&nn,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 2
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsymm_( &side,
&uplo,
&mm,
&nn,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 3
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
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* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsyrk_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 4
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
double* ap = bli_obj_buffer( a );
double* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
double* cp = bli_obj_buffer( c );
dsyr2k_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 5
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = 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_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#if NBLAS >= 6
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = 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 );
dtrsm_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#if NBLAS >= 7
{
f77_char transa = 'N';
f77_char transb = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width_after_trans( a );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* bp = bli_obj_buffer( b );
dcomplex* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zgemm_( &transa,
&transb,
&mm,
&nn,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 8
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_int mm = bli_obj_length( c );
f77_int nn = bli_obj_width( c );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* bp = bli_obj_buffer( b );
dcomplex* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zhemm_( &side,
&uplo,
&mm,
&nn,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 9
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldc = bli_obj_col_stride( c );
double* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
double* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zherk_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 10
{
f77_char uplo = 'L';
f77_char trans = 'N';
f77_int mm = bli_obj_length( c );
f77_int kk = bli_obj_width( a );
f77_int lda = bli_obj_col_stride( a );
f77_int ldb = bli_obj_col_stride( b );
f77_int ldc = bli_obj_col_stride( c );
dcomplex* alphap = bli_obj_buffer( alpha );
dcomplex* ap = bli_obj_buffer( a );
dcomplex* bp = bli_obj_buffer( b );
double* betap = bli_obj_buffer( beta );
dcomplex* cp = bli_obj_buffer( c );
zher2k_( &uplo,
&trans,
&mm,
&kk,
alphap,
ap, &lda,
bp, &ldb,
betap,
cp, &ldc );
}
#endif
#if NBLAS >= 11
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = 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_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#if NBLAS >= 12
{
f77_char side = 'L';
f77_char uplo = 'L';
f77_char trans = 'N';
f77_char diag = 'N';
f77_int mm = bli_obj_length( c );
f77_int nn = 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 );
ztrsm_( &side,
&uplo,
&trans,
&diag,
&mm,
&nn,
alphap,
ap, &lda,
cp, &ldc );
}
#endif
#endif
#ifdef NBLIS
bli_obj_free( &x );
bli_obj_free( &y );
bli_obj_free( &alpha );
bli_obj_free( &beta );
bli_obj_free( &a );
bli_obj_free( &b );
bli_obj_free( &c );
#endif
#ifdef NBLAS
free( x.buffer );
free( y.buffer );
free( alpha.buffer );
free( beta.buffer );
free( a.buffer );
free( b.buffer );
free( c.buffer );
#endif
}
#ifdef NBLIS
bli_finalize();
#endif
return 0;
}
/* Subroutine */ int zgqrts_(integer *n, integer *m, integer *p,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
r__, integer *lda, doublecomplex *taua, doublecomplex *b,
doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
doublereal ulp;
integer info;
doublereal unfl, resid, anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *),
zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zggqrf_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zungqr_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zungrq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGQRTS tests ZGGQRF, which computes the GQR factorization of an */
/* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows of the matrices A and B. N >= 0. */
/* M (input) INTEGER */
/* The number of columns of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of columns of the matrix B. P >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,M) */
/* The N-by-M matrix A. */
/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the GQR factorization of A and B, as returned */
/* by ZGGQRF, see CGGQRF for further details. */
/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
/* The M-by-M unitary matrix Q. */
/* R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, R and Q. */
/* LDA >= max(M,N). */
/* TAUA (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by ZGGQRF. */
/* B (input) COMPLEX*16 array, dimension (LDB,P) */
/* On entry, the N-by-P matrix A. */
/* BF (output) COMPLEX*16 array, dimension (LDB,N) */
/* Details of the GQR factorization of A and B, as returned */
/* by ZGGQRF, see CGGQRF for further details. */
/* Z (output) COMPLEX*16 array, dimension (LDB,P) */
/* The P-by-P unitary matrix Z. */
/* T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N)) */
/* BWK (workspace) COMPLEX*16 array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the arrays B, BF, Z and T. */
/* LDB >= max(P,N). */
/* TAUB (output) COMPLEX*16 array, dimension (min(P,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by DGGRQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The test ratios: */
/* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */
/* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */
/* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */
/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--taua;
bwk_dim1 = *ldb;
bwk_offset = 1 + bwk_dim1;
bwk -= bwk_offset;
t_dim1 = *ldb;
t_offset = 1 + t_dim1;
t -= t_offset;
z_dim1 = *ldb;
z_offset = 1 + z_dim1;
z__ -= z_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--taub;
--work;
--rwork;
--result;
/* Function Body */
ulp = dlamch_("Precision");
unfl = dlamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
zlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
d__1 = zlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Computing MAX */
d__1 = zlange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
bnorm = max(d__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
zggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
i__1 = min(*n,*m);
zungqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*n <= *p) {
if (*n > 0 && *n < *p) {
i__1 = *p - *n;
zlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 +
z_dim1], ldb);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2],
ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb);
}
} else {
if (*p > 1) {
i__1 = *p - 1;
i__2 = *p - 1;
zlacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, &
z__[z_dim1 + 2], ldb);
}
}
i__1 = min(*n,*p);
zungrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
zlaset_("Full", n, m, &c_b1, &c_b1, &r__[r_offset], lda);
zlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
/* Copy T */
zlaset_("Full", n, p, &c_b1, &c_b1, &t[t_offset], ldb);
if (*n <= *p) {
zlacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p
- *n + 1) * t_dim1 + 1], ldb);
} else {
i__1 = *n - *p;
zlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
zlacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p +
1 + t_dim1], ldb);
}
/* Compute R - Q'*A */
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "No transpose", n, m, n, &z__1, &q[q_offset]
, lda, &a[a_offset], lda, &c_b2, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = zlange_("1", n, m, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.;
}
/* Compute T*Z - Q'*B */
zgemm_("No Transpose", "No transpose", n, p, p, &c_b2, &t[t_offset], ldb,
&z__[z_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "No transpose", n, p, n, &z__1, &q[q_offset]
, lda, &b[b_offset], ldb, &c_b2, &bwk[bwk_offset], ldb);
/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = zlange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp;
} else {
result[2] = 0.;
}
/* Compute I - Q'*Q */
zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
zherk_("Upper", "Conjugate transpose", n, n, &c_b34, &q[q_offset], lda, &
c_b35, &r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (doublereal) max(1,*n) / ulp;
/* Compute I - Z'*Z */
zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
&c_b35, &t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (doublereal) max(1,*p) / ulp;
return 0;
/* End of ZGQRTS */
} /* zgqrts_ */
/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZPOTRF computes the Cholesky factorization of a complex Hermitian
positive definite matrix A.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
This is the block version of the algorithm, calling Level 3 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 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 factor U or L from the Cholesky
factorization A = U**H*U or A = L*L**H.
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, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b14 = -1.;
static doublereal c_b15 = 1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer jb, nb;
extern /* Subroutine */ int zpotf2_(char *, integer *, doublecomplex *,
integer *, integer *), 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_("ZPOTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, 6L, 1L);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code. */
zpotf2_(uplo, n, &A(1,1), lda, info);
} else {
/* Use blocked code. */
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
i__2 = nb;
for (j = 1; nb < 0 ? j >= *n : j <= *n; j += nb) {
/* Update and factorize the current diagonal bloc
k and test
for non-positive-definiteness.
Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
zherk_("Upper", "Conjugate transpose", &jb, &i__3, &c_b14, &A(1,j), lda, &c_b15, &A(j,j), lda);
zpotf2_("Upper", &jb, &A(j,j), lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block row. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("Conjugate transpose", "No transpose", &jb, &i__3,
&i__4, &z__1, &A(1,j), lda, &A(1,j+jb), lda, &c_b1, &A(j,j+jb), lda);
i__3 = *n - j - jb + 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit",
&jb, &i__3, &c_b1, &A(j,j), lda, &A(j,j+jb), lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__2 = *n;
i__1 = nb;
for (j = 1; nb < 0 ? j >= *n : j <= *n; j += nb) {
/* Update and factorize the current diagonal bloc
k and test
for non-positive-definiteness.
Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
zherk_("Lower", "No transpose", &jb, &i__3, &c_b14, &A(j,1), lda, &c_b15, &A(j,j), lda);
zpotf2_("Lower", &jb, &A(j,j), lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block column. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", &i__3, &jb,
&i__4, &z__1, &A(j+jb,1), lda, &A(j,1), lda, &c_b1, &A(j+jb,j), lda);
i__3 = *n - j - jb + 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non-unit"
, &i__3, &jb, &c_b1, &A(j,j), lda, &A(j+jb,j), lda);
}
/* L20: */
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
/* End of ZPOTRF */
} /* zpotrf_ */
/* Subroutine */ int zunt01_(char *rowcol, integer *m, integer *n,
doublecomplex *u, integer *ldu, doublecomplex *work, integer *lwork,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal eps;
doublecomplex tmp;
extern logical lsame_(char *, char *);
integer mnmin;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
integer ldwork;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
char transu[1];
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNT01 checks that the matrix U is unitary by computing the ratio */
/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* Alternatively, if there isn't sufficient workspace to form */
/* I - U*U' or I - U'*U, the ratio is computed as */
/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* where EPS is the machine precision. ROWCOL is used only if m = n; */
/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
/* assumed to be 'R'. */
/* Arguments */
/* ========= */
/* ROWCOL (input) CHARACTER */
/* Specifies whether the rows or columns of U should be checked */
/* for orthogonality. Used only if M = N. */
/* = 'R': Check for orthogonal rows of U */
/* = 'C': Check for orthogonal columns of U */
/* M (input) INTEGER */
/* The number of rows of the matrix U. */
/* N (input) INTEGER */
/* The number of columns of the matrix U. */
/* U (input) COMPLEX*16 array, dimension (LDU,N) */
/* The unitary matrix U. U is checked for orthogonal columns */
/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. For best performance, LWORK */
/* should be at least N*N if ROWCOL = 'C' or M*M if */
/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (min(M,N)) */
/* Used only if LWORK is large enough to use the Level 3 BLAS */
/* code. */
/* RESID (output) DOUBLE PRECISION */
/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
/* Function Body */
*resid = 0.;
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return 0;
}
eps = dlamch_("Precision");
if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
*(unsigned char *)transu = 'N';
k = *n;
} else {
*(unsigned char *)transu = 'C';
k = *m;
}
mnmin = min(*m,*n);
if ((mnmin + 1) * mnmin <= *lwork) {
ldwork = mnmin;
} else {
ldwork = 0;
}
if (ldwork > 0) {
/* Compute I - U*U' or I - U'*U. */
zlaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
zherk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b11,
&work[1], &ldwork);
/* Compute norm( I - U*U' ) / ( K * EPS ) . */
*resid = zlansy_("1", "Upper", &mnmin, &work[1], &ldwork, &rwork[1]);
*resid = *resid / (doublereal) k / eps;
} else if (*(unsigned char *)transu == 'C') {
/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp.r = 0., tmp.i = 0.;
} else {
tmp.r = 1., tmp.i = 0.;
}
zdotc_(&z__2, m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
1], &c__1);
z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
tmp.r = z__1.r, tmp.i = z__1.i;
/* Computing MAX */
d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
d_imag(&tmp), abs(d__2));
*resid = max(d__3,d__4);
/* L10: */
}
/* L20: */
}
*resid = *resid / (doublereal) (*m) / eps;
} else {
/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp.r = 0., tmp.i = 0.;
} else {
tmp.r = 1., tmp.i = 0.;
}
zdotc_(&z__2, n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
tmp.r = z__1.r, tmp.i = z__1.i;
/* Computing MAX */
d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
d_imag(&tmp), abs(d__2));
*resid = max(d__3,d__4);
/* L30: */
}
/* L40: */
}
*resid = *resid / (doublereal) (*n) / eps;
}
return 0;
/* End of ZUNT01 */
} /* zunt01_ */
/* Subroutine */ int zdrvrf4_(integer *nout, integer *nn, integer *nval,
doublereal *thresh, doublecomplex *c1, doublecomplex *c2, integer *
ldc, doublecomplex *crf, doublecomplex *a, integer *lda, doublereal *
d_work_zlange__)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char forms[1*2] = "N" "C";
static char transs[1*2] = "N" "C";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
"ing ZHFRK ***\002)";
static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
"'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
"'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
"=\002,g12.5)";
static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
"outine passed the \002,\002threshold (\002,i5,\002 tests run)"
"\002)";
static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
" of \002,i5,\002 tests failed to pass the threshold\002)";
/* System generated locals */
integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1,
i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
do_fio(integer *, char *, ftnlen);
/* Local variables */
integer i__, j, k, n, iik, iin;
doublereal eps, beta;
integer info;
char uplo[1];
integer nrun;
doublereal alpha;
integer nfail, iseed[4];
char cform[1];
integer iform;
doublereal norma, normc;
extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *), zhfrk_(char *, char *
, char *, integer *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, doublecomplex *);
char trans[1];
integer iuplo;
extern doublereal dlamch_(char *);
integer ialpha;
extern doublereal dlarnd_(integer *, integer *), zlange_(char *, integer *
, integer *, doublecomplex *, integer *, doublereal *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
integer itrans;
doublereal result[1];
extern /* Subroutine */ int ztfttr_(char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), ztrttf_(char *, char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
/* Fortran I/O blocks */
static cilist io___28 = { 0, 0, 0, 0, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVRF4 tests the LAPACK RFP routines: */
/* ZHFRK */
/* Arguments */
/* ========= */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* C1 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) */
/* C2 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) */
/* LDC (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* CRF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* ===================================================================== */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
c2_dim1 = *ldc;
c2_offset = 1 + c2_dim1;
c2 -= c2_offset;
c1_dim1 = *ldc;
c1_offset = 1 + c1_dim1;
c1 -= c1_offset;
--crf;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d_work_zlange__;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nfail = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Precision");
i__1 = *nn;
for (iin = 1; iin <= i__1; ++iin) {
n = nval[iin];
i__2 = *nn;
for (iik = 1; iik <= i__2; ++iik) {
k = nval[iin];
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
for (itrans = 1; itrans <= 2; ++itrans) {
*(unsigned char *)trans = *(unsigned char *)&transs[
itrans - 1];
for (ialpha = 1; ialpha <= 4; ++ialpha) {
if (ialpha == 1) {
alpha = 0.;
beta = 0.;
} else if (ialpha == 1) {
alpha = 1.;
beta = 0.;
} else if (ialpha == 1) {
alpha = 0.;
beta = 1.;
} else {
alpha = dlarnd_(&c__2, iseed);
beta = dlarnd_(&c__2, iseed);
}
/* All the parameters are set: */
/* CFORM, UPLO, TRANS, M, N, */
/* ALPHA, and BETA */
/* READY TO TEST! */
++nrun;
if (itrans == 1) {
/* In this case we are NOTRANS, so A is N-by-K */
i__3 = k;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * a_dim1;
zlarnd_(&z__1, &c__4, iseed);
a[i__5].r = z__1.r, a[i__5].i =
z__1.i;
}
}
norma = zlange_("I", &n, &k, &a[a_offset],
lda, &d_work_zlange__[1]);
} else {
/* In this case we are TRANS, so A is K-by-N */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = k;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * a_dim1;
zlarnd_(&z__1, &c__4, iseed);
a[i__5].r = z__1.r, a[i__5].i =
z__1.i;
}
}
norma = zlange_("I", &k, &n, &a[a_offset],
lda, &d_work_zlange__[1]);
}
/* Generate C1 our N--by--N Hermitian matrix. */
/* Make sure C2 has the same upper/lower part, */
/* (the one that we do not touch), so */
/* copy the initial C1 in C2 in it. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * c1_dim1;
zlarnd_(&z__1, &c__4, iseed);
c1[i__5].r = z__1.r, c1[i__5].i = z__1.i;
i__5 = i__ + j * c2_dim1;
i__6 = i__ + j * c1_dim1;
c2[i__5].r = c1[i__6].r, c2[i__5].i = c1[
i__6].i;
}
}
/* (See comment later on for why we use ZLANGE and */
/* not ZLANHE for C1.) */
normc = zlange_("I", &n, &n, &c1[c1_offset], ldc,
&d_work_zlange__[1]);
s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (
ftnlen)6);
ztrttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
crf[1], &info);
/* call zherk the BLAS routine -> gives C1 */
s_copy(srnamc_1.srnamt, "ZHERK ", (ftnlen)32, (
ftnlen)6);
zherk_(uplo, trans, &n, &k, &alpha, &a[a_offset],
lda, &beta, &c1[c1_offset], ldc);
/* call zhfrk the RFP routine -> gives CRF */
s_copy(srnamc_1.srnamt, "ZHFRK ", (ftnlen)32, (
ftnlen)6);
zhfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
a_offset], lda, &beta, &crf[1]);
/* convert CRF in full format -> gives C2 */
s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (
ftnlen)6);
ztfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset],
ldc, &info);
/* compare C1 and C2 */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * c1_dim1;
i__6 = i__ + j * c1_dim1;
i__7 = i__ + j * c2_dim1;
z__1.r = c1[i__6].r - c2[i__7].r, z__1.i =
c1[i__6].i - c2[i__7].i;
c1[i__5].r = z__1.r, c1[i__5].i = z__1.i;
}
}
/* Yes, C1 is Hermitian so we could call ZLANHE, */
/* but we want to check the upper part that is */
/* supposed to be unchanged and the diagonal that */
/* is supposed to be real -> ZLANGE */
result[0] = zlange_("I", &n, &n, &c1[c1_offset],
ldc, &d_work_zlange__[1]);
/* Computing MAX */
d__1 = abs(alpha) * norma * norma + abs(beta) *
normc;
result[0] = result[0] / max(d__1,1.) / max(n,1) /
eps;
if (result[0] >= *thresh) {
if (nfail == 0) {
io___28.ciunit = *nout;
s_wsle(&io___28);
e_wsle();
io___29.ciunit = *nout;
s_wsfe(&io___29);
e_wsfe();
}
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, "ZHFRK", (ftnlen)5);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* Print a summary of the results. */
if (nfail == 0) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, "ZHFRK", (ftnlen)5);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "ZHFRK", (ftnlen)5);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of ZDRVRF4 */
} /* zdrvrf4_ */
/* Subroutine */ int zlauum_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, ib, nb;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zlauu2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAUUM 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*16 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 */
/* ===================================================================== */
/* .. 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");
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_("ZLAUUM", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
zlauu2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
ztrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", &
i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
* a_dim1 + 1], lda);
zlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
zgemm_("No transpose", "Conjugate transpose", &i__3, &ib,
&i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, &
a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ *
a_dim1 + 1], lda);
i__3 = *n - i__ - ib + 1;
zherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[
i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ +
i__ * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
ztrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", &
ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
+ a_dim1], lda);
zlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
zgemm_("Conjugate transpose", "No transpose", &ib, &i__3,
&i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, &
a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1]
, lda);
i__3 = *n - i__ - ib + 1;
zherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21,
&a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__
+ i__ * a_dim1], lda);
}
/* L20: */
}
}
}
return 0;
/* End of ZLAUUM */
} /* zlauum_ */
void
zherk(char uplo, char transa, int n, int k, double alpha, doublecomplex *a, int lda, double beta, doublecomplex *c, int ldc)
{
zherk_( &uplo, &transa, &n, &k, &alpha, a, &lda, &beta, c, &ldc);
}
/* Subroutine */ int ztimb3_(char *line, integer *nm, integer *mval, integer *
nn, integer *nval, integer *nk, integer *kval, integer *nlda, integer
*ldaval, doublereal *timmin, doublecomplex *a, doublecomplex *b,
doublecomplex *c__, doublereal *reslts, integer *ldr1, integer *ldr2,
integer *nout, ftnlen line_len)
{
/* Initialized data */
static char names[6*9] = "ZGEMM " "ZHEMM " "ZSYMM " "ZHERK " "ZHER2K"
"ZSYRK " "ZSYR2K" "ZTRMM " "ZTRSM ";
static char trans[1*3] = "N" "T" "C";
static char sides[1*2] = "L" "R";
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002with LDA = \002,i5)";
static char fmt_9996[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9995[] = "(/1x,\002ZGEMM with TRANSA = '\002,a1,\002', "
"TRANSB = '\002,a1,\002'\002)";
static char fmt_9994[] = "(/1x,\002K = \002,i4,/)";
static char fmt_9993[] = "(/1x,a6,\002 with SIDE = '\002,a1,\002', UPLO "
"= '\002,a1,\002'\002,/)";
static char fmt_9992[] = "(/1x,a6,\002 with UPLO = '\002,a1,\002', TRANS"
" = '\002,a1,\002'\002,/)";
static char fmt_9991[] = "(/1x,a6,\002 with SIDE = '\002,a1,\002', UPLO "
"= '\002,a1,\002',\002,\002 TRANS = '\002,a1,\002'\002,/)";
static char fmt_9990[] = "(/////)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_offset, i__1, i__2, i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ilda;
static char side[1];
static integer imat, info;
static char path[3];
static doublereal time;
static integer isub;
static char uplo[1];
static integer i__, k, m, n;
static char cname[6];
static integer iside;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhemm_(char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
static integer iuplo;
static doublereal s1, s2;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zsymm_(char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *),
ztrsm_(char *, char *, char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), zsyrk_(char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, integer *);
extern doublereal dopbl3_(char *, integer *, integer *, integer *)
;
extern /* Subroutine */ int zher2k_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *);
static integer ic, ik, im, in;
extern doublereal dsecnd_(void);
extern /* Subroutine */ int zsyr2k_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), atimck_(integer *, char *, integer *, integer *, integer
*, integer *, integer *, integer *, ftnlen);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), dprtbl_(
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *, ftnlen,
ftnlen);
static char transa[1], transb[1];
static doublereal untime;
static logical timsub[9];
extern /* Subroutine */ int ztimmg_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, integer *);
static integer lda, icl, ita, itb;
static doublereal ops;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9990, 0 };
#define names_ref(a_0,a_1) &names[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3) reslts[((a_3)*reslts_dim2 + (a_2))*\
reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTIMB3 times the Level 3 BLAS routines.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NK (input) INTEGER
The number of values of K contained in the vector KVAL.
KVAL (input) INTEGER array, dimension (NK)
The values of K. K is used as the intermediate matrix
dimension for ZGEMM (the product of an M x K matrix and a
K x N matrix) and as the dimension of the rank-K update in
ZHERK and ZSYRK.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) DOUBLE PRECISION
The minimum time a subroutine will be timed.
A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values permitted
for LDA and N.
B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
C (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA)
The timing results for each subroutine over the relevant
values of M, N, K, and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NM,NK).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NN).
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--kval;
--ldaval;
--a;
--b;
--c__;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * 1);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "B3", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__9, names, timsub, nout, &info, (ftnlen)3,
line_len, (ftnlen)6);
if (info != 0) {
goto L690;
}
/* Check that M <= LDA. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__1, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L690;
}
/* Time each routine. */
for (isub = 1; isub <= 9; ++isub) {
if (! timsub[isub - 1]) {
goto L680;
}
/* Print header. */
s_copy(cname, names_ref(0, isub), (ftnlen)6, (ftnlen)6);
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
if (*nlda == 1) {
io___12.ciunit = *nout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&ldaval[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L10: */
}
}
/* Time ZGEMM */
if (s_cmp(cname, "ZGEMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[ita - 1];
for (itb = 1; itb <= 3; ++itb) {
*(unsigned char *)transb = *(unsigned char *)&trans[itb -
1];
i__1 = *nk;
for (ik = 1; ik <= i__1; ++ik) {
k = kval[ik];
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
i__3 = *nm;
for (im = 1; im <= i__3; ++im) {
m = mval[im];
i__4 = *nn;
for (in = 1; in <= i__4; ++in) {
n = nval[in];
if (*(unsigned char *)transa == 'N') {
ztimmg_(&c__1, &m, &k, &a[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&c__1, &k, &m, &a[1], &lda, &
c__0, &c__0);
}
if (*(unsigned char *)transb == 'N') {
ztimmg_(&c__0, &k, &n, &b[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&c__0, &n, &k, &b[1], &lda, &
c__0, &c__0);
}
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L20:
zgemm_(transa, transb, &m, &n, &k, &c_b1,
&a[1], &lda, &b[1], &lda, &c_b1, &
c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda,
&c__0, &c__0);
goto L20;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L30:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda,
&c__0, &c__0);
goto L30;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &m, &n, &k);
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L40: */
}
/* L50: */
}
/* L60: */
}
if (ik == 1) {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, transa, (ftnlen)1);
do_fio(&c__1, transb, (ftnlen)1);
e_wsfe();
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&kval[ik], (ftnlen)sizeof(
integer));
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Time ZHEMM */
} else if (s_cmp(cname, "ZHEMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 6;
} else {
imat = -6;
}
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ztimmg_(&imat, &n, &n, &a[1], &lda, &c__0,
&c__0);
}
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L100:
zhemm_(side, uplo, &m, &n, &c_b1, &a[1], &lda,
&b[1], &lda, &c_b1, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L100;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L110:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L110;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4)
;
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L120: */
}
/* L130: */
}
/* L140: */
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "ZHEMM ", (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (ftnlen)
1, (ftnlen)1);
/* L150: */
}
/* L160: */
}
/* Time ZSYMM */
} else if (s_cmp(cname, "ZSYMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 8;
} else {
imat = -8;
}
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ztimmg_(&imat, &n, &n, &a[1], &lda, &c__0,
&c__0);
}
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L170:
zsymm_(side, uplo, &m, &n, &c_b1, &a[1], &lda,
&b[1], &lda, &c_b1, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L170;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L180:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__1, &m, &n, &c__[1], &lda, &
c__0, &c__0);
goto L180;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4)
;
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L190: */
}
/* L200: */
}
/* L210: */
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "ZSYMM ", (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (ftnlen)
1, (ftnlen)1);
/* L220: */
}
/* L230: */
}
/* Time ZHERK */
} else if (s_cmp(cname, "ZHERK ", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 6;
} else {
imat = -6;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[ita -
1];
if (*(unsigned char *)transa != 'T') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transa == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L240:
zherk_(uplo, transa, &n, &k, &c_b156, &a[
1], &lda, &c_b156, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L240;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L250:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L250;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L260: */
}
/* L270: */
}
/* L280: */
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L290: */
}
/* L300: */
}
/* Time ZHER2K */
} else if (s_cmp(cname, "ZHER2K", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 6;
} else {
imat = -6;
}
for (itb = 1; itb <= 3; ++itb) {
*(unsigned char *)transb = *(unsigned char *)&trans[itb -
1];
if (*(unsigned char *)transb != 'T') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transb == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &n, &k, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &k, &n, &b[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L310:
zher2k_(uplo, transb, &n, &k, &c_b1, &a[1]
, &lda, &b[1], &lda, &c_b156, &
c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L310;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L320:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L320;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L330: */
}
/* L340: */
}
/* L350: */
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transb, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L360: */
}
/* L370: */
}
/* Time ZSYRK */
} else if (s_cmp(cname, "ZSYRK ", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 8;
} else {
imat = -8;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[ita -
1];
if (*(unsigned char *)transa != 'C') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transa == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L380:
zsyrk_(uplo, transa, &n, &k, &c_b1, &a[1],
&lda, &c_b1, &c__[1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L380;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L390:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L390;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L400: */
}
/* L410: */
}
/* L420: */
}
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L430: */
}
/* L440: */
}
/* Time ZSYR2K */
} else if (s_cmp(cname, "ZSYR2K", (ftnlen)6, (ftnlen)6) == 0) {
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
imat = 8;
} else {
imat = -8;
}
for (itb = 1; itb <= 3; ++itb) {
*(unsigned char *)transb = *(unsigned char *)&trans[itb -
1];
if (*(unsigned char *)transb != 'C') {
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nk;
for (ik = 1; ik <= i__2; ++ik) {
k = kval[ik];
if (*(unsigned char *)transb == 'N') {
ztimmg_(&c__1, &n, &k, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &n, &k, &b[1], &lda, &c__0,
&c__0);
} else {
ztimmg_(&c__1, &k, &n, &a[1], &lda, &c__0,
&c__0);
ztimmg_(&c__0, &k, &n, &b[1], &lda, &c__0,
&c__0);
}
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
ztimmg_(&imat, &n, &n, &c__[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L450:
zsyr2k_(uplo, transb, &n, &k, &c_b1, &a[1]
, &lda, &b[1], &lda, &c_b1, &c__[
1], &lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L450;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L460:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&imat, &n, &n, &c__[1], &lda,
&c__0, &c__0);
goto L460;
}
time = (time - untime) / (doublereal) ic;
ops = dopbl3_(cname, &n, &n, &k);
reslts_ref(ik, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L470: */
}
/* L480: */
}
/* L490: */
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transb, (ftnlen)1);
e_wsfe();
dprtbl_("K", "N", nk, &kval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
}
/* L500: */
}
/* L510: */
}
/* Time ZTRMM */
} else if (s_cmp(cname, "ZTRMM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 11;
} else {
imat = -11;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[
ita - 1];
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&imat, &n, &n, &a[1], &lda, &
c__0, &c__0);
}
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ic = 0;
s1 = dsecnd_();
L520:
ztrmm_(side, uplo, transa, "Non-unit", &m,
&n, &c_b1, &a[1], &lda, &b[1], &
lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L520;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L530:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L530;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4);
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L540: */
}
/* L550: */
}
/* L560: */
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
/* L570: */
}
/* L580: */
}
/* L590: */
}
/* Time ZTRSM */
} else if (s_cmp(cname, "ZTRSM ", (ftnlen)6, (ftnlen)6) == 0) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
if (lsame_(uplo, "U")) {
imat = 11;
} else {
imat = -11;
}
for (ita = 1; ita <= 3; ++ita) {
*(unsigned char *)transa = *(unsigned char *)&trans[
ita - 1];
i__1 = *nlda;
for (ilda = 1; ilda <= i__1; ++ilda) {
lda = ldaval[ilda];
i__2 = *nm;
for (im = 1; im <= i__2; ++im) {
m = mval[im];
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
if (iside == 1) {
ztimmg_(&imat, &m, &m, &a[1], &lda, &
c__0, &c__0);
} else {
ztimmg_(&imat, &n, &n, &a[1], &lda, &
c__0, &c__0);
}
ztimmg_(&c__0, &m, &n, &b[1], &lda, &c__0,
&c__0);
ic = 0;
s1 = dsecnd_();
L600:
ztrsm_(side, uplo, transa, "Non-unit", &m,
&n, &c_b1, &a[1], &lda, &b[1], &
lda);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L600;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L610:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m, &n, &b[1], &lda, &
c__0, &c__0);
goto L610;
}
time = (time - untime) / (doublereal) ic;
i__4 = iside - 1;
ops = dopbl3_(cname, &m, &n, &i__4);
reslts_ref(im, in, ilda) = dmflop_(&ops, &
time, &c__0);
/* L620: */
}
/* L630: */
}
/* L640: */
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, cname, (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, transa, (ftnlen)1);
e_wsfe();
dprtbl_("M", "N", nm, &mval[1], nn, &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (
ftnlen)1, (ftnlen)1);
/* L650: */
}
/* L660: */
}
/* L670: */
}
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
e_wsfe();
L680:
;
}
L690:
return 0;
/* End of ZTIMB3 */
} /* ztimb3_ */
/* Subroutine */ int zlqt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the first k */
/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
/* checks that the rows of Q are orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by ZLQT01. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by ZGELQF. */
/* See ZGELQF for further details. */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* L (workspace) COMPLEX*16 array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ factorization in AF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)6, (ftnlen)6);
zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
zlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT02 */
} /* zlqt02_ */
/* Subroutine */ int zrqt01_(integer *m, integer *n, doublecomplex *a,
doublecomplex *af, doublecomplex *q, doublecomplex *r__, integer *lda,
doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zgerqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungrq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZRQT01 tests ZGERQF, which computes the RQ factorization of an m-by-n */
/* matrix A, and partially tests ZUNGRQ which forms the n-by-n */
/* orthogonal matrix Q. */
/* ZRQT01 compares R with A*Q', and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by ZGERQF. */
/* See ZGERQF for further details. */
/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
/* The n-by-n orthogonal matrix Q. */
/* R (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. */
/* LDA >= max(M,N). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by ZGERQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "ZGERQF", (ftnlen)6, (ftnlen)6);
zgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
q_dim1], lda);
}
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
zlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
}
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
q[q_dim1 + 2], lda);
}
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6);
zungrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy R */
zlaset_("Full", m, n, &c_b12, &c_b12, &r__[r_offset], lda);
if (*m <= *n) {
if (*m > 0) {
zlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
r__[(*n - *m + 1) * r_dim1 + 1], lda);
}
} else {
if (*m > *n && *n > 0) {
i__1 = *m - *n;
zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
lda);
}
if (*n > 0) {
zlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
*n + 1 + r_dim1], lda);
}
}
/* Compute R - A*Q' */
zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b19, &a[
a_offset], lda, &q[q_offset], lda, &c_b20, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", n, n, &c_b12, &c_b20, &r__[r_offset], lda);
zherk_("Upper", "No transpose", n, n, &c_b28, &q[q_offset], lda, &c_b29, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZRQT01 */
} /* zrqt01_ */
int zpotrf_(char *uplo, int *n, doublecomplex *a,
int *lda, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
int j, jb, nb;
extern int lsame_(char *, char *);
extern int zgemm_(char *, char *, int *, int *,
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *), zherk_(char *, char *, int *,
int *, double *, doublecomplex *, int *, double *,
doublecomplex *, int *);
int upper;
extern int ztrsm_(char *, char *, char *, char *,
int *, int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *),
zpotf2_(char *, int *, doublecomplex *, int *, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPOTRF computes the Cholesky factorization of a complex Hermitian */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U**H * U, if UPLO = 'U', or */
/* A = L * L**H, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the block version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 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 factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H. */
/* 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, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* .. 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");
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_("ZPOTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code. */
zpotf2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code. */
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Update and factorize the current diagonal block and test */
/* for non-positive-definiteness. */
/* Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = MIN(i__3,i__4);
i__3 = j - 1;
zherk_("Upper", "Conjugate transpose", &jb, &i__3, &c_b14, &a[
j * a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda);
zpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block row. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "No transpose", &jb, &i__3,
&i__4, &z__1, &a[j * a_dim1 + 1], lda, &a[(j + jb)
* a_dim1 + 1], lda, &c_b1, &a[j + (j + jb) *
a_dim1], lda);
i__3 = *n - j - jb + 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit",
&jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j
+ (j + jb) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__2 = *n;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Update and factorize the current diagonal block and test */
/* for non-positive-definiteness. */
/* Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = MIN(i__3,i__4);
i__3 = j - 1;
zherk_("Lower", "No transpose", &jb, &i__3, &c_b14, &a[j +
a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda);
zpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block column. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__3, &jb,
&i__4, &z__1, &a[j + jb + a_dim1], lda, &a[j +
a_dim1], lda, &c_b1, &a[j + jb + j * a_dim1], lda);
i__3 = *n - j - jb + 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non-unit"
, &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[
j + jb + j * a_dim1], lda);
}
/* L20: */
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
/* End of ZPOTRF */
} /* zpotrf_ */
/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1;
/* Local variables */
integer i__, j, i2, i3, ib, nb, ii, jj;
doublecomplex work[1056] /* was [33][32] */;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *), ztrsm_(char *, char
*, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zpbtf2_(char *, integer *, integer *,
doublecomplex *, integer *, integer *), zpotf2_(char *,
integer *, doublecomplex *, integer *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPBTRF computes the Cholesky factorization of a complex Hermitian */
/* positive definite band matrix A. */
/* The factorization has the form */
/* A = U**H * U, if UPLO = 'U', or */
/* A = L * L**H, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, if INFO = 0, the triangular factor U or L from the */
/* Cholesky factorization A = U**H*U or A = L*L**H of the band */
/* matrix A, in the same storage format as A. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 6, KD = 2, and UPLO = 'U': */
/* On entry: On exit: */
/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* Similarly, if UPLO = 'L' the format of A is as follows: */
/* On entry: On exit: */
/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
/* Array elements marked * are not used by the routine. */
/* Contributed by */
/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "ZPBTRF", uplo, n, kd, &c_n1, &c_n1);
/* The block size must not exceed the semi-bandwidth KD, and must not */
/* exceed the limit set by the size of the local array WORK. */
nb = min(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
zpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a Hermitian band */
/* matrix, given the upper triangle of the matrix in band */
/* storage. */
/* Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 33 - 34;
work[i__3].r = 0., work[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
/* Process the band matrix one diagonal block at a time. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix. */
/* If A11 denotes the diagonal block which has just been */
/* factorized, then we need to update the remaining */
/* blocks in the diagram: */
/* A11 A12 A13 */
/* A22 A23 */
/* A33 */
/* The numbers of rows and columns in the partitioning */
/* are IB, I2, I3 respectively. The blocks A12, A22 and */
/* A23 are empty if IB = KD. The upper triangle of A13 */
/* lies outside the band. */
/* Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i2, &c_b1, &ab[*kd + 1 + i__ *
ab_dim1], &i__3, &ab[*kd + 1 - ib + (i__ + ib)
* ab_dim1], &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i2, &ib, &
c_b21, &ab[*kd + 1 - ib + (i__ + ib) *
ab_dim1], &i__3, &c_b22, &ab[*kd + 1 + (i__ +
ib) * ab_dim1], &i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 into the work array. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ii + jj * 33 - 34;
i__6 = ii - jj + 1 + (jj + i__ + *kd - 1) *
ab_dim1;
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L30: */
}
/* L40: */
}
/* Update A13 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i3, &c_b1, &ab[*kd + 1 + i__ *
ab_dim1], &i__3, work, &c__33);
/* Update A23 */
if (i2 > 0) {
z__1.r = -1., z__1.i = -0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("Conjugate transpose", "No transpose", &i2,
&i3, &ib, &z__1, &ab[*kd + 1 - ib + (i__
+ ib) * ab_dim1], &i__3, work, &c__33, &
c_b1, &ab[ib + 1 + (i__ + *kd) * ab_dim1],
&i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i3, &ib, &
c_b21, work, &c__33, &c_b22, &ab[*kd + 1 + (
i__ + *kd) * ab_dim1], &i__3);
/* Copy the lower triangle of A13 back into place. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ii - jj + 1 + (jj + i__ + *kd - 1) *
ab_dim1;
i__6 = ii + jj * 33 - 34;
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L50: */
}
/* L60: */
}
}
}
/* L70: */
}
} else {
/* Compute the Cholesky factorization of a Hermitian band */
/* matrix, given the lower triangle of the matrix in band */
/* storage. */
/* Zero the lower triangle of the work array. */
i__2 = nb;
for (j = 1; j <= i__2; ++j) {
i__1 = nb;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__3 = i__ + j * 33 - 34;
work[i__3].r = 0., work[i__3].i = 0.;
/* L80: */
}
/* L90: */
}
/* Process the band matrix one diagonal block at a time. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix. */
/* If A11 denotes the diagonal block which has just been */
/* factorized, then we need to update the remaining */
/* blocks in the diagram: */
/* A11 */
/* A21 A22 */
/* A31 A32 A33 */
/* The numbers of rows and columns in the partitioning */
/* are IB, I2, I3 respectively. The blocks A21, A22 and */
/* A32 are empty if IB = KD. The lower triangle of A31 */
/* lies outside the band. */
/* Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A21 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i2, &ib, &c_b1, &ab[i__ * ab_dim1 +
1], &i__3, &ab[ib + 1 + i__ * ab_dim1], &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Lower", "No transpose", &i2, &ib, &c_b21, &ab[
ib + 1 + i__ * ab_dim1], &i__3, &c_b22, &ab[(
i__ + ib) * ab_dim1 + 1], &i__4);
}
if (i3 > 0) {
/* Copy the upper triangle of A31 into the work array. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = ii + jj * 33 - 34;
i__6 = *kd + 1 - jj + ii + (jj + i__ - 1) *
ab_dim1;
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L100: */
}
/* L110: */
}
/* Update A31 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i3, &ib, &c_b1, &ab[i__ * ab_dim1 +
1], &i__3, work, &c__33);
/* Update A32 */
if (i2 > 0) {
z__1.r = -1., z__1.i = -0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("No transpose", "Conjugate transpose", &i3,
&i2, &ib, &z__1, work, &c__33, &ab[ib +
1 + i__ * ab_dim1], &i__3, &c_b1, &ab[*kd
+ 1 - ib + (i__ + ib) * ab_dim1], &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Lower", "No transpose", &i3, &ib, &c_b21,
work, &c__33, &c_b22, &ab[(i__ + *kd) *
ab_dim1 + 1], &i__3);
/* Copy the upper triangle of A31 back into place. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = *kd + 1 - jj + ii + (jj + i__ - 1) *
ab_dim1;
i__6 = ii + jj * 33 - 34;
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L120: */
}
/* L130: */
}
}
}
/* L140: */
}
}
}
return 0;
L150:
return 0;
/* End of ZPBTRF */
} /* zpbtrf_ */
