/* Subroutine */ int ssyrk_(char *uplo, char *trans, integer *n, integer *k, real *alpha, real *a, integer *lda, real *beta, real *c__, integer * ldc) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; /* Local variables */ static integer info; static real temp; static integer i__, j, l; extern logical lsame_(char *, char *); static integer nrowa; static logical upper; extern /* Subroutine */ int xerbla_(char *, integer *); #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] /* Purpose ======= SSYRK performs one of the symmetric rank k operations C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, where alpha and beta are scalars, C is an n by n symmetric matrix and A is an n by k matrix in the first case and a k by n matrix in the second case. Parameters ========== UPLO - CHARACTER*1. 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 - CHARACTER*1. On entry, TRANS specifies the operation to be performed as follows: TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. TRANS = 'T' or 't' C := alpha*A'*A + beta*C. TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. Unchanged on exit. N - INTEGER. On entry, N specifies the order of the matrix C. N must be at least zero. Unchanged on exit. K - INTEGER. On entry with TRANS = 'N' or 'n', K specifies the number of columns of the matrix A, and on entry with TRANS = 'T' or 't' or 'C' or 'c', K specifies the number of rows of the matrix A. K must be at least zero. Unchanged on exit. ALPHA - REAL . On entry, ALPHA specifies the scalar alpha. Unchanged on exit. A - REAL 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 - 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 - REAL . On entry, BETA specifies the scalar beta. Unchanged on exit. C - REAL array of DIMENSION ( LDC, n ). Before entry with UPLO = 'U' or 'u', the leading n by n upper triangular part of the array C must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of C is not referenced. On exit, the upper triangular part of the array C is overwritten by the upper triangular part of the updated matrix. Before entry with UPLO = 'L' or 'l', the leading n by n lower triangular part of the array C must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of C is not referenced. On exit, the lower triangular part of the array C is overwritten by the lower triangular part of the updated matrix. LDC - INTEGER. On entry, LDC specifies the first dimension of C as declared in the calling (sub) program. LDC must be at least max( 1, n ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Test the input parameters. Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ if (lsame_(trans, "N")) { nrowa = *n; } else { nrowa = *k; } upper = lsame_(uplo, "U"); info = 0; if (! upper && ! lsame_(uplo, "L")) { info = 1; } else if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { info = 2; } else if (*n < 0) { info = 3; } else if (*k < 0) { info = 4; } else if (*lda < max(1,nrowa)) { info = 7; } else if (*ldc < max(1,*n)) { info = 10; } if (info != 0) { xerbla_("SSYRK ", &info); return 0; } /* Quick return if possible. */ if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.f) { if (upper) { if (*beta == 0.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L30: */ } /* L40: */ } } } else { if (*beta == 0.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L50: */ } /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L70: */ } /* L80: */ } } } return 0; } /* Start the operations. */ if (lsame_(trans, "N")) { /* Form C := alpha*A*A' + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*beta == 0.f) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L90: */ } } else if (*beta != 1.f) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L100: */ } } i__2 = *k; for (l = 1; l <= i__2; ++l) { if (a_ref(j, l) != 0.f) { temp = *alpha * a_ref(j, l); i__3 = j; for (i__ = 1; i__ <= i__3; ++i__) { c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( i__, l); /* L110: */ } } /* L120: */ } /* L130: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*beta == 0.f) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L140: */ } } else if (*beta != 1.f) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L150: */ } } i__2 = *k; for (l = 1; l <= i__2; ++l) { if (a_ref(j, l) != 0.f) { temp = *alpha * a_ref(j, l); i__3 = *n; for (i__ = j; i__ <= i__3; ++i__) { c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( i__, l); /* L160: */ } } /* L170: */ } /* L180: */ } } } else { /* Form C := alpha*A'*A + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { temp = 0.f; i__3 = *k; for (l = 1; l <= i__3; ++l) { temp += a_ref(l, i__) * a_ref(l, j); /* L190: */ } if (*beta == 0.f) { c___ref(i__, j) = *alpha * temp; } else { c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, j); } /* L200: */ } /* L210: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { temp = 0.f; i__3 = *k; for (l = 1; l <= i__3; ++l) { temp += a_ref(l, i__) * a_ref(l, j); /* L220: */ } if (*beta == 0.f) { c___ref(i__, j) = *alpha * temp; } else { c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, j); } /* L230: */ } /* L240: */ } } } return 0; /* End of SSYRK . */ } /* ssyrk_ */
/* Subroutine */ int sgemm_(char *transa, char *transb, integer *m, integer * n, integer *k, real *alpha, real *a, integer *lda, real *b, integer * ldb, real *beta, real *c__, integer *ldc) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3; /* Local variables */ static integer info; static logical nota, notb; static real temp; static integer i__, j, l, ncola; extern logical lsame_(char *, char *); static integer nrowa, nrowb; extern /* Subroutine */ int xerbla_(char *, integer *); #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] /* Purpose ======= SGEMM performs one of the matrix-matrix operations C := alpha*op( A )*op( B ) + beta*C, where op( X ) is one of op( X ) = X or op( X ) = X', alpha and beta are scalars, and A, B and C are matrices, with op( A ) an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. Parameters ========== TRANSA - CHARACTER*1. On entry, TRANSA specifies the form of op( A ) to be used in the matrix multiplication as follows: TRANSA = 'N' or 'n', op( A ) = A. TRANSA = 'T' or 't', op( A ) = A'. TRANSA = 'C' or 'c', op( A ) = A'. Unchanged on exit. TRANSB - CHARACTER*1. On entry, TRANSB specifies the form of op( B ) to be used in the matrix multiplication as follows: TRANSB = 'N' or 'n', op( B ) = B. TRANSB = 'T' or 't', op( B ) = B'. TRANSB = 'C' or 'c', op( B ) = B'. Unchanged on exit. M - INTEGER. On entry, M specifies the number of rows of the matrix op( A ) and of the matrix C. M must be at least zero. Unchanged on exit. N - INTEGER. On entry, N specifies the number of columns of the matrix op( B ) and the number of columns of the matrix C. N must be at least zero. Unchanged on exit. K - INTEGER. On entry, K specifies the number of columns of the matrix op( A ) and the number of rows of the matrix op( B ). K must be at least zero. Unchanged on exit. ALPHA - REAL . On entry, ALPHA specifies the scalar alpha. Unchanged on exit. A - REAL array of DIMENSION ( LDA, ka ), where ka is k when TRANSA = 'N' or 'n', and is m otherwise. Before entry with TRANSA = 'N' or 'n', the leading m by k part of the array A must contain the matrix A, otherwise the leading k by m part of the array A must contain the matrix A. Unchanged on exit. LDA - INTEGER. On entry, LDA specifies the first dimension of A as declared in the calling (sub) program. When TRANSA = 'N' or 'n' then LDA must be at least max( 1, m ), otherwise LDA must be at least max( 1, k ). Unchanged on exit. B - REAL array of DIMENSION ( LDB, kb ), where kb is n when TRANSB = 'N' or 'n', and is k otherwise. Before entry with TRANSB = 'N' or 'n', the leading k by n part of the array B must contain the matrix B, otherwise the leading n by k part of the array B must contain the matrix B. Unchanged on exit. LDB - INTEGER. On entry, LDB specifies the first dimension of B as declared in the calling (sub) program. When TRANSB = 'N' or 'n' then LDB must be at least max( 1, k ), otherwise LDB must be at least max( 1, n ). Unchanged on exit. BETA - REAL . On entry, BETA specifies the scalar beta. When BETA is supplied as zero then C need not be set on input. Unchanged on exit. C - REAL array of DIMENSION ( LDC, n ). Before entry, the leading m by n part of the array C must contain the matrix C, except when beta is zero, in which case C need not be set on entry. On exit, the array C is overwritten by the m by n matrix ( alpha*op( A )*op( B ) + beta*C ). LDC - INTEGER. On entry, LDC specifies the first dimension of C as declared in the calling (sub) program. LDC must be at least max( 1, m ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Set NOTA and NOTB as true if A and B respectively are not transposed and set NROWA, NCOLA and NROWB as the number of rows and columns of A and the number of rows of B respectively. Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ nota = lsame_(transa, "N"); notb = lsame_(transb, "N"); if (nota) { nrowa = *m; ncola = *k; } else { nrowa = *k; ncola = *m; } if (notb) { nrowb = *k; } else { nrowb = *n; } /* Test the input parameters. */ info = 0; if (! nota && ! lsame_(transa, "C") && ! lsame_( transa, "T")) { info = 1; } else if (! notb && ! lsame_(transb, "C") && ! lsame_(transb, "T")) { info = 2; } else if (*m < 0) { info = 3; } else if (*n < 0) { info = 4; } else if (*k < 0) { info = 5; } else if (*lda < max(1,nrowa)) { info = 8; } else if (*ldb < max(1,nrowb)) { info = 10; } else if (*ldc < max(1,*m)) { info = 13; } if (info != 0) { xerbla_("SGEMM ", &info); return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { return 0; } /* And if alpha.eq.zero. */ if (*alpha == 0.f) { if (*beta == 0.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L30: */ } /* L40: */ } } return 0; } /* Start the operations. */ if (notb) { if (nota) { /* Form C := alpha*A*B + beta*C. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*beta == 0.f) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L50: */ } } else if (*beta != 1.f) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L60: */ } } i__2 = *k; for (l = 1; l <= i__2; ++l) { if (b_ref(l, j) != 0.f) { temp = *alpha * b_ref(l, j); i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( i__, l); /* L70: */ } } /* L80: */ } /* L90: */ } } else { /* Form C := alpha*A'*B + beta*C */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = 0.f; i__3 = *k; for (l = 1; l <= i__3; ++l) { temp += a_ref(l, i__) * b_ref(l, j); /* L100: */ } if (*beta == 0.f) { c___ref(i__, j) = *alpha * temp; } else { c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, j); } /* L110: */ } /* L120: */ } } } else { if (nota) { /* Form C := alpha*A*B' + beta*C */ i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*beta == 0.f) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.f; /* L130: */ } } else if (*beta != 1.f) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L140: */ } } i__2 = *k; for (l = 1; l <= i__2; ++l) { if (b_ref(j, l) != 0.f) { temp = *alpha * b_ref(j, l); i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( i__, l); /* L150: */ } } /* L160: */ } /* L170: */ } } else { /* Form C := alpha*A'*B' + beta*C */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = 0.f; i__3 = *k; for (l = 1; l <= i__3; ++l) { temp += a_ref(l, i__) * b_ref(j, l); /* L180: */ } if (*beta == 0.f) { c___ref(i__, j) = *alpha * temp; } else { c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, j); } /* L190: */ } /* L200: */ } } } return 0; /* End of SGEMM . */ } /* sgemm_ */
/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer * ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *ldc, doublereal *work, integer *info) { /* System generated locals */ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; /* Local variables */ static integer isub; static doublereal smin; static integer sqre1, i__, j; static doublereal r__; extern logical lsame_(char *, char *); extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), dswap_(integer *, doublereal *, integer * , doublereal *, integer *); static integer iuplo; static doublereal cs, sn; extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), xerbla_(char *, integer *), dbdsqr_(char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); static logical rotate; static integer np1; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] #define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1] #define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1] /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1999 Purpose ======= DLASDQ computes the singular value decomposition (SVD) of a real (upper or lower) bidiagonal matrix with diagonal D and offdiagonal E, accumulating the transformations if desired. Letting B denote the input bidiagonal matrix, the algorithm computes orthogonal matrices Q and P such that B = Q * S * P' (P' denotes the transpose of P). The singular values S are overwritten on D. The input matrix U is changed to U * Q if desired. The input matrix VT is changed to P' * VT if desired. The input matrix C is changed to Q' * C if desired. See "Computing Small Singular Values of Bidiagonal Matrices With Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, LAPACK Working Note #3, for a detailed description of the algorithm. Arguments ========= UPLO (input) CHARACTER*1 On entry, UPLO specifies whether the input bidiagonal matrix is upper or lower bidiagonal, and wether it is square are not. UPLO = 'U' or 'u' B is upper bidiagonal. UPLO = 'L' or 'l' B is lower bidiagonal. SQRE (input) INTEGER = 0: then the input matrix is N-by-N. = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and (N+1)-by-N if UPLU = 'L'. The bidiagonal matrix has N = NL + NR + 1 rows and M = N + SQRE >= N columns. N (input) INTEGER On entry, N specifies the number of rows and columns in the matrix. N must be at least 0. NCVT (input) INTEGER On entry, NCVT specifies the number of columns of the matrix VT. NCVT must be at least 0. NRU (input) INTEGER On entry, NRU specifies the number of rows of the matrix U. NRU must be at least 0. NCC (input) INTEGER On entry, NCC specifies the number of columns of the matrix C. NCC must be at least 0. D (input/output) DOUBLE PRECISION array, dimension (N) On entry, D contains the diagonal entries of the bidiagonal matrix whose SVD is desired. On normal exit, D contains the singular values in ascending order. E (input/output) DOUBLE PRECISION array. dimension is (N-1) if SQRE = 0 and N if SQRE = 1. On entry, the entries of E contain the offdiagonal entries of the bidiagonal matrix whose SVD is desired. On normal exit, E will contain 0. If the algorithm does not converge, D and E will contain the diagonal and superdiagonal entries of a bidiagonal matrix orthogonally equivalent to the one given as input. VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) On entry, contains a matrix which on exit has been premultiplied by P', dimension N-by-NCVT if SQRE = 0 and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). LDVT (input) INTEGER On entry, LDVT specifies the leading dimension of VT as declared in the calling (sub) program. LDVT must be at least 1. If NCVT is nonzero LDVT must also be at least N. U (input/output) DOUBLE PRECISION array, dimension (LDU, N) On entry, contains a matrix which on exit has been postmultiplied by Q, dimension NRU-by-N if SQRE = 0 and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). LDU (input) INTEGER On entry, LDU specifies the leading dimension of U as declared in the calling (sub) program. LDU must be at least max( 1, NRU ) . C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) On entry, contains an N-by-NCC matrix which on exit has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). LDC (input) INTEGER On entry, LDC specifies the leading dimension of C as declared in the calling (sub) program. LDC must be at least 1. If NCC is nonzero, LDC must also be at least N. WORK (workspace) DOUBLE PRECISION array, dimension (4*N) Workspace. Only referenced if one of NCVT, NRU, or NCC is nonzero, and if N is at least 2. INFO (output) INTEGER On exit, a value of 0 indicates a successful exit. If INFO < 0, argument number -INFO is illegal. If INFO > 0, the algorithm did not converge, and INFO specifies how many superdiagonals did not converge. Further Details =============== Based on contributions by Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA ===================================================================== Test the input parameters. Parameter adjustments */ --d__; --e; vt_dim1 = *ldvt; vt_offset = 1 + vt_dim1 * 1; vt -= vt_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; iuplo = 0; if (lsame_(uplo, "U")) { iuplo = 1; } if (lsame_(uplo, "L")) { iuplo = 2; } if (iuplo == 0) { *info = -1; } else if (*sqre < 0 || *sqre > 1) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ncvt < 0) { *info = -4; } else if (*nru < 0) { *info = -5; } else if (*ncc < 0) { *info = -6; } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) { *info = -10; } else if (*ldu < max(1,*nru)) { *info = -12; } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) { *info = -14; } if (*info != 0) { i__1 = -(*info); xerbla_("DLASDQ", &i__1); return 0; } if (*n == 0) { return 0; } /* ROTATE is true if any singular vectors desired, false otherwise */ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; np1 = *n + 1; sqre1 = *sqre; /* If matrix non-square upper bidiagonal, rotate to be lower bidiagonal. The rotations are on the right. */ if (iuplo == 1 && sqre1 == 1) { i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); d__[i__] = r__; e[i__] = sn * d__[i__ + 1]; d__[i__ + 1] = cs * d__[i__ + 1]; if (rotate) { work[i__] = cs; work[*n + i__] = sn; } /* L10: */ } dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); d__[*n] = r__; e[*n] = 0.; if (rotate) { work[*n] = cs; work[*n + *n] = sn; } iuplo = 2; sqre1 = 0; /* Update singular vectors if desired. */ if (*ncvt > 0) { dlasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[ vt_offset], ldvt); } } /* If matrix lower bidiagonal, rotate to be upper bidiagonal by applying Givens rotations on the left. */ if (iuplo == 2) { i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); d__[i__] = r__; e[i__] = sn * d__[i__ + 1]; d__[i__ + 1] = cs * d__[i__ + 1]; if (rotate) { work[i__] = cs; work[*n + i__] = sn; } /* L20: */ } /* If matrix (N+1)-by-N lower bidiagonal, one additional rotation is needed. */ if (sqre1 == 1) { dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); d__[*n] = r__; if (rotate) { work[*n] = cs; work[*n + *n] = sn; } } /* Update singular vectors if desired. */ if (*nru > 0) { if (sqre1 == 0) { dlasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[ u_offset], ldu); } else { dlasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[ u_offset], ldu); } } if (*ncc > 0) { if (sqre1 == 0) { dlasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[ c_offset], ldc); } else { dlasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[ c_offset], ldc); } } } /* Call DBDSQR to compute the SVD of the reduced real N-by-N upper bidiagonal matrix. */ dbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[ u_offset], ldu, &c__[c_offset], ldc, &work[1], info); /* Sort the singular values into ascending order (insertion sort on singular values, but only one transposition per singular vector) */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Scan for smallest D(I). */ isub = i__; smin = d__[i__]; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { if (d__[j] < smin) { isub = j; smin = d__[j]; } /* L30: */ } if (isub != i__) { /* Swap singular values and vectors. */ d__[isub] = d__[i__]; d__[i__] = smin; if (*ncvt > 0) { dswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(i__, 1), ldvt); } if (*nru > 0) { dswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, i__), &c__1); } if (*ncc > 0) { dswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(i__, 1), ldc); } } /* L40: */ } return 0; /* End of DLASDQ */ } /* dlasdq_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, integer *ldc, real *scale, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CTRSYL solves the complex Sylvester matrix equation: op(A)*X + X*op(B) = scale*C or op(A)*X - X*op(B) = scale*C, where op(A) = A or A**H, and A and B are both upper triangular. A is M-by-M and B is N-by-N; the right hand side C and the solution X are M-by-N; and scale is an output scale factor, set <= 1 to avoid overflow in X. Arguments ========= TRANA (input) CHARACTER*1 Specifies the option op(A): = 'N': op(A) = A (No transpose) = 'C': op(A) = A**H (Conjugate transpose) TRANB (input) CHARACTER*1 Specifies the option op(B): = 'N': op(B) = B (No transpose) = 'C': op(B) = B**H (Conjugate transpose) ISGN (input) INTEGER Specifies the sign in the equation: = +1: solve op(A)*X + X*op(B) = scale*C = -1: solve op(A)*X - X*op(B) = scale*C M (input) INTEGER The order of the matrix A, and the number of rows in the matrices X and C. M >= 0. N (input) INTEGER The order of the matrix B, and the number of columns in the matrices X and C. N >= 0. A (input) COMPLEX array, dimension (LDA,M) The upper triangular matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input) COMPLEX array, dimension (LDB,N) The upper triangular matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). C (input/output) COMPLEX array, dimension (LDC,N) On entry, the M-by-N right hand side matrix C. On exit, C is overwritten by the solution matrix X. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M) SCALE (output) REAL The scale factor, scale, set <= 1 to avoid overflow in X. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value = 1: A and B have common or very close eigenvalues; perturbed values were used to solve the equation (but the matrices A and B are unchanged). ===================================================================== Decode and Test input parameters Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static real smin; static complex suml, sumr; static integer j, k, l; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer *, complex *, integer *); static complex a11; static real db; extern /* Subroutine */ int slabad_(real *, real *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static complex x11; extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); static real scaloc; extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *); static real bignum; static logical notrna, notrnb; static real smlnum, da11; static complex vec; static real dum[1], eps, sgn; #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 b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ notrna = lsame_(trana, "N"); notrnb = lsame_(tranb, "N"); *info = 0; if (! notrna && ! lsame_(trana, "T") && ! lsame_( trana, "C")) { *info = -1; } else if (! notrnb && ! lsame_(tranb, "T") && ! lsame_(tranb, "C")) { *info = -2; } else if (*isgn != 1 && *isgn != -1) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*m)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldc < max(1,*m)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("CTRSYL", &i__1); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } /* Set constants to control overflow */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = smlnum * (real) (*m * *n) / eps; bignum = 1.f / smlnum; /* Computing MAX */ r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n, &b[b_offset], ldb, dum); smin = dmax(r__1,r__2); *scale = 1.f; sgn = (real) (*isgn); if (notrna && notrnb) { /* Solve A*X + ISGN*X*B = scale*C. The (K,L)th block of X is determined starting from bottom-left corner column by column by A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) Where M L-1 R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. I=K+1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { for (k = *m; k >= 1; --k) { /* Computing MIN */ i__2 = k + 1; /* Computing MIN */ i__3 = k + 1; i__4 = *m - k; cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref( min(i__3,*m), l), &c__1); suml.r = q__1.r, suml.i = q__1.i; i__2 = l - 1; cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1) ; sumr.r = q__1.r, sumr.i = q__1.i; i__2 = c___subscr(k, l); q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__2 = a_subscr(k, k); i__3 = b_subscr(l, l); q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i; q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L10: */ } *scale *= scaloc; } i__2 = c___subscr(k, l); c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L20: */ } /* L30: */ } } else if (! notrna && notrnb) { /* Solve A' *X + ISGN*X*B = scale*C. The (K,L)th block of X is determined starting from upper-left corner column by column by A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) Where K-1 L-1 R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] I=1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { i__2 = *m; for (k = 1; k <= i__2; ++k) { i__3 = k - 1; cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), & c__1); suml.r = q__1.r, suml.i = q__1.i; i__3 = l - 1; cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1) ; sumr.r = q__1.r, sumr.i = q__1.i; i__3 = c___subscr(k, l); q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; r_cnjg(&q__2, &a_ref(k, k)); i__3 = b_subscr(l, l); q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__3 = *n; for (j = 1; j <= i__3; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L40: */ } *scale *= scaloc; } i__3 = c___subscr(k, l); c__[i__3].r = x11.r, c__[i__3].i = x11.i; /* L50: */ } /* L60: */ } } else if (! notrna && ! notrnb) { /* Solve A'*X + ISGN*X*B' = C. The (K,L)th block of X is determined starting from upper-right corner column by column by A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) Where K-1 R(K,L) = SUM [A'(I,K)*X(I,L)] + I=1 N ISGN*SUM [X(K,J)*B'(L,J)]. J=L+1 */ for (l = *n; l >= 1; --l) { i__1 = *m; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), & c__1); suml.r = q__1.r, suml.i = q__1.i; /* Computing MIN */ i__2 = l + 1; /* Computing MIN */ i__3 = l + 1; i__4 = *n - l; cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l, min(i__3,*n)), ldb); sumr.r = q__1.r, sumr.i = q__1.i; i__2 = c___subscr(k, l); r_cnjg(&q__4, &sumr); q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__2 = a_subscr(k, k); i__3 = b_subscr(l, l); q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i; r_cnjg(&q__1, &q__2); a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L70: */ } *scale *= scaloc; } i__2 = c___subscr(k, l); c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L80: */ } /* L90: */ } } else if (notrna && ! notrnb) { /* Solve A*X + ISGN*X*B' = C. The (K,L)th block of X is determined starting from bottom-left corner column by column by A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) Where M N R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] I=K+1 J=L+1 */ for (l = *n; l >= 1; --l) { for (k = *m; k >= 1; --k) { /* Computing MIN */ i__1 = k + 1; /* Computing MIN */ i__2 = k + 1; i__3 = *m - k; cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref( min(i__2,*m), l), &c__1); suml.r = q__1.r, suml.i = q__1.i; /* Computing MIN */ i__1 = l + 1; /* Computing MIN */ i__2 = l + 1; i__3 = *n - l; cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l, min(i__2,*n)), ldb); sumr.r = q__1.r, sumr.i = q__1.i; i__1 = c___subscr(k, l); r_cnjg(&q__4, &sumr); q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__1 = a_subscr(k, k); r_cnjg(&q__3, &b_ref(l, l)); q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i; q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L100: */ } *scale *= scaloc; } i__1 = c___subscr(k, l); c__[i__1].r = x11.r, c__[i__1].i = x11.i; /* L110: */ } /* L120: */ } } return 0; /* End of CTRSYL */ } /* ctrsyl_ */
/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc, integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real * e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer *ldc, real *work, 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 ======= SGBBRD reduces a real general m-by-n band matrix A to upper bidiagonal form B by an orthogonal transformation: Q' * A * P = B. The routine computes B, and optionally forms Q or P', or computes Q'*C for a given matrix C. Arguments ========= VECT (input) CHARACTER*1 Specifies whether or not the matrices Q and P' are to be formed. = 'N': do not form Q or P'; = 'Q': form Q only; = 'P': form P' only; = 'B': form both. 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. NCC (input) INTEGER The number of columns of the matrix C. NCC >= 0. KL (input) INTEGER The number of subdiagonals of the matrix A. KL >= 0. KU (input) INTEGER The number of superdiagonals of the matrix A. KU >= 0. AB (input/output) REAL array, dimension (LDAB,N) On entry, the m-by-n band matrix A, stored in rows 1 to KL+KU+1. The j-th column of A is stored in the j-th column of the array AB as follows: AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). On exit, A is overwritten by values generated during the reduction. LDAB (input) INTEGER The leading dimension of the array A. LDAB >= KL+KU+1. D (output) REAL array, dimension (min(M,N)) The diagonal elements of the bidiagonal matrix B. E (output) REAL array, dimension (min(M,N)-1) The superdiagonal elements of the bidiagonal matrix B. Q (output) REAL array, dimension (LDQ,M) If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. If VECT = 'N' or 'P', the array Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. PT (output) REAL array, dimension (LDPT,N) If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. If VECT = 'N' or 'Q', the array PT is not referenced. LDPT (input) INTEGER The leading dimension of the array PT. LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. C (input/output) REAL array, dimension (LDC,NCC) On entry, an m-by-ncc matrix C. On exit, C is overwritten by Q'*C. C is not referenced if NCC = 0. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. WORK (workspace) REAL array, dimension (2*max(M,N)) INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. ===================================================================== Test the input parameters Parameter adjustments */ /* Table of constant values */ static real c_b8 = 0.f; static real c_b9 = 1.f; static integer c__1 = 1; /* System generated locals */ integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; /* Local variables */ static integer inca; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); static integer i__, j, l; extern logical lsame_(char *, char *); static logical wantb, wantc; static integer minmn; static logical wantq; static integer j1, j2, kb; static real ra, rb, rc; static integer kk, ml, mn, nr, mu; static real rs; extern /* Subroutine */ int xerbla_(char *, integer *), slaset_( char *, integer *, integer *, real *, real *, real *, integer *), slartg_(real *, real *, real *, real *, real *); static integer kb1; extern /* Subroutine */ int slargv_(integer *, real *, integer *, real *, integer *, real *, integer *); static integer ml0; extern /* Subroutine */ int slartv_(integer *, real *, integer *, real *, integer *, real *, real *, integer *); static logical wantpt; static integer mu0, klm, kun, nrt, klu1; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] #define pt_ref(a_1,a_2) pt[(a_2)*pt_dim1 + a_1] ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --d__; --e; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; pt_dim1 = *ldpt; pt_offset = 1 + pt_dim1 * 1; pt -= pt_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ wantb = lsame_(vect, "B"); wantq = lsame_(vect, "Q") || wantb; wantpt = lsame_(vect, "P") || wantb; wantc = *ncc > 0; klu1 = *kl + *ku + 1; *info = 0; if (! wantq && ! wantpt && ! lsame_(vect, "N")) { *info = -1; } else if (*m < 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ncc < 0) { *info = -4; } else if (*kl < 0) { *info = -5; } else if (*ku < 0) { *info = -6; } else if (*ldab < klu1) { *info = -8; } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) { *info = -12; } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) { *info = -14; } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) { *info = -16; } if (*info != 0) { i__1 = -(*info); xerbla_("SGBBRD", &i__1); return 0; } /* Initialize Q and P' to the unit matrix, if needed */ if (wantq) { slaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq); } if (wantpt) { slaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt); } /* Quick return if possible. */ if (*m == 0 || *n == 0) { return 0; } minmn = min(*m,*n); if (*kl + *ku > 1) { /* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce first to lower bidiagonal form and then transform to upper bidiagonal */ if (*ku > 0) { ml0 = 1; mu0 = 2; } else { ml0 = 2; mu0 = 1; } /* Wherever possible, plane rotations are generated and applied in vector operations of length NR over the index set J1:J2:KLU1. The sines of the plane rotations are stored in WORK(1:max(m,n)) and the cosines in WORK(max(m,n)+1:2*max(m,n)). */ mn = max(*m,*n); /* Computing MIN */ i__1 = *m - 1; klm = min(i__1,*kl); /* Computing MIN */ i__1 = *n - 1; kun = min(i__1,*ku); kb = klm + kun; kb1 = kb + 1; inca = kb1 * *ldab; nr = 0; j1 = klm + 2; j2 = 1 - kun; i__1 = minmn; for (i__ = 1; i__ <= i__1; ++i__) { /* Reduce i-th column and i-th row of matrix to bidiagonal form */ ml = klm + 1; mu = kun + 1; i__2 = kb; for (kk = 1; kk <= i__2; ++kk) { j1 += kb; j2 += kb; /* generate plane rotations to annihilate nonzero elements which have been created below the band */ if (nr > 0) { slargv_(&nr, &ab_ref(klu1, j1 - klm - 1), &inca, &work[j1] , &kb1, &work[mn + j1], &kb1); } /* apply plane rotations from the left */ i__3 = kb; for (l = 1; l <= i__3; ++l) { if (j2 - klm + l - 1 > *n) { nrt = nr - 1; } else { nrt = nr; } if (nrt > 0) { slartv_(&nrt, &ab_ref(klu1 - l, j1 - klm + l - 1), & inca, &ab_ref(klu1 - l + 1, j1 - klm + l - 1), &inca, &work[mn + j1], &work[j1], &kb1); } /* L10: */ } if (ml > ml0) { if (ml <= *m - i__ + 1) { /* generate plane rotation to annihilate a(i+ml-1,i) within the band, and apply rotation from the left */ slartg_(&ab_ref(*ku + ml - 1, i__), &ab_ref(*ku + ml, i__), &work[mn + i__ + ml - 1], &work[i__ + ml - 1], &ra); ab_ref(*ku + ml - 1, i__) = ra; if (i__ < *n) { /* Computing MIN */ i__4 = *ku + ml - 2, i__5 = *n - i__; i__3 = min(i__4,i__5); i__6 = *ldab - 1; i__7 = *ldab - 1; srot_(&i__3, &ab_ref(*ku + ml - 2, i__ + 1), & i__6, &ab_ref(*ku + ml - 1, i__ + 1), & i__7, &work[mn + i__ + ml - 1], &work[i__ + ml - 1]); } } ++nr; j1 -= kb1; } if (wantq) { /* accumulate product of plane rotations in Q */ i__3 = j2; i__4 = kb1; for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { srot_(m, &q_ref(1, j - 1), &c__1, &q_ref(1, j), &c__1, &work[mn + j], &work[j]); /* L20: */ } } if (wantc) { /* apply plane rotations to C */ i__4 = j2; i__3 = kb1; for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { srot_(ncc, &c___ref(j - 1, 1), ldc, &c___ref(j, 1), ldc, &work[mn + j], &work[j]); /* L30: */ } } if (j2 + kun > *n) { /* adjust J2 to keep within the bounds of the matrix */ --nr; j2 -= kb1; } i__3 = j2; i__4 = kb1; for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { /* create nonzero element a(j-1,j+ku) above the band and store it in WORK(n+1:2*n) */ work[j + kun] = work[j] * ab_ref(1, j + kun); ab_ref(1, j + kun) = work[mn + j] * ab_ref(1, j + kun); /* L40: */ } /* generate plane rotations to annihilate nonzero elements which have been generated above the band */ if (nr > 0) { slargv_(&nr, &ab_ref(1, j1 + kun - 1), &inca, &work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1); } /* apply plane rotations from the right */ i__4 = kb; for (l = 1; l <= i__4; ++l) { if (j2 + l - 1 > *m) { nrt = nr - 1; } else { nrt = nr; } if (nrt > 0) { slartv_(&nrt, &ab_ref(l + 1, j1 + kun - 1), &inca, & ab_ref(l, j1 + kun), &inca, &work[mn + j1 + kun], &work[j1 + kun], &kb1); } /* L50: */ } if (ml == ml0 && mu > mu0) { if (mu <= *n - i__ + 1) { /* generate plane rotation to annihilate a(i,i+mu-1) within the band, and apply rotation from the right */ slartg_(&ab_ref(*ku - mu + 3, i__ + mu - 2), &ab_ref(* ku - mu + 2, i__ + mu - 1), &work[mn + i__ + mu - 1], &work[i__ + mu - 1], &ra); ab_ref(*ku - mu + 3, i__ + mu - 2) = ra; /* Computing MIN */ i__3 = *kl + mu - 2, i__5 = *m - i__; i__4 = min(i__3,i__5); srot_(&i__4, &ab_ref(*ku - mu + 4, i__ + mu - 2), & c__1, &ab_ref(*ku - mu + 3, i__ + mu - 1), & c__1, &work[mn + i__ + mu - 1], &work[i__ + mu - 1]); } ++nr; j1 -= kb1; } if (wantpt) { /* accumulate product of plane rotations in P' */ i__4 = j2; i__3 = kb1; for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { srot_(n, &pt_ref(j + kun - 1, 1), ldpt, &pt_ref(j + kun, 1), ldpt, &work[mn + j + kun], &work[j + kun]); /* L60: */ } } if (j2 + kb > *m) { /* adjust J2 to keep within the bounds of the matrix */ --nr; j2 -= kb1; } i__3 = j2; i__4 = kb1; for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { /* create nonzero element a(j+kl+ku,j+ku-1) below the band and store it in WORK(1:n) */ work[j + kb] = work[j + kun] * ab_ref(klu1, j + kun); ab_ref(klu1, j + kun) = work[mn + j + kun] * ab_ref(klu1, j + kun); /* L70: */ } if (ml > ml0) { --ml; } else { --mu; } /* L80: */ } /* L90: */ } } if (*ku == 0 && *kl > 0) { /* A has been reduced to lower bidiagonal form Transform lower bidiagonal form to upper bidiagonal by applying plane rotations from the left, storing diagonal elements in D and off-diagonal elements in E Computing MIN */ i__2 = *m - 1; i__1 = min(i__2,*n); for (i__ = 1; i__ <= i__1; ++i__) { slartg_(&ab_ref(1, i__), &ab_ref(2, i__), &rc, &rs, &ra); d__[i__] = ra; if (i__ < *n) { e[i__] = rs * ab_ref(1, i__ + 1); ab_ref(1, i__ + 1) = rc * ab_ref(1, i__ + 1); } if (wantq) { srot_(m, &q_ref(1, i__), &c__1, &q_ref(1, i__ + 1), &c__1, & rc, &rs); } if (wantc) { srot_(ncc, &c___ref(i__, 1), ldc, &c___ref(i__ + 1, 1), ldc, & rc, &rs); } /* L100: */ } if (*m <= *n) { d__[*m] = ab_ref(1, *m); } } else if (*ku > 0) { /* A has been reduced to upper bidiagonal form */ if (*m < *n) { /* Annihilate a(m,m+1) by applying plane rotations from the right, storing diagonal elements in D and off-diagonal elements in E */ rb = ab_ref(*ku, *m + 1); for (i__ = *m; i__ >= 1; --i__) { slartg_(&ab_ref(*ku + 1, i__), &rb, &rc, &rs, &ra); d__[i__] = ra; if (i__ > 1) { rb = -rs * ab_ref(*ku, i__); e[i__ - 1] = rc * ab_ref(*ku, i__); } if (wantpt) { srot_(n, &pt_ref(i__, 1), ldpt, &pt_ref(*m + 1, 1), ldpt, &rc, &rs); } /* L110: */ } } else { /* Copy off-diagonal elements to E and diagonal elements to D */ i__1 = minmn - 1; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] = ab_ref(*ku, i__ + 1); /* L120: */ } i__1 = minmn; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = ab_ref(*ku + 1, i__); /* L130: */ } } } else { /* A is diagonal. Set elements of E to zero and copy diagonal elements to D. */ i__1 = minmn - 1; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] = 0.f; /* L140: */ } i__1 = minmn; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = ab_ref(1, i__); /* L150: */ } } return 0; /* End of SGBBRD */ } /* sgbbrd_ */
/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * c__, integer *ldc, doublereal *work, integer *lwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DORMQR overwrites the general real M-by-N matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N': Q * C C * Q TRANS = 'T': Q**T * C C * Q**T where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply Q or Q**T from the Left; = 'R': apply Q or Q**T from the Right. TRANS (input) CHARACTER*1 = 'N': No transpose, apply Q; = 'T': Transpose, apply Q**T. M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= 0. A (input) DOUBLE PRECISION array, dimension (LDA,K) The i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by DGEQRF in the first k columns of its array argument A. A is modified by the routine but restored on exit. LDA (input) INTEGER The leading dimension of the array A. If SIDE = 'L', LDA >= max(1,M); if SIDE = 'R', LDA >= max(1,N). TAU (input) DOUBLE PRECISION array, dimension (K) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by DGEQRF. C (input/output) DOUBLE PRECISION array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. If SIDE = 'L', LWORK >= max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum performance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE = 'R', where NB is the optimal blocksize. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static integer c__2 = 2; static integer c__65 = 65; /* System generated locals */ address a__1[2]; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5; char ch__1[2]; /* Builtin functions Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static logical left; static integer i__; static doublereal t[4160] /* was [65][64] */; extern logical lsame_(char *, char *); static integer nbmin, iinfo, i1, i2, i3; extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static integer ib, ic, jc, nb, mi, ni; extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); static integer nq, nw; extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); static logical notran; static integer ldwork, lwkopt; static logical lquery; static integer iws; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L"); notran = lsame_(trans, "N"); lquery = *lwork == -1; /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! notran && ! lsame_(trans, "T")) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < max(1,nq)) { *info = -7; } else if (*ldc < max(1,*m)) { *info = -10; } else if (*lwork < max(1,nw) && ! lquery) { *info = -12; } if (*info == 0) { /* Determine the block size. NB may be at most NBMAX, where NBMAX is used to define the local array T. Computing MIN Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, ( ftnlen)6, (ftnlen)2); nb = min(i__1,i__2); lwkopt = max(1,nw) * nb; work[1] = (doublereal) lwkopt; } if (*info != 0) { i__1 = -(*info); xerbla_("DORMQR", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { work[1] = 1.; return 0; } nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { iws = nw * nb; if (*lwork < iws) { nb = *lwork / ldwork; /* Computing MAX Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1, ( ftnlen)6, (ftnlen)2); nbmin = max(i__1,i__2); } } else { iws = nw; } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo); } else { /* Use blocked code */ if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = nb; } else { i1 = (*k - 1) / nb * nb + 1; i2 = 1; i3 = -nb; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__4 = nb, i__5 = *k - i__ + 1; ib = min(i__4,i__5); /* Form the triangular factor of the block reflector H = H(i) H(i+1) . . . H(i+ib-1) */ i__4 = nq - i__ + 1; dlarft_("Forward", "Columnwise", &i__4, &ib, &a_ref(i__, i__), lda, &tau[i__], t, &c__65); if (left) { /* H or H' is applied to C(i:m,1:n) */ mi = *m - i__ + 1; ic = i__; } else { /* H or H' is applied to C(1:m,i:n) */ ni = *n - i__ + 1; jc = i__; } /* Apply H or H' */ dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, & a_ref(i__, i__), lda, t, &c__65, &c___ref(ic, jc), ldc, & work[1], &ldwork); /* L10: */ } } work[1] = (doublereal) lwkopt; return 0; /* End of DORMQR */ } /* dormqr_ */
/* Subroutine */ int dbdt02_(integer *m, integer *n, doublereal *b, integer * ldb, doublereal *c__, integer *ldc, doublereal *u, integer *ldu, doublereal *work, doublereal *resid) { /* System generated locals */ integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1; doublereal d__1, d__2; /* Local variables */ static integer j; extern /* Subroutine */ int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); extern doublereal dasum_(integer *, doublereal *, integer *); static doublereal bnorm; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); extern doublereal dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *); static doublereal realmn, eps; #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= DBDT02 tests the change of basis C = U' * B by computing the residual RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), where B and C are M by N matrices, U is an M by M orthogonal matrix, and EPS is the machine precision. Arguments ========= M (input) INTEGER The number of rows of the matrices B and C and the order of the matrix Q. N (input) INTEGER The number of columns of the matrices B and C. B (input) DOUBLE PRECISION array, dimension (LDB,N) The m by n matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,M). C (input) DOUBLE PRECISION array, dimension (LDC,N) The m by n matrix C, assumed to contain U' * B. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). U (input) DOUBLE PRECISION array, dimension (LDU,M) The m by m orthogonal matrix U. LDU (input) INTEGER The leading dimension of the array U. LDU >= max(1,M). WORK (workspace) DOUBLE PRECISION array, dimension (M) RESID (output) DOUBLE PRECISION RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), ====================================================================== Quick return if possible Parameter adjustments */ b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; --work; /* Function Body */ *resid = 0.; if (*m <= 0 || *n <= 0) { return 0; } realmn = (doublereal) max(*m,*n); eps = dlamch_("Precision"); /* Compute norm( B - U * C ) */ i__1 = *n; for (j = 1; j <= i__1; ++j) { dcopy_(m, &b_ref(1, j), &c__1, &work[1], &c__1); dgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c___ref(1, j), &c__1, &c_b9, &work[1], &c__1); /* Computing MAX */ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1); *resid = max(d__1,d__2); /* L10: */ } /* Compute norm of B. */ bnorm = dlange_("1", m, n, &b[b_offset], ldb, &work[1]); if (bnorm <= 0.) { if (*resid != 0.) { *resid = 1. / eps; } } else { if (bnorm >= *resid) { *resid = *resid / bnorm / (realmn * eps); } else { if (bnorm < 1.) { /* Computing MIN */ d__1 = *resid, d__2 = realmn * bnorm; *resid = min(d__1,d__2) / bnorm / (realmn * eps); } else { /* Computing MIN */ d__1 = *resid / bnorm; *resid = min(d__1,realmn) / (realmn * eps); } } } return 0; /* End of DBDT02 */ } /* dbdt02_ */
/* Subroutine */ int dlarz_(char *side, integer *m, integer *n, integer *l, doublereal *v, integer *incv, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DLARZ applies a real elementary reflector H to a real M-by-N matrix C, from either the left or the right. H is represented in the form H = I - tau * v * v' where tau is a real scalar and v is a real vector. If tau = 0, then H is taken to be the unit matrix. H is a product of k elementary reflectors as returned by DTZRZF. Arguments ========= SIDE (input) CHARACTER*1 = 'L': form H * C = 'R': form C * H M (input) INTEGER The number of rows of the matrix C. N (input) INTEGER The number of columns of the matrix C. L (input) INTEGER The number of entries of the vector V containing the meaningful part of the Householder vectors. If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV)) The vector v in the representation of H as returned by DTZRZF. V is not used if TAU = 0. INCV (input) INTEGER The increment between elements of v. INCV <> 0. TAU (input) DOUBLE PRECISION The value tau in the representation of H. C (input/output) DOUBLE PRECISION array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by the matrix H * C if SIDE = 'L', or C * H if SIDE = 'R'. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace) DOUBLE PRECISION array, dimension (N) if SIDE = 'L' or (M) if SIDE = 'R' Further Details =============== Based on contributions by A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static doublereal c_b5 = 1.; /* System generated locals */ integer c_dim1, c_offset; doublereal d__1; /* Local variables */ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *) ; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] --v; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ if (lsame_(side, "L")) { /* Form H * C */ if (*tau != 0.) { /* w( 1:n ) = C( 1, 1:n ) */ dcopy_(n, &c__[c_offset], ldc, &work[1], &c__1); /* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) */ dgemv_("Transpose", l, n, &c_b5, &c___ref(*m - *l + 1, 1), ldc, & v[1], incv, &c_b5, &work[1], &c__1); /* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */ d__1 = -(*tau); daxpy_(n, &d__1, &work[1], &c__1, &c__[c_offset], ldc); /* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... tau * v( 1:l ) * w( 1:n )' */ d__1 = -(*tau); dger_(l, n, &d__1, &v[1], incv, &work[1], &c__1, &c___ref(*m - *l + 1, 1), ldc); } } else { /* Form C * H */ if (*tau != 0.) { /* w( 1:m ) = C( 1:m, 1 ) */ dcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1); /* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */ dgemv_("No transpose", m, l, &c_b5, &c___ref(1, *n - *l + 1), ldc, &v[1], incv, &c_b5, &work[1], &c__1); /* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */ d__1 = -(*tau); daxpy_(m, &d__1, &work[1], &c__1, &c__[c_offset], &c__1); /* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... tau * w( 1:m ) * v( 1:l )' */ d__1 = -(*tau); dger_(m, l, &d__1, &work[1], &c__1, &v[1], incv, &c___ref(1, *n - *l + 1), ldc); } } return 0; /* End of DLARZ */ } /* dlarz_ */
/* Subroutine */ int zrqt03_(integer *m, integer *n, integer *k, doublecomplex *af, doublecomplex *c__, doublecomplex *cc, doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, doublereal *rwork, doublereal *result) { /* Initialized data */ static integer iseed[4] = { 1988,1989,1990,1991 }; /* System generated locals */ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1, q_offset, i__1, i__2; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static char side[1]; static integer info, j, iside; extern logical lsame_(char *, char *); static doublereal resid; static integer minmn; static doublereal cnorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static char trans[1]; static integer mc, nc; extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); static integer itrans; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlarnv_( integer *, integer *, integer *, doublecomplex *), zungrq_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmrq_( char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); static doublereal eps; #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] #define 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 ======= ZRQT03 tests ZUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. ZRQT03 compares the results of a call to ZUNMRQ with the results of forming Q explicitly by a call to ZUNGRQ and then performing matrix multiplication by a call to ZGEMM. Arguments ========= M (input) INTEGER The number of rows or columns of the matrix C; C is n-by-m if Q is applied from the left, or m-by-n if Q is applied from the right. M >= 0. N (input) INTEGER The order of the orthogonal matrix Q. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the orthogonal matrix Q. N >= K >= 0. AF (input) COMPLEX*16 array, dimension (LDA,N) Details of the RQ factorization of an m-by-n matrix, as returned by ZGERQF. See CGERQF for further details. C (workspace) COMPLEX*16 array, dimension (LDA,N) CC (workspace) COMPLEX*16 array, dimension (LDA,N) Q (workspace) COMPLEX*16 array, dimension (LDA,N) LDA (input) INTEGER The leading dimension of the arrays AF, C, CC, and Q. TAU (input) COMPLEX*16 array, dimension (min(M,N)) 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 length of WORK. LWORK must be at least M, and should be M*NB, where NB is the blocksize for this environment. RWORK (workspace) DOUBLE PRECISION array, dimension (M) RESULT (output) DOUBLE PRECISION array, dimension (4) The test ratios compare two techniques for multiplying a random matrix C by an n-by-n orthogonal matrix Q. RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) ===================================================================== Parameter adjustments */ q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; cc_dim1 = *lda; cc_offset = 1 + cc_dim1 * 1; cc -= cc_offset; c_dim1 = *lda; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = dlamch_("Epsilon"); minmn = min(*m,*n); /* Quick return if possible */ if (minmn == 0) { result[1] = 0.; result[2] = 0.; result[3] = 0.; result[4] = 0.; return 0; } /* Copy the last k rows of the factorization to the array Q */ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda); if (*k > 0 && *n > *k) { i__1 = *n - *k; zlacpy_("Full", k, &i__1, &af_ref(*m - *k + 1, 1), lda, &q_ref(*n - * k + 1, 1), lda); } if (*k > 1) { i__1 = *k - 1; i__2 = *k - 1; zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *k + 2, *n - *k + 1), lda, &q_ref(*n - *k + 2, *n - *k + 1), lda); } /* Generate the n-by-n matrix Q */ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6); zungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork, &info); for (iside = 1; iside <= 2; ++iside) { if (iside == 1) { *(unsigned char *)side = 'L'; mc = *n; nc = *m; } else { *(unsigned char *)side = 'R'; mc = *m; nc = *n; } /* Generate MC by NC matrix C */ i__1 = nc; for (j = 1; j <= i__1; ++j) { zlarnv_(&c__2, iseed, &mc, &c___ref(1, j)); /* L10: */ } cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]); if (cnorm == 0.) { cnorm = 1.; } for (itrans = 1; itrans <= 2; ++itrans) { if (itrans == 1) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'C'; } /* Copy C */ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset], lda); /* Apply Q or Q' to C */ s_copy(srnamc_1.srnamt, "ZUNMRQ", (ftnlen)6, (ftnlen)6); if (*k > 0) { zunmrq_(side, trans, &mc, &nc, k, &af_ref(*m - *k + 1, 1), lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[ 1], lwork, &info); } /* Form explicit product and subtract */ if (lsame_(side, "L")) { zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[ cc_offset], lda); } else { zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[ cc_offset], lda); } /* Compute error in the difference */ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]); result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,* n) * cnorm * eps); /* L20: */ } /* L30: */ } return 0; /* End of ZRQT03 */ } /* zrqt03_ */
/* Subroutine */ int cunmrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, complex *a, integer *lda, complex *tau, complex *c__, integer *ldc, complex *work, integer *lwork, integer * info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CUNMRZ overwrites the general complex M-by-N matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N': Q * C C * Q TRANS = 'C': Q**H * C C * Q**H where Q is a complex unitary matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply Q or Q**H from the Left; = 'R': apply Q or Q**H from the Right. TRANS (input) CHARACTER*1 = 'N': No transpose, apply Q; = 'C': Conjugate transpose, apply Q**H. M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= 0. L (input) INTEGER The number of columns of the matrix A containing the meaningful part of the Householder reflectors. If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. A (input) COMPLEX array, dimension (LDA,M) if SIDE = 'L', (LDA,N) if SIDE = 'R' The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by CTZRZF in the last k rows of its array argument A. A is modified by the routine but restored on exit. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,K). TAU (input) COMPLEX array, dimension (K) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by CTZRZF. C (input/output) COMPLEX array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace/output) COMPLEX array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. If SIDE = 'L', LWORK >= max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum performance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE = 'R', where NB is the optimal blocksize. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Further Details =============== Based on contributions by A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ===================================================================== Test the input arguments Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static integer c__2 = 2; static integer c__65 = 65; /* System generated locals */ address a__1[2]; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5; char ch__1[2]; /* Builtin functions Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static logical left; static integer i__; static complex t[4160] /* was [65][64] */; extern logical lsame_(char *, char *); static integer nbmin, iinfo, i1, i2, i3; extern /* Subroutine */ int cunmr3_(char *, char *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *); static integer ib, ic, ja, jc, nb, mi, ni, nq, nw; extern /* Subroutine */ int clarzb_(char *, char *, char *, char *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *), clarzt_( char *, char *, integer *, integer *, complex *, integer *, complex *, complex *, integer *); static logical notran; static integer ldwork; static char transt[1]; static integer lwkopt; static logical lquery; static integer iws; #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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L"); notran = lsame_(trans, "N"); lquery = *lwork == -1; /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! notran && ! lsame_(trans, "C")) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { *info = -6; } else if (*lda < max(1,*k)) { *info = -8; } else if (*ldc < max(1,*m)) { *info = -11; } else if (*lwork < max(1,nw) && ! lquery) { *info = -13; } if (*info == 0) { /* Determine the block size. NB may be at most NBMAX, where NBMAX is used to define the local array T. Computing MIN Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1, ( ftnlen)6, (ftnlen)2); nb = min(i__1,i__2); lwkopt = max(1,nw) * nb; work[1].r = (real) lwkopt, work[1].i = 0.f; } if (*info != 0) { i__1 = -(*info); xerbla_("CUNMRZ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { work[1].r = 1.f, work[1].i = 0.f; return 0; } /* Determine the block size. NB may be at most NBMAX, where NBMAX is used to define the local array T. Computing MIN Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1, (ftnlen) 6, (ftnlen)2); nb = min(i__1,i__2); nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { iws = nw * nb; if (*lwork < iws) { nb = *lwork / ldwork; /* Computing MAX Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMRQ", ch__1, m, n, k, &c_n1, ( ftnlen)6, (ftnlen)2); nbmin = max(i__1,i__2); } } else { iws = nw; } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ cunmr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo); } else { /* Use blocked code */ if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = nb; } else { i1 = (*k - 1) / nb * nb + 1; i2 = 1; i3 = -nb; } if (left) { ni = *n; jc = 1; ja = *m - *l + 1; } else { mi = *m; ic = 1; ja = *n - *l + 1; } if (notran) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'N'; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__4 = nb, i__5 = *k - i__ + 1; ib = min(i__4,i__5); /* Form the triangular factor of the block reflector H = H(i+ib-1) . . . H(i+1) H(i) */ clarzt_("Backward", "Rowwise", l, &ib, &a_ref(i__, ja), lda, &tau[ i__], t, &c__65); if (left) { /* H or H' is applied to C(i:m,1:n) */ mi = *m - i__ + 1; ic = i__; } else { /* H or H' is applied to C(1:m,i:n) */ ni = *n - i__ + 1; jc = i__; } /* Apply H or H' */ clarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, & a_ref(i__, ja), lda, t, &c__65, &c___ref(ic, jc), ldc, & work[1], &ldwork); /* L10: */ } } work[1].r = (real) lwkopt, work[1].i = 0.f; return 0; /* End of CUNMRZ */ } /* cunmrz_ */
/* Subroutine */ int dormhr_(char *side, char *trans, integer *m, integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal * tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DORMHR overwrites the general real M-by-N matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N': Q * C C * Q TRANS = 'T': Q**T * C C * Q**T where Q is a real orthogonal matrix of order nq, with nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of IHI-ILO elementary reflectors, as returned by DGEHRD: Q = H(ilo) H(ilo+1) . . . H(ihi-1). Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply Q or Q**T from the Left; = 'R': apply Q or Q**T from the Right. TRANS (input) CHARACTER*1 = 'N': No transpose, apply Q; = 'T': Transpose, apply Q**T. M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. ILO (input) INTEGER IHI (input) INTEGER ILO and IHI must have the same values as in the previous call of DGEHRD. Q is equal to the unit matrix except in the submatrix Q(ilo+1:ihi,ilo+1:ihi). If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and ILO = 1 and IHI = 0, if M = 0; if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and ILO = 1 and IHI = 0, if N = 0. A (input) DOUBLE PRECISION array, dimension (LDA,M) if SIDE = 'L' (LDA,N) if SIDE = 'R' The vectors which define the elementary reflectors, as returned by DGEHRD. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' (N-1) if SIDE = 'R' TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by DGEHRD. C (input/output) DOUBLE PRECISION array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. If SIDE = 'L', LWORK >= max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum performance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE = 'R', where NB is the optimal blocksize. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static integer c__2 = 2; /* System generated locals */ address a__1[2]; integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2; char ch__1[2]; /* Builtin functions Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static logical left; extern logical lsame_(char *, char *); static integer iinfo, i1, i2, nb, mi, nh, ni, nq, nw; extern /* Subroutine */ int xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *); static integer lwkopt; static logical lquery; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; nh = *ihi - *ilo; left = lsame_(side, "L"); lquery = *lwork == -1; /* NQ is the order of Q and NW is the minimum dimension of WORK */ if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! lsame_(trans, "N") && ! lsame_(trans, "T")) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ilo < 1 || *ilo > max(1,nq)) { *info = -5; } else if (*ihi < min(*ilo,nq) || *ihi > nq) { *info = -6; } else if (*lda < max(1,nq)) { *info = -8; } else if (*ldc < max(1,*m)) { *info = -11; } else if (*lwork < max(1,nw) && ! lquery) { *info = -13; } if (*info == 0) { if (left) { /* Writing concatenation */ i__1[0] = 1, a__1[0] = side; i__1[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); nb = ilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &c_n1, (ftnlen) 6, (ftnlen)2); } else { /* Writing concatenation */ i__1[0] = 1, a__1[0] = side; i__1[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1, (ftnlen) 6, (ftnlen)2); } lwkopt = max(1,nw) * nb; work[1] = (doublereal) lwkopt; } if (*info != 0) { i__2 = -(*info); xerbla_("DORMHR", &i__2); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || nh == 0) { work[1] = 1.; return 0; } if (left) { mi = nh; ni = *n; i1 = *ilo + 1; i2 = 1; } else { mi = *m; ni = nh; i1 = 1; i2 = *ilo + 1; } dormqr_(side, trans, &mi, &ni, &nh, &a_ref(*ilo + 1, *ilo), lda, &tau[* ilo], &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo); work[1] = (doublereal) lwkopt; return 0; /* End of DORMHR */ } /* dormhr_ */
/* Subroutine */ int cunmbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c__, integer *ldc, complex *work, integer *lwork, integer * info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N': Q * C C * Q TRANS = 'C': Q**H * C C * Q**H If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N': P * C C * P TRANS = 'C': P**H * C C * P**H Here Q and P**H are the unitary matrices determined by CGEBRD when reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q and P**H are defined as products of elementary reflectors H(i) and G(i) respectively. Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the order of the unitary matrix Q or P**H that is applied. If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: if nq >= k, Q = H(1) H(2) . . . H(k); if nq < k, Q = H(1) H(2) . . . H(nq-1). If VECT = 'P', A is assumed to have been a K-by-NQ matrix: if k < nq, P = G(1) G(2) . . . G(k); if k >= nq, P = G(1) G(2) . . . G(nq-1). Arguments ========= VECT (input) CHARACTER*1 = 'Q': apply Q or Q**H; = 'P': apply P or P**H. SIDE (input) CHARACTER*1 = 'L': apply Q, Q**H, P or P**H from the Left; = 'R': apply Q, Q**H, P or P**H from the Right. TRANS (input) CHARACTER*1 = 'N': No transpose, apply Q or P; = 'C': Conjugate transpose, apply Q**H or P**H. M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. K (input) INTEGER If VECT = 'Q', the number of columns in the original matrix reduced by CGEBRD. If VECT = 'P', the number of rows in the original matrix reduced by CGEBRD. K >= 0. A (input) COMPLEX array, dimension (LDA,min(nq,K)) if VECT = 'Q' (LDA,nq) if VECT = 'P' The vectors which define the elementary reflectors H(i) and G(i), whose products determine the matrices Q and P, as returned by CGEBRD. LDA (input) INTEGER The leading dimension of the array A. If VECT = 'Q', LDA >= max(1,nq); if VECT = 'P', LDA >= max(1,min(nq,K)). TAU (input) COMPLEX array, dimension (min(nq,K)) TAU(i) must contain the scalar factor of the elementary reflector H(i) or G(i) which determines Q or P, as returned by CGEBRD in the array argument TAUQ or TAUP. C (input/output) COMPLEX array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q or P*C or P**H*C or C*P or C*P**H. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace/output) COMPLEX array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. If SIDE = 'L', LWORK >= max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum performance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE = 'R', where NB is the optimal blocksize. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static integer c__2 = 2; /* System generated locals */ address a__1[2]; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; char ch__1[2]; /* Builtin functions Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static logical left; extern logical lsame_(char *, char *); static integer iinfo, i1, i2, nb, mi, ni, nq, nw; extern /* Subroutine */ int xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int cunmlq_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); static logical notran; extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); static logical applyq; static char transt[1]; static integer lwkopt; static logical lquery; #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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; applyq = lsame_(vect, "Q"); left = lsame_(side, "L"); notran = lsame_(trans, "N"); lquery = *lwork == -1; /* NQ is the order of Q or P and NW is the minimum dimension of WORK */ if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! applyq && ! lsame_(vect, "P")) { *info = -1; } else if (! left && ! lsame_(side, "R")) { *info = -2; } else if (! notran && ! lsame_(trans, "C")) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*k < 0) { *info = -6; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = 1, i__2 = min(nq,*k); if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { *info = -8; } else if (*ldc < max(1,*m)) { *info = -11; } else if (*lwork < max(1,nw) && ! lquery) { *info = -13; } } if (*info == 0) { if (applyq) { if (left) { /* Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = *m - 1; i__2 = *m - 1; nb = ilaenv_(&c__1, "CUNMQR", ch__1, &i__1, n, &i__2, &c_n1, ( ftnlen)6, (ftnlen)2); } else { /* Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = *n - 1; i__2 = *n - 1; nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &i__1, &i__2, &c_n1, ( ftnlen)6, (ftnlen)2); } } else { if (left) { /* Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = *m - 1; i__2 = *m - 1; nb = ilaenv_(&c__1, "CUNMLQ", ch__1, &i__1, n, &i__2, &c_n1, ( ftnlen)6, (ftnlen)2); } else { /* Writing concatenation */ i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); i__1 = *n - 1; i__2 = *n - 1; nb = ilaenv_(&c__1, "CUNMLQ", ch__1, m, &i__1, &i__2, &c_n1, ( ftnlen)6, (ftnlen)2); } } lwkopt = max(1,nw) * nb; work[1].r = (real) lwkopt, work[1].i = 0.f; } if (*info != 0) { i__1 = -(*info); xerbla_("CUNMBR", &i__1); return 0; } else if (lquery) { } /* Quick return if possible */ work[1].r = 1.f, work[1].i = 0.f; if (*m == 0 || *n == 0) { return 0; } if (applyq) { /* Apply Q */ if (nq >= *k) { /* Q was determined by a call to CGEBRD with nq >= k */ cunmqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], lwork, &iinfo); } else if (nq > 1) { /* Q was determined by a call to CGEBRD with nq < k */ if (left) { mi = *m - 1; ni = *n; i1 = 2; i2 = 1; } else { mi = *m; ni = *n - 1; i1 = 1; i2 = 2; } i__1 = nq - 1; cunmqr_(side, trans, &mi, &ni, &i__1, &a_ref(2, 1), lda, &tau[1], &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo); } } else { /* Apply P */ if (notran) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'N'; } if (nq > *k) { /* P was determined by a call to CGEBRD with nq > k */ cunmlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], lwork, &iinfo); } else if (nq > 1) { /* P was determined by a call to CGEBRD with nq <= k */ if (left) { mi = *m - 1; ni = *n; i1 = 2; i2 = 1; } else { mi = *m; ni = *n - 1; i1 = 1; i2 = 2; } i__1 = nq - 1; cunmlq_(side, transt, &mi, &ni, &i__1, &a_ref(1, 2), lda, &tau[1], &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo); } } work[1].r = (real) lwkopt, work[1].i = 0.f; return 0; /* End of CUNMBR */ } /* cunmbr_ */
/* Subroutine */ int dopmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, doublereal *ap, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work, 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 ======= DOPMTR overwrites the general real M-by-N matrix C with SIDE = 'L' SIDE = 'R' TRANS = 'N': Q * C C * Q TRANS = 'T': Q**T * C C * Q**T where Q is a real orthogonal matrix of order nq, with nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of nq-1 elementary reflectors, as returned by DSPTRD using packed storage: if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply Q or Q**T from the Left; = 'R': apply Q or Q**T from the Right. UPLO (input) CHARACTER*1 = 'U': Upper triangular packed storage used in previous call to DSPTRD; = 'L': Lower triangular packed storage used in previous call to DSPTRD. TRANS (input) CHARACTER*1 = 'N': No transpose, apply Q; = 'T': Transpose, apply Q**T. M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. AP (input) DOUBLE PRECISION array, dimension (M*(M+1)/2) if SIDE = 'L' (N*(N+1)/2) if SIDE = 'R' The vectors which define the elementary reflectors, as returned by DSPTRD. AP is modified by the routine but restored on exit. TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' or (N-1) if SIDE = 'R' TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by DSPTRD. C (input/output) DOUBLE PRECISION array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace) DOUBLE PRECISION array, dimension (N) if SIDE = 'L' (M) if SIDE = 'R' INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer c_dim1, c_offset, i__1, i__2; /* Local variables */ static logical left; static integer i__; extern /* Subroutine */ int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *); extern logical lsame_(char *, char *); static integer i1; static logical upper; static integer i2, i3, ic, jc, ii, mi, ni, nq; extern /* Subroutine */ int xerbla_(char *, integer *); static logical notran, forwrd; static doublereal aii; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] --ap; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L"); notran = lsame_(trans, "N"); upper = lsame_(uplo, "U"); /* NQ is the order of Q */ if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! notran && ! lsame_(trans, "T")) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*ldc < max(1,*m)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("DOPMTR", &i__1); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } if (upper) { /* Q was determined by a call to DSPTRD with UPLO = 'U' */ forwrd = left && notran || ! left && ! notran; if (forwrd) { i1 = 1; i2 = nq - 1; i3 = 1; ii = 2; } else { i1 = nq - 1; i2 = 1; i3 = -1; ii = nq * (nq + 1) / 2 - 1; } if (left) { ni = *n; } else { mi = *m; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { if (left) { /* H(i) is applied to C(1:i,1:n) */ mi = i__; } else { /* H(i) is applied to C(1:m,1:i) */ ni = i__; } /* Apply H(i) */ aii = ap[ii]; ap[ii] = 1.; dlarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &tau[i__], &c__[ c_offset], ldc, &work[1]); ap[ii] = aii; if (forwrd) { ii = ii + i__ + 2; } else { ii = ii - i__ - 1; } /* L10: */ } } else { /* Q was determined by a call to DSPTRD with UPLO = 'L'. */ forwrd = left && ! notran || ! left && notran; if (forwrd) { i1 = 1; i2 = nq - 1; i3 = 1; ii = 2; } else { i1 = nq - 1; i2 = 1; i3 = -1; ii = nq * (nq + 1) / 2 - 1; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__2 = i2; i__1 = i3; for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { aii = ap[ii]; ap[ii] = 1.; if (left) { /* H(i) is applied to C(i+1:m,1:n) */ mi = *m - i__; ic = i__ + 1; } else { /* H(i) is applied to C(1:m,i+1:n) */ ni = *n - i__; jc = i__ + 1; } /* Apply H(i) */ dlarf_(side, &mi, &ni, &ap[ii], &c__1, &tau[i__], &c___ref(ic, jc) , ldc, &work[1]); ap[ii] = aii; if (forwrd) { ii = ii + nq - i__ + 1; } else { ii = ii - nq + i__ - 2; } /* L20: */ } } return 0; /* End of DOPMTR */ } /* dopmtr_ */
/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char * storev, integer *m, integer *n, integer *k, doublereal *v, integer * ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, doublereal *work, integer *ldwork) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= DLARFB applies a real block reflector H or its transpose H' to a real m by n matrix C, from either the left or the right. Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply H or H' from the Left = 'R': apply H or H' from the Right TRANS (input) CHARACTER*1 = 'N': apply H (No transpose) = 'T': apply H' (Transpose) DIRECT (input) CHARACTER*1 Indicates how H is formed from a product of elementary reflectors = 'F': H = H(1) H(2) . . . H(k) (Forward) = 'B': H = H(k) . . . H(2) H(1) (Backward) STOREV (input) CHARACTER*1 Indicates how the vectors which define the elementary reflectors are stored: = 'C': Columnwise = 'R': Rowwise M (input) INTEGER The number of rows of the matrix C. N (input) INTEGER The number of columns of the matrix C. K (input) INTEGER The order of the matrix T (= the number of elementary reflectors whose product defines the block reflector). V (input) DOUBLE PRECISION array, dimension (LDV,K) if STOREV = 'C' (LDV,M) if STOREV = 'R' and SIDE = 'L' (LDV,N) if STOREV = 'R' and SIDE = 'R' The matrix V. See further details. LDV (input) INTEGER The leading dimension of the array V. If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); if STOREV = 'R', LDV >= K. T (input) DOUBLE PRECISION array, dimension (LDT,K) The triangular k by k matrix T in the representation of the block reflector. LDT (input) INTEGER The leading dimension of the array T. LDT >= K. C (input/output) DOUBLE PRECISION array, dimension (LDC,N) On entry, the m by n matrix C. On exit, C is overwritten by H*C or H'*C or C*H or C*H'. LDC (input) INTEGER The leading dimension of the array C. LDA >= max(1,M). WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) LDWORK (input) INTEGER The leading dimension of the array WORK. If SIDE = 'L', LDWORK >= max(1,N); if SIDE = 'R', LDWORK >= max(1,M). ===================================================================== Quick return if possible Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static doublereal c_b14 = 1.; static doublereal c_b25 = -1.; /* System generated locals */ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2; /* Local variables */ static integer i__, j; extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static char transt[1]; #define work_ref(a_1,a_2) work[(a_2)*work_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1] v_dim1 = *ldv; v_offset = 1 + v_dim1 * 1; v -= v_offset; t_dim1 = *ldt; t_offset = 1 + t_dim1 * 1; t -= t_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; work_dim1 = *ldwork; work_offset = 1 + work_dim1 * 1; work -= work_offset; /* Function Body */ if (*m <= 0 || *n <= 0) { return 0; } if (lsame_(trans, "N")) { *(unsigned char *)transt = 'T'; } else { *(unsigned char *)transt = 'N'; } if (lsame_(storev, "C")) { if (lsame_(direct, "F")) { /* Let V = ( V1 ) (first K rows) ( V2 ) where V1 is unit lower triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) W := C1' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1); /* L10: */ } /* W := W * V1 */ dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C2'*V2 */ i__1 = *m - *k; dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & c___ref(*k + 1, 1), ldc, &v_ref(*k + 1, 1), ldv, & c_b14, &work[work_offset], ldwork); } /* W := W * T' or W * T */ dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V * W' */ if (*m > *k) { /* C2 := C2 - V2 * W' */ i__1 = *m - *k; dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & v_ref(*k + 1, 1), ldv, &work[work_offset], ldwork, &c_b14, &c___ref(*k + 1, 1), ldc); } /* W := W * V1' */ dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j); /* L20: */ } /* L30: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V = (C1*V1 + C2*V2) (stored in WORK) W := C1 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1); /* L40: */ } /* W := W * V1 */ dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C2 * V2 */ i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, k, &i__1, & c_b14, &c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1) , ldv, &c_b14, &work[work_offset], ldwork); } /* W := W * T or W * T' */ dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V' */ if (*n > *k) { /* C2 := C2 - W * V2' */ i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & work[work_offset], ldwork, &v_ref(*k + 1, 1), ldv, &c_b14, &c___ref(1, *k + 1), ldc); } /* W := W * V1' */ dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j); /* L50: */ } /* L60: */ } } } else { /* Let V = ( V1 ) ( V2 ) (last K rows) where V2 is unit upper triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) W := C2' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), &c__1); /* L70: */ } /* W := W * V2 */ dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, &v_ref(*m - *k + 1, 1), ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C1'*V1 */ i__1 = *m - *k; dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & work[work_offset], ldwork); } /* W := W * T' or W * T */ dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V * W' */ if (*m > *k) { /* C1 := C1 - V1 * W' */ i__1 = *m - *k; dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & v[v_offset], ldv, &work[work_offset], ldwork, & c_b14, &c__[c_offset], ldc) ; } /* W := W * V2' */ dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & v_ref(*m - *k + 1, 1), ldv, &work[work_offset], ldwork); /* C2 := C2 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__) - work_ref(i__, j); /* L80: */ } /* L90: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V = (C1*V1 + C2*V2) (stored in WORK) W := C2 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j) , &c__1); /* L100: */ } /* W := W * V2 */ dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14, &v_ref(*n - *k + 1, 1), ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C1 * V1 */ i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, k, &i__1, & c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b14, &work[work_offset], ldwork); } /* W := W * T or W * T' */ dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V' */ if (*n > *k) { /* C1 := C1 - W * V1' */ i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & work[work_offset], ldwork, &v[v_offset], ldv, & c_b14, &c__[c_offset], ldc) ; } /* W := W * V2' */ dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & v_ref(*n - *k + 1, 1), ldv, &work[work_offset], ldwork); /* C2 := C2 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j) - work_ref(i__, j); /* L110: */ } /* L120: */ } } } } else if (lsame_(storev, "R")) { if (lsame_(direct, "F")) { /* Let V = ( V1 V2 ) (V1: first K columns) where V1 is unit upper triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) W := C1' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1); /* L130: */ } /* W := W * V1' */ dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & v[v_offset], ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C2'*V2' */ i__1 = *m - *k; dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & c___ref(*k + 1, 1), ldc, &v_ref(1, *k + 1), ldv, & c_b14, &work[work_offset], ldwork); } /* W := W * T' or W * T */ dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V' * W' */ if (*m > *k) { /* C2 := C2 - V2' * W' */ i__1 = *m - *k; dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, & v_ref(1, *k + 1), ldv, &work[work_offset], ldwork, &c_b14, &c___ref(*k + 1, 1), ldc); } /* W := W * V1 */ dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j); /* L140: */ } /* L150: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V' = (C1*V1' + C2*V2') (stored in WORK) W := C1 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1); /* L160: */ } /* W := W * V1' */ dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & v[v_offset], ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C2 * V2' */ i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, & c___ref(1, *k + 1), ldc, &v_ref(1, *k + 1), ldv, & c_b14, &work[work_offset], ldwork); } /* W := W * T or W * T' */ dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V */ if (*n > *k) { /* C2 := C2 - W * V2 */ i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, &i__1, k, & c_b25, &work[work_offset], ldwork, &v_ref(1, *k + 1), ldv, &c_b14, &c___ref(1, *k + 1), ldc); } /* W := W * V1 */ dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j); /* L170: */ } /* L180: */ } } } else { /* Let V = ( V1 V2 ) (V2: last K columns) where V2 is unit lower triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) W := C2' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), &c__1); /* L190: */ } /* W := W * V2' */ dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & v_ref(1, *m - *k + 1), ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C1'*V1' */ i__1 = *m - *k; dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & work[work_offset], ldwork); } /* W := W * T' or W * T */ dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V' * W' */ if (*m > *k) { /* C1 := C1 - V1' * W' */ i__1 = *m - *k; dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[ v_offset], ldv, &work[work_offset], ldwork, & c_b14, &c__[c_offset], ldc); } /* W := W * V2 */ dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, &v_ref(1, *m - *k + 1), ldv, &work[work_offset], ldwork); /* C2 := C2 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__) - work_ref(i__, j); /* L200: */ } /* L210: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V' = (C1*V1' + C2*V2') (stored in WORK) W := C2 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j) , &c__1); /* L220: */ } /* W := W * V2' */ dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & v_ref(1, *n - *k + 1), ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C1 * V1' */ i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & work[work_offset], ldwork); } /* W := W * T or W * T' */ dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V */ if (*n > *k) { /* C1 := C1 - W * V1 */ i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, &i__1, k, & c_b25, &work[work_offset], ldwork, &v[v_offset], ldv, &c_b14, &c__[c_offset], ldc); } /* W := W * V2 */ dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, &v_ref(1, *n - *k + 1), ldv, &work[work_offset], ldwork); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j) - work_ref(i__, j); /* L230: */ } /* L240: */ } } } } return 0; /* End of DLARFB */ } /* dlarfb_ */
/* Subroutine */ int sqrt03_(integer *m, integer *n, integer *k, real *af, real *c__, real *cc, real *q, integer *lda, real *tau, real *work, integer *lwork, real *rwork, real *result) { /* Initialized data */ static integer iseed[4] = { 1988,1989,1990,1991 }; /* System generated locals */ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1, q_offset, i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static char side[1]; static integer info, j, iside; extern logical lsame_(char *, char *); static real resid; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real cnorm; static char trans[1]; static integer mc, nc; extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *); static integer itrans; extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real *), sorgqr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), sormqr_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real * , integer *, real *, integer *, integer *); static real eps; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1] /* -- 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 ======= SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'. SQRT03 compares the results of a call to SORMQR with the results of forming Q explicitly by a call to SORGQR and then performing matrix multiplication by a call to SGEMM. Arguments ========= M (input) INTEGER The order of the orthogonal matrix Q. M >= 0. N (input) INTEGER The number of rows or columns of the matrix C; C is m-by-n if Q is applied from the left, or n-by-m if Q is applied from the right. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the orthogonal matrix Q. M >= K >= 0. AF (input) REAL array, dimension (LDA,N) Details of the QR factorization of an m-by-n matrix, as returnedby SGEQRF. See SGEQRF for further details. C (workspace) REAL array, dimension (LDA,N) CC (workspace) REAL array, dimension (LDA,N) Q (workspace) REAL array, dimension (LDA,M) LDA (input) INTEGER The leading dimension of the arrays AF, C, CC, and Q. TAU (input) REAL array, dimension (min(M,N)) The scalar factors of the elementary reflectors corresponding to the QR factorization in AF. WORK (workspace) REAL array, dimension (LWORK) LWORK (input) INTEGER The length of WORK. LWORK must be at least M, and should be M*NB, where NB is the blocksize for this environment. RWORK (workspace) REAL array, dimension (M) RESULT (output) REAL array, dimension (4) The test ratios compare two techniques for multiplying a random matrix C by an m-by-m orthogonal matrix Q. RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) ===================================================================== Parameter adjustments */ q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; cc_dim1 = *lda; cc_offset = 1 + cc_dim1 * 1; cc -= cc_offset; c_dim1 = *lda; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = slamch_("Epsilon"); /* Copy the first k columns of the factorization to the array Q */ slaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda); i__1 = *m - 1; slacpy_("Lower", &i__1, k, &af_ref(2, 1), lda, &q_ref(2, 1), lda); /* Generate the m-by-m matrix Q */ s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)6, (ftnlen)6); sorgqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info); for (iside = 1; iside <= 2; ++iside) { if (iside == 1) { *(unsigned char *)side = 'L'; mc = *m; nc = *n; } else { *(unsigned char *)side = 'R'; mc = *n; nc = *m; } /* Generate MC by NC matrix C */ i__1 = nc; for (j = 1; j <= i__1; ++j) { slarnv_(&c__2, iseed, &mc, &c___ref(1, j)); /* L10: */ } cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]); if (cnorm == 0.f) { cnorm = 1.f; } for (itrans = 1; itrans <= 2; ++itrans) { if (itrans == 1) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } /* Copy C */ slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset], lda); /* Apply Q or Q' to C */ s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)6, (ftnlen)6); sormqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], & cc[cc_offset], lda, &work[1], lwork, &info); /* Form explicit product and subtract */ if (lsame_(side, "L")) { sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[ cc_offset], lda); } else { sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[ cc_offset], lda); } /* Compute error in the difference */ resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]); result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) * cnorm * eps); /* L20: */ } /* L30: */ } return 0; /* End of SQRT03 */ } /* sqrt03_ */
/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer * nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt, integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__, integer *ldc, doublereal *rwork, integer *info) { /* System generated locals */ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; doublereal d__1, d__2, d__3, d__4; /* Builtin functions */ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign( doublereal *, doublereal *); /* Local variables */ static doublereal abse; static integer idir; static doublereal abss; static integer oldm; static doublereal cosl; static integer isub, iter; static doublereal unfl, sinl, cosr, smin, smax, sinr; extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); static doublereal f, g, h__; static integer i__, j, m; static doublereal r__; extern logical lsame_(char *, char *); static doublereal oldcs; static integer oldll; static doublereal shift, sigmn, oldsn; static integer maxit; static doublereal sminl, sigmx; static logical lower; extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, doublecomplex *, integer *), zdrot_(integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *) , zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlasq1_(integer *, doublereal *, doublereal *, doublereal *, integer *), dlasv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); static doublereal cs; static integer ll; extern doublereal dlamch_(char *); static doublereal sn, mu; extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); static doublereal sminoa, thresh; static logical rotate; static doublereal sminlo; static integer nm1; static doublereal tolmul; static integer nm12, nm13, lll; static doublereal eps, sll, tol; #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] #define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1 #define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)] #define vt_subscr(a_1,a_2) (a_2)*vt_dim1 + a_1 #define vt_ref(a_1,a_2) vt[vt_subscr(a_1,a_2)] /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1999 Purpose ======= ZBDSQR computes the singular value decomposition (SVD) of a real N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' denotes the transpose of P), where S is a diagonal matrix with non-negative diagonal elements (the singular values of B), and Q and P are orthogonal matrices. The routine computes S, and optionally computes U * Q, P' * VT, or Q' * C, for given complex input matrices U, VT, and C. See "Computing Small Singular Values of Bidiagonal Matrices With Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, no. 5, pp. 873-912, Sept 1990) and "Accurate singular values and differential qd algorithms," by B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics Department, University of California at Berkeley, July 1992 for a detailed description of the algorithm. Arguments ========= UPLO (input) CHARACTER*1 = 'U': B is upper bidiagonal; = 'L': B is lower bidiagonal. N (input) INTEGER The order of the matrix B. N >= 0. NCVT (input) INTEGER The number of columns of the matrix VT. NCVT >= 0. NRU (input) INTEGER The number of rows of the matrix U. NRU >= 0. NCC (input) INTEGER The number of columns of the matrix C. NCC >= 0. D (input/output) DOUBLE PRECISION array, dimension (N) On entry, the n diagonal elements of the bidiagonal matrix B. On exit, if INFO=0, the singular values of B in decreasing order. E (input/output) DOUBLE PRECISION array, dimension (N) On entry, the elements of E contain the offdiagonal elements of of the bidiagonal matrix whose SVD is desired. On normal exit (INFO = 0), E is destroyed. If the algorithm does not converge (INFO > 0), D and E will contain the diagonal and superdiagonal elements of a bidiagonal matrix orthogonally equivalent to the one given as input. E(N) is used for workspace. VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) On entry, an N-by-NCVT matrix VT. On exit, VT is overwritten by P' * VT. VT is not referenced if NCVT = 0. LDVT (input) INTEGER The leading dimension of the array VT. LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. U (input/output) COMPLEX*16 array, dimension (LDU, N) On entry, an NRU-by-N matrix U. On exit, U is overwritten by U * Q. U is not referenced if NRU = 0. LDU (input) INTEGER The leading dimension of the array U. LDU >= max(1,NRU). C (input/output) COMPLEX*16 array, dimension (LDC, NCC) On entry, an N-by-NCC matrix C. On exit, C is overwritten by Q' * C. C is not referenced if NCC = 0. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. RWORK (workspace) DOUBLE PRECISION array, dimension (4*N) INFO (output) INTEGER = 0: successful exit < 0: If INFO = -i, the i-th argument had an illegal value > 0: the algorithm did not converge; D and E contain the elements of a bidiagonal matrix which is orthogonally similar to the input matrix B; if INFO = i, i elements of E have not converged to zero. Internal Parameters =================== TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) TOLMUL controls the convergence criterion of the QR loop. If it is positive, TOLMUL*EPS is the desired relative precision in the computed singular values. If it is negative, abs(TOLMUL*EPS*sigma_max) is the desired absolute accuracy in the computed singular values (corresponds to relative accuracy abs(TOLMUL*EPS) in the largest singular value. abs(TOLMUL) should be between 1 and 1/EPS, and preferably between 10 (for fast convergence) and .1/EPS (for there to be some accuracy in the results). Default is to lose at either one eighth or 2 of the available decimal digits in each computed singular value (whichever is smaller). MAXITR INTEGER, default = 6 MAXITR controls the maximum number of passes of the algorithm through its inner loop. The algorithms stops (and so fails to converge) if the number of passes through the inner loop exceeds MAXITR*N**2. ===================================================================== Test the input parameters. Parameter adjustments */ --d__; --e; vt_dim1 = *ldvt; vt_offset = 1 + vt_dim1 * 1; vt -= vt_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --rwork; /* Function Body */ *info = 0; lower = lsame_(uplo, "L"); if (! lsame_(uplo, "U") && ! lower) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ncvt < 0) { *info = -3; } else if (*nru < 0) { *info = -4; } else if (*ncc < 0) { *info = -5; } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) { *info = -9; } else if (*ldu < max(1,*nru)) { *info = -11; } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("ZBDSQR", &i__1); return 0; } if (*n == 0) { return 0; } if (*n == 1) { goto L160; } /* ROTATE is true if any singular vectors desired, false otherwise */ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; /* If no singular vectors desired, use qd algorithm */ if (! rotate) { dlasq1_(n, &d__[1], &e[1], &rwork[1], info); return 0; } nm1 = *n - 1; nm12 = nm1 + nm1; nm13 = nm12 + nm1; idir = 0; /* Get machine constants */ eps = dlamch_("Epsilon"); unfl = dlamch_("Safe minimum"); /* If matrix lower bidiagonal, rotate to be upper bidiagonal by applying Givens rotations on the left */ if (lower) { i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); d__[i__] = r__; e[i__] = sn * d__[i__ + 1]; d__[i__ + 1] = cs * d__[i__ + 1]; rwork[i__] = cs; rwork[nm1 + i__] = sn; /* L10: */ } /* Update singular vectors if desired */ if (*nru > 0) { zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset], ldu); } if (*ncc > 0) { zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[ c_offset], ldc); } } /* Compute singular values to relative accuracy TOL (By setting TOL to be negative, algorithm will compute singular values to absolute accuracy ABS(TOL)*norm(input matrix)) Computing MAX Computing MIN */ d__3 = 100., d__4 = pow_dd(&eps, &c_b15); d__1 = 10., d__2 = min(d__3,d__4); tolmul = max(d__1,d__2); tol = tolmul * eps; /* Compute approximate maximum, minimum singular values */ smax = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); smax = max(d__2,d__3); /* L20: */ } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); smax = max(d__2,d__3); /* L30: */ } sminl = 0.; if (tol >= 0.) { /* Relative accuracy desired */ sminoa = abs(d__[1]); if (sminoa == 0.) { goto L50; } mu = sminoa; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] , abs(d__1)))); sminoa = min(sminoa,mu); if (sminoa == 0.) { goto L50; } /* L40: */ } L50: sminoa /= sqrt((doublereal) (*n)); /* Computing MAX */ d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl; thresh = max(d__1,d__2); } else { /* Absolute accuracy desired Computing MAX */ d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl; thresh = max(d__1,d__2); } /* Prepare for main iteration loop for the singular values (MAXIT is the maximum number of passes through the inner loop permitted before nonconvergence signalled.) */ maxit = *n * 6 * *n; iter = 0; oldll = -1; oldm = -1; /* M points to last element of unconverged part of matrix */ m = *n; /* Begin main iteration loop */ L60: /* Check for convergence or exceeding iteration count */ if (m <= 1) { goto L160; } if (iter > maxit) { goto L200; } /* Find diagonal block of matrix to work on */ if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { d__[m] = 0.; } smax = (d__1 = d__[m], abs(d__1)); smin = smax; i__1 = m - 1; for (lll = 1; lll <= i__1; ++lll) { ll = m - lll; abss = (d__1 = d__[ll], abs(d__1)); abse = (d__1 = e[ll], abs(d__1)); if (tol < 0. && abss <= thresh) { d__[ll] = 0.; } if (abse <= thresh) { goto L80; } smin = min(smin,abss); /* Computing MAX */ d__1 = max(smax,abss); smax = max(d__1,abse); /* L70: */ } ll = 0; goto L90; L80: e[ll] = 0.; /* Matrix splits since E(LL) = 0 */ if (ll == m - 1) { /* Convergence of bottom singular value, return to top of loop */ --m; goto L60; } L90: ++ll; /* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */ if (ll == m - 1) { /* 2 by 2 block, handle separately */ dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, &sinl, &cosl); d__[m - 1] = sigmx; e[m - 1] = 0.; d__[m] = sigmn; /* Compute singular vectors, if desired */ if (*ncvt > 0) { zdrot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr, &sinr); } if (*nru > 0) { zdrot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, & sinl); } if (*ncc > 0) { zdrot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, & sinl); } m += -2; goto L60; } /* If working on new submatrix, choose shift direction (from larger end diagonal element towards smaller) */ if (ll > oldm || m < oldll) { if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { /* Chase bulge from top (big end) to bottom (small end) */ idir = 1; } else { /* Chase bulge from bottom (big end) to top (small end) */ idir = 2; } } /* Apply convergence tests */ if (idir == 1) { /* Run convergence test in forward direction First apply standard test to bottom of matrix */ if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs( d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) { e[m - 1] = 0.; goto L60; } if (tol >= 0.) { /* If relative accuracy desired, apply convergence criterion forward */ mu = (d__1 = d__[ll], abs(d__1)); sminl = mu; i__1 = m - 1; for (lll = ll; lll <= i__1; ++lll) { if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { e[lll] = 0.; goto L60; } sminlo = sminl; mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ lll], abs(d__1)))); sminl = min(sminl,mu); /* L100: */ } } } else { /* Run convergence test in backward direction First apply standard test to top of matrix */ if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { e[ll] = 0.; goto L60; } if (tol >= 0.) { /* If relative accuracy desired, apply convergence criterion backward */ mu = (d__1 = d__[m], abs(d__1)); sminl = mu; i__1 = ll; for (lll = m - 1; lll >= i__1; --lll) { if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { e[lll] = 0.; goto L60; } sminlo = sminl; mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] , abs(d__1)))); sminl = min(sminl,mu); /* L110: */ } } } oldll = ll; oldm = m; /* Compute shift. First, test if shifting would ruin relative accuracy, and if so set the shift to zero. Computing MAX */ d__1 = eps, d__2 = tol * .01; if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) { /* Use a zero shift to avoid loss of relative accuracy */ shift = 0.; } else { /* Compute the shift from 2-by-2 block at end of matrix */ if (idir == 1) { sll = (d__1 = d__[ll], abs(d__1)); dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); } else { sll = (d__1 = d__[m], abs(d__1)); dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); } /* Test if shift negligible, and if so set to zero */ if (sll > 0.) { /* Computing 2nd power */ d__1 = shift / sll; if (d__1 * d__1 < eps) { shift = 0.; } } } /* Increment iteration count */ iter = iter + m - ll; /* If SHIFT = 0, do simplified QR iteration */ if (shift == 0.) { if (idir == 1) { /* Chase bulge from top to bottom Save cosines and sines for later singular vector updates */ cs = 1.; oldcs = 1.; i__1 = m - 1; for (i__ = ll; i__ <= i__1; ++i__) { d__1 = d__[i__] * cs; dlartg_(&d__1, &e[i__], &cs, &sn, &r__); if (i__ > ll) { e[i__ - 1] = oldsn * r__; } d__1 = oldcs * r__; d__2 = d__[i__ + 1] * sn; dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); rwork[i__ - ll + 1] = cs; rwork[i__ - ll + 1 + nm1] = sn; rwork[i__ - ll + 1 + nm12] = oldcs; rwork[i__ - ll + 1 + nm13] = oldsn; /* L120: */ } h__ = d__[m] * cs; d__[m] = h__ * oldcs; e[m - 1] = h__ * oldsn; /* Update singular vectors */ if (*ncvt > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], & vt_ref(ll, 1), ldvt); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[ nm13 + 1], &u_ref(1, ll), ldu); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[ nm13 + 1], &c___ref(ll, 1), ldc); } /* Test convergence */ if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { e[m - 1] = 0.; } } else { /* Chase bulge from bottom to top Save cosines and sines for later singular vector updates */ cs = 1.; oldcs = 1.; i__1 = ll + 1; for (i__ = m; i__ >= i__1; --i__) { d__1 = d__[i__] * cs; dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); if (i__ < m) { e[i__] = oldsn * r__; } d__1 = oldcs * r__; d__2 = d__[i__ - 1] * sn; dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); rwork[i__ - ll] = cs; rwork[i__ - ll + nm1] = -sn; rwork[i__ - ll + nm12] = oldcs; rwork[i__ - ll + nm13] = -oldsn; /* L130: */ } h__ = d__[ll] * cs; d__[ll] = h__ * oldcs; e[ll] = h__ * oldsn; /* Update singular vectors */ if (*ncvt > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[ nm13 + 1], &vt_ref(ll, 1), ldvt); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], & u_ref(1, ll), ldu); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], & c___ref(ll, 1), ldc); } /* Test convergence */ if ((d__1 = e[ll], abs(d__1)) <= thresh) { e[ll] = 0.; } } } else { /* Use nonzero shift */ if (idir == 1) { /* Chase bulge from top to bottom Save cosines and sines for later singular vector updates */ f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ ll]) + shift / d__[ll]); g = e[ll]; i__1 = m - 1; for (i__ = ll; i__ <= i__1; ++i__) { dlartg_(&f, &g, &cosr, &sinr, &r__); if (i__ > ll) { e[i__ - 1] = r__; } f = cosr * d__[i__] + sinr * e[i__]; e[i__] = cosr * e[i__] - sinr * d__[i__]; g = sinr * d__[i__ + 1]; d__[i__ + 1] = cosr * d__[i__ + 1]; dlartg_(&f, &g, &cosl, &sinl, &r__); d__[i__] = r__; f = cosl * e[i__] + sinl * d__[i__ + 1]; d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; if (i__ < m - 1) { g = sinl * e[i__ + 1]; e[i__ + 1] = cosl * e[i__ + 1]; } rwork[i__ - ll + 1] = cosr; rwork[i__ - ll + 1 + nm1] = sinr; rwork[i__ - ll + 1 + nm12] = cosl; rwork[i__ - ll + 1 + nm13] = sinl; /* L140: */ } e[m - 1] = f; /* Update singular vectors */ if (*ncvt > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], & vt_ref(ll, 1), ldvt); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[ nm13 + 1], &u_ref(1, ll), ldu); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[ nm13 + 1], &c___ref(ll, 1), ldc); } /* Test convergence */ if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { e[m - 1] = 0.; } } else { /* Chase bulge from bottom to top Save cosines and sines for later singular vector updates */ f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] ) + shift / d__[m]); g = e[m - 1]; i__1 = ll + 1; for (i__ = m; i__ >= i__1; --i__) { dlartg_(&f, &g, &cosr, &sinr, &r__); if (i__ < m) { e[i__] = r__; } f = cosr * d__[i__] + sinr * e[i__ - 1]; e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; g = sinr * d__[i__ - 1]; d__[i__ - 1] = cosr * d__[i__ - 1]; dlartg_(&f, &g, &cosl, &sinl, &r__); d__[i__] = r__; f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; if (i__ > ll + 1) { g = sinl * e[i__ - 2]; e[i__ - 2] = cosl * e[i__ - 2]; } rwork[i__ - ll] = cosr; rwork[i__ - ll + nm1] = -sinr; rwork[i__ - ll + nm12] = cosl; rwork[i__ - ll + nm13] = -sinl; /* L150: */ } e[ll] = f; /* Test convergence */ if ((d__1 = e[ll], abs(d__1)) <= thresh) { e[ll] = 0.; } /* Update singular vectors if desired */ if (*ncvt > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[ nm13 + 1], &vt_ref(ll, 1), ldvt); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], & u_ref(1, ll), ldu); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], & c___ref(ll, 1), ldc); } } } /* QR iteration finished, go back and check convergence */ goto L60; /* All singular values converged, so make them positive */ L160: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (d__[i__] < 0.) { d__[i__] = -d__[i__]; /* Change sign of singular vectors, if desired */ if (*ncvt > 0) { zdscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt); } } /* L170: */ } /* Sort the singular values into decreasing order (insertion sort on singular values, but only one transposition per singular vector) */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Scan for smallest D(I) */ isub = 1; smin = d__[1]; i__2 = *n + 1 - i__; for (j = 2; j <= i__2; ++j) { if (d__[j] <= smin) { isub = j; smin = d__[j]; } /* L180: */ } if (isub != *n + 1 - i__) { /* Swap singular values and vectors */ d__[isub] = d__[*n + 1 - i__]; d__[*n + 1 - i__] = smin; if (*ncvt > 0) { zswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1), ldvt); } if (*nru > 0) { zswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), & c__1); } if (*ncc > 0) { zswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1), ldc); } } /* L190: */ } goto L220; /* Maximum number of iterations exceeded, failure to converge */ L200: *info = 0; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { if (e[i__] != 0.) { ++(*info); } /* L210: */ } L220: return 0; /* End of ZBDSQR */ } /* zbdsqr_ */
/* Subroutine */ int zunmr3_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer * info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= ZUNMR3 overwrites the general complex m by n matrix C with Q * C if SIDE = 'L' and TRANS = 'N', or Q'* C if SIDE = 'L' and TRANS = 'C', or C * Q if SIDE = 'R' and TRANS = 'N', or C * Q' if SIDE = 'R' and TRANS = 'C', where Q is a complex unitary matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n if SIDE = 'R'. Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply Q or Q' from the Left = 'R': apply Q or Q' from the Right TRANS (input) CHARACTER*1 = 'N': apply Q (No transpose) = 'C': apply Q' (Conjugate transpose) M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= 0. L (input) INTEGER The number of columns of the matrix A containing the meaningful part of the Householder reflectors. If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. A (input) COMPLEX*16 array, dimension (LDA,M) if SIDE = 'L', (LDA,N) if SIDE = 'R' The i-th row must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by ZTZRZF in the last k rows of its array argument A. A is modified by the routine but restored on exit. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,K). TAU (input) COMPLEX*16 array, dimension (K) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by ZTZRZF. C (input/output) COMPLEX*16 array, dimension (LDC,N) On entry, the m-by-n matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L', (M) if SIDE = 'R' INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Further Details =============== Based on contributions by A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ===================================================================== Test the input arguments Parameter adjustments */ /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; doublecomplex z__1; /* Builtin functions */ void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static logical left; static doublecomplex taui; static integer i__; extern logical lsame_(char *, char *); static integer i1, i2, i3; extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer * , doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); static integer ja, ic, jc, mi, ni, nq; extern /* Subroutine */ int xerbla_(char *, integer *); static logical notran; #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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L"); notran = lsame_(trans, "N"); /* NQ is the order of Q */ if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! notran && ! lsame_(trans, "C")) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { *info = -6; } else if (*lda < max(1,*k)) { *info = -8; } else if (*ldc < max(1,*m)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNMR3", &i__1); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { return 0; } if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = 1; } else { i1 = *k; i2 = 1; i3 = -1; } if (left) { ni = *n; ja = *m - *l + 1; jc = 1; } else { mi = *m; ja = *n - *l + 1; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { if (left) { /* H(i) or H(i)' is applied to C(i:m,1:n) */ mi = *m - i__ + 1; ic = i__; } else { /* H(i) or H(i)' is applied to C(1:m,i:n) */ ni = *n - i__ + 1; jc = i__; } /* Apply H(i) or H(i)' */ if (notran) { i__3 = i__; taui.r = tau[i__3].r, taui.i = tau[i__3].i; } else { d_cnjg(&z__1, &tau[i__]); taui.r = z__1.r, taui.i = z__1.i; } zlarz_(side, &mi, &ni, l, &a_ref(i__, ja), lda, &taui, &c___ref(ic, jc), ldc, &work[1]); /* L10: */ } return 0; /* End of ZUNMR3 */ } /* zunmr3_ */
/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer * n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde, complex *f, integer *ldf, real *scale, real *dif, complex *work, integer *lwork, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CTGSYL solves the generalized Sylvester equation: A * R - L * B = scale * C (1) D * R - L * E = scale * F where R and L are unknown m-by-n matrices, (A, D), (B, E) and (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, respectively, with complex entries. A, B, D and E are upper triangular (i.e., (A,D) and (B,E) in generalized Schur form). The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor chosen to avoid overflow. In matrix notation (1) is equivalent to solve Zx = scale*b, where Z is defined as Z = [ kron(In, A) -kron(B', Im) ] (2) [ kron(In, D) -kron(E', Im) ], Here Ix is the identity matrix of size x and X' is the conjugate transpose of X. Kron(X, Y) is the Kronecker product between the matrices X and Y. If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b is solved for, which is equivalent to solve for R and L in A' * R + D' * L = scale * C (3) R * B' + L * E' = scale * -F This case (TRANS = 'C') is used to compute an one-norm-based estimate of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) and (B,E), using CLACON. If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the reciprocal of the smallest singular value of Z. This is a level-3 BLAS algorithm. Arguments ========= TRANS (input) CHARACTER*1 = 'N': solve the generalized sylvester equation (1). = 'C': solve the "conjugate transposed" system (3). IJOB (input) INTEGER Specifies what kind of functionality to be performed. =0: solve (1) only. =1: The functionality of 0 and 3. =2: The functionality of 0 and 4. =3: Only an estimate of Dif[(A,D), (B,E)] is computed. (look ahead strategy is used). =4: Only an estimate of Dif[(A,D), (B,E)] is computed. (CGECON on sub-systems is used). Not referenced if TRANS = 'C'. M (input) INTEGER The order of the matrices A and D, and the row dimension of the matrices C, F, R and L. N (input) INTEGER The order of the matrices B and E, and the column dimension of the matrices C, F, R and L. A (input) COMPLEX array, dimension (LDA, M) The upper triangular matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1, M). B (input) COMPLEX array, dimension (LDB, N) The upper triangular matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1, N). C (input/output) COMPLEX array, dimension (LDC, N) On entry, C contains the right-hand-side of the first matrix equation in (1) or (3). On exit, if IJOB = 0, 1 or 2, C has been overwritten by the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, the solution achieved during the computation of the Dif-estimate. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1, M). D (input) COMPLEX array, dimension (LDD, M) The upper triangular matrix D. LDD (input) INTEGER The leading dimension of the array D. LDD >= max(1, M). E (input) COMPLEX array, dimension (LDE, N) The upper triangular matrix E. LDE (input) INTEGER The leading dimension of the array E. LDE >= max(1, N). F (input/output) COMPLEX array, dimension (LDF, N) On entry, F contains the right-hand-side of the second matrix equation in (1) or (3). On exit, if IJOB = 0, 1 or 2, F has been overwritten by the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, the solution achieved during the computation of the Dif-estimate. LDF (input) INTEGER The leading dimension of the array F. LDF >= max(1, M). DIF (output) REAL On exit DIF is the reciprocal of a lower bound of the reciprocal of the Dif-function, i.e. DIF is an upper bound of Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2). IF IJOB = 0 or TRANS = 'C', DIF is not referenced. SCALE (output) REAL On exit SCALE is the scaling factor in (1) or (3). If 0 < SCALE < 1, C and F hold the solutions R and L, resp., to a slightly perturbed system but the input matrices A, B, D and E have not been changed. If SCALE = 0, R and L will hold the solutions to the homogenious system with C = F = 0. WORK (workspace/output) COMPLEX array, dimension (LWORK) IF IJOB = 0, WORK is not referenced. Otherwise, LWORK (input) INTEGER The dimension of the array WORK. LWORK > = 1. If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*M*N. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. IWORK (workspace) INTEGER array, dimension (M+N+2) If IJOB = 0, IWORK is not referenced. INFO (output) INTEGER =0: successful exit <0: If INFO = -i, the i-th argument had an illegal value. >0: (A, D) and (B, E) have common or very close eigenvalues. Further Details =============== Based on contributions by Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden. [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software for Solving the Generalized Sylvester Equation and Estimating the Separation between Regular Matrix Pairs, Report UMINF - 93.23, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, December 1993, Revised April 1994, Also as LAPACK Working Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. Appl., 15(4):1045-1060, 1994. [3] B. Kagstrom and L. Westin, Generalized Schur Methods with Condition Estimators for Solving the Generalized Sylvester Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. ===================================================================== Decode and test input parameters Parameter adjustments */ /* Table of constant values */ static integer c__2 = 2; static integer c_n1 = -1; static integer c__5 = 5; static integer c__0 = 0; static integer c__1 = 1; static complex c_b16 = {0.f,0.f}; static complex c_b53 = {-1.f,0.f}; static complex c_b54 = {1.f,0.f}; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, i__4; complex q__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static real dsum; static integer i__, j, k, p, q; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *), cgemm_(char *, char *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *); extern logical lsame_(char *, char *); static integer ifunc, linfo; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); static integer lwmin; static real scale2; extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, real *, integer *); static integer ie, je, mb, nb; static real dscale; static integer is, js, pq; static real scaloc; extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); static integer iround; static logical notran; static integer isolve; static logical lquery; #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 b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] #define d___subscr(a_1,a_2) (a_2)*d_dim1 + a_1 #define d___ref(a_1,a_2) d__[d___subscr(a_1,a_2)] #define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1 #define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)] #define f_subscr(a_1,a_2) (a_2)*f_dim1 + a_1 #define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; d_dim1 = *ldd; d_offset = 1 + d_dim1 * 1; d__ -= d_offset; e_dim1 = *lde; e_offset = 1 + e_dim1 * 1; e -= e_offset; f_dim1 = *ldf; f_offset = 1 + f_dim1 * 1; f -= f_offset; --work; --iwork; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); lquery = *lwork == -1; if ((*ijob == 1 || *ijob == 2) && notran) { /* Computing MAX */ i__1 = 1, i__2 = (*m << 1) * *n; lwmin = max(i__1,i__2); } else { lwmin = 1; } if (! notran && ! lsame_(trans, "C")) { *info = -1; } else if (*ijob < 0 || *ijob > 4) { *info = -2; } else if (*m <= 0) { *info = -3; } else if (*n <= 0) { *info = -4; } else if (*lda < max(1,*m)) { *info = -6; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldc < max(1,*m)) { *info = -10; } else if (*ldd < max(1,*m)) { *info = -12; } else if (*lde < max(1,*n)) { *info = -14; } else if (*ldf < max(1,*m)) { *info = -16; } else if (*lwork < lwmin && ! lquery) { *info = -20; } if (*info == 0) { work[1].r = (real) lwmin, work[1].i = 0.f; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGSYL", &i__1); return 0; } else if (lquery) { return 0; } /* Determine optimal block sizes MB and NB */ mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); isolve = 1; ifunc = 0; if (*ijob >= 3 && notran) { ifunc = *ijob - 2; i__1 = *n; for (j = 1; j <= i__1; ++j) { ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1); ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1); /* L10: */ } } else if (*ijob >= 1 && notran) { isolve = 2; } if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { /* Use unblocked Level 2 solver */ i__1 = isolve; for (iround = 1; iround <= i__1; ++iround) { *scale = 1.f; dscale = 0.f; dsum = 1.f; pq = *m * *n; ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], lde, &f[f_offset], ldf, scale, &dsum, &dscale, info); if (dscale != 0.f) { if (*ijob == 1 || *ijob == 3) { *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( dsum)); } else { *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); } } if (isolve == 2 && iround == 1) { ifunc = *ijob; scale2 = *scale; clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); i__2 = *n; for (j = 1; j <= i__2; ++j) { ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1); ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1); /* L20: */ } } else if (isolve == 2 && iround == 2) { clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); *scale = scale2; } /* L30: */ } return 0; } /* Determine block structure of A */ p = 0; i__ = 1; L40: if (i__ > *m) { goto L50; } ++p; iwork[p] = i__; i__ += mb; if (i__ >= *m) { goto L50; } goto L40; L50: iwork[p + 1] = *m + 1; if (iwork[p] == iwork[p + 1]) { --p; } /* Determine block structure of B */ q = p + 1; j = 1; L60: if (j > *n) { goto L70; } ++q; iwork[q] = j; j += nb; if (j >= *n) { goto L70; } goto L60; L70: iwork[q + 1] = *n + 1; if (iwork[q] == iwork[q + 1]) { --q; } if (notran) { i__1 = isolve; for (iround = 1; iround <= i__1; ++iround) { /* Solve (I, J) - subsystem A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ pq = 0; *scale = 1.f; dscale = 0.f; dsum = 1.f; i__2 = q; for (j = p + 2; j <= i__2; ++j) { js = iwork[j]; je = iwork[j + 1] - 1; nb = je - js + 1; for (i__ = p; i__ >= 1; --i__) { is = iwork[i__]; ie = iwork[i__ + 1] - 1; mb = ie - is + 1; ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, & b_ref(js, js), ldb, &c___ref(is, js), ldc, & d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref( is, js), ldf, &scaloc, &dsum, &dscale, &linfo); if (linfo > 0) { *info = linfo; } pq += mb * nb; if (scaloc != 1.f) { i__3 = js - 1; for (k = 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L80: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(1, k), &c__1); i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(1, k), &c__1); /* L90: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1); i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1); /* L100: */ } i__3 = *n; for (k = je + 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L110: */ } *scale *= scaloc; } /* Substitute R(I,J) and L(I,J) into remaining equation. */ if (i__ > 1) { i__3 = is - 1; cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &a_ref(1, is), lda, &c___ref(is, js), ldc, &c_b54, & c___ref(1, js), ldc); i__3 = is - 1; cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &d___ref(1, is), ldd, &c___ref(is, js), ldc, &c_b54, & f_ref(1, js), ldf); } if (j < q) { i__3 = *n - je; cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is, js), ldf, &b_ref(js, je + 1), ldb, &c_b54, & c___ref(is, je + 1), ldc); i__3 = *n - je; cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is, js), ldf, &e_ref(js, je + 1), lde, &c_b54, & f_ref(is, je + 1), ldf); } /* L120: */ } /* L130: */ } if (dscale != 0.f) { if (*ijob == 1 || *ijob == 3) { *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( dsum)); } else { *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); } } if (isolve == 2 && iround == 1) { ifunc = *ijob; scale2 = *scale; clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); i__2 = *n; for (j = 1; j <= i__2; ++j) { ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1); ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1); /* L140: */ } } else if (isolve == 2 && iround == 2) { clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); *scale = scale2; } /* L150: */ } } else { /* Solve transposed (I, J)-subsystem A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) for I = 1,2,..., P; J = Q, Q-1,..., 1 */ *scale = 1.f; i__1 = p; for (i__ = 1; i__ <= i__1; ++i__) { is = iwork[i__]; ie = iwork[i__ + 1] - 1; mb = ie - is + 1; i__2 = p + 2; for (j = q; j >= i__2; --j) { js = iwork[j]; je = iwork[j + 1] - 1; nb = je - js + 1; ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &b_ref( js, js), ldb, &c___ref(is, js), ldc, &d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref(is, js), ldf, & scaloc, &dsum, &dscale, &linfo); if (linfo > 0) { *info = linfo; } if (scaloc != 1.f) { i__3 = js - 1; for (k = 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L160: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(1, k), &c__1); i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(1, k), &c__1); /* L170: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1); i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1); /* L180: */ } i__3 = *n; for (k = je + 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L190: */ } *scale *= scaloc; } /* Substitute R(I,J) and L(I,J) into remaining equation. */ if (j > p + 2) { i__3 = js - 1; cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &c___ref(is, js) , ldc, &b_ref(1, js), ldb, &c_b54, &f_ref(is, 1), ldf); i__3 = js - 1; cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &f_ref(is, js), ldf, &e_ref(1, js), lde, &c_b54, &f_ref(is, 1), ldf); } if (i__ < p) { i__3 = *m - ie; cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &a_ref(is, ie + 1), lda, &c___ref(is, js), ldc, &c_b54, &c___ref( ie + 1, js), ldc); i__3 = *m - ie; cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &d___ref(is, ie + 1), ldd, &f_ref(is, js), ldf, &c_b54, &c___ref( ie + 1, js), ldc); } /* L200: */ } /* L210: */ } } work[1].r = (real) lwmin, work[1].i = 0.f; return 0; /* End of CTGSYL */ } /* ctgsyl_ */
/* Subroutine */ HYPRE_Int dsymm_(char *side, char *uplo, integer *m, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3; /* Local variables */ static integer info; static doublereal temp1, temp2; static integer i__, j, k; extern logical hypre_lsame_(char *, char *); static integer nrowa; static logical upper; extern /* Subroutine */ HYPRE_Int hypre_xerbla_(char *, integer *); #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] /* Purpose ======= DSYMM performs one of the matrix-matrix operations C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, where alpha and beta are scalars, A is a symmetric matrix and B and C are m by n matrices. Parameters ========== SIDE - CHARACTER*1. On entry, SIDE specifies whether the symmetric matrix A appears on the left or right in the operation as follows: SIDE = 'L' or 'l' C := alpha*A*B + beta*C, SIDE = 'R' or 'r' C := alpha*B*A + beta*C, Unchanged on exit. UPLO - CHARACTER*1. On entry, UPLO specifies whether the upper or lower triangular part of the symmetric matrix A is to be referenced as follows: UPLO = 'U' or 'u' Only the upper triangular part of the symmetric matrix is to be referenced. UPLO = 'L' or 'l' Only the lower triangular part of the symmetric matrix is to be referenced. Unchanged on exit. M - INTEGER. On entry, M specifies the number of rows of the matrix C. M must be at least zero. Unchanged on exit. N - INTEGER. On entry, N specifies the number of columns of the matrix C. N must be at least zero. Unchanged on exit. ALPHA - DOUBLE PRECISION. On entry, ALPHA specifies the scalar alpha. Unchanged on exit. A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is m when SIDE = 'L' or 'l' and is n otherwise. Before entry with SIDE = 'L' or 'l', the m by m part of the array A must contain the symmetric matrix, such that when UPLO = 'U' or 'u', the leading m by m upper triangular part of the array A must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of A is not referenced, and when UPLO = 'L' or 'l', the leading m by m lower triangular part of the array A must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of A is not referenced. Before entry with SIDE = 'R' or 'r', the n by n part of the array A must contain the symmetric matrix, such that when UPLO = 'U' or 'u', the leading n by n upper triangular part of the array A must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of A is not referenced, and when UPLO = 'L' or 'l', the leading n by n lower triangular part of the array A must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of A is not referenced. Unchanged on exit. LDA - INTEGER. On entry, LDA specifies the first dimension of A as declared in the calling (sub) program. When SIDE = 'L' or 'l' then LDA must be at least max( 1, m ), otherwise LDA must be at least max( 1, n ). Unchanged on exit. B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). Before entry, the leading m by n part of the array B must contain the matrix B. Unchanged on exit. LDB - INTEGER. On entry, LDB specifies the first dimension of B as declared in the calling (sub) program. LDB must be at least max( 1, m ). Unchanged on exit. BETA - DOUBLE PRECISION. On entry, BETA specifies the scalar beta. When BETA is supplied as zero then C need not be set on input. Unchanged on exit. C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). Before entry, the leading m by n part of the array C must contain the matrix C, except when beta is zero, in which case C need not be set on entry. On exit, the array C is overwritten by the m by n updated matrix. LDC - INTEGER. On entry, LDC specifies the first dimension of C as declared in the calling (sub) program. LDC must be at least max( 1, m ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Set NROWA as the number of rows of A. Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ if (hypre_lsame_(side, "L")) { nrowa = *m; } else { nrowa = *n; } upper = hypre_lsame_(uplo, "U"); /* Test the input parameters. */ info = 0; if (! hypre_lsame_(side, "L") && ! hypre_lsame_(side, "R")) { info = 1; } else if (! upper && ! hypre_lsame_(uplo, "L")) { info = 2; } else if (*m < 0) { info = 3; } else if (*n < 0) { info = 4; } else if (*lda < max(1,nrowa)) { info = 7; } else if (*ldb < max(1,*m)) { info = 9; } else if (*ldc < max(1,*m)) { info = 12; } if (info != 0) { hypre_xerbla_("DSYMM ", &info); return 0; } /* Quick return if possible. */ if ((*m == 0 || *n == 0) || (*alpha == 0. && *beta == 1.)) { return 0; } /* And when alpha.eq.zero. */ if (*alpha == 0.) { if (*beta == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = 0.; /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j); /* L30: */ } /* L40: */ } } return 0; } /* Start the operations. */ if (hypre_lsame_(side, "L")) { /* Form C := alpha*A*B + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp1 = *alpha * b_ref(i__, j); temp2 = 0.; i__3 = i__ - 1; for (k = 1; k <= i__3; ++k) { c___ref(k, j) = c___ref(k, j) + temp1 * a_ref(k, i__); temp2 += b_ref(k, j) * a_ref(k, i__); /* L50: */ } if (*beta == 0.) { c___ref(i__, j) = temp1 * a_ref(i__, i__) + *alpha * temp2; } else { c___ref(i__, j) = *beta * c___ref(i__, j) + temp1 * a_ref(i__, i__) + *alpha * temp2; } /* L60: */ } /* L70: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (i__ = *m; i__ >= 1; --i__) { temp1 = *alpha * b_ref(i__, j); temp2 = 0.; i__2 = *m; for (k = i__ + 1; k <= i__2; ++k) { c___ref(k, j) = c___ref(k, j) + temp1 * a_ref(k, i__); temp2 += b_ref(k, j) * a_ref(k, i__); /* L80: */ } if (*beta == 0.) { c___ref(i__, j) = temp1 * a_ref(i__, i__) + *alpha * temp2; } else { c___ref(i__, j) = *beta * c___ref(i__, j) + temp1 * a_ref(i__, i__) + *alpha * temp2; } /* L90: */ } /* L100: */ } } } else { /* Form C := alpha*B*A + beta*C. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { temp1 = *alpha * a_ref(j, j); if (*beta == 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = temp1 * b_ref(i__, j); /* L110: */ } } else { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c___ref(i__, j) = *beta * c___ref(i__, j) + temp1 * b_ref( i__, j); /* L120: */ } } i__2 = j - 1; for (k = 1; k <= i__2; ++k) { if (upper) { temp1 = *alpha * a_ref(k, j); } else { temp1 = *alpha * a_ref(j, k); } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { c___ref(i__, j) = c___ref(i__, j) + temp1 * b_ref(i__, k); /* L130: */ } /* L140: */ } i__2 = *n; for (k = j + 1; k <= i__2; ++k) { if (upper) { temp1 = *alpha * a_ref(j, k); } else { temp1 = *alpha * a_ref(k, j); } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { c___ref(i__, j) = c___ref(i__, j) + temp1 * b_ref(i__, k); /* L150: */ } /* L160: */ } /* L170: */ } } return 0; /* End of DSYMM . */ } /* dsymm_ */
/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * c__, integer *ldc, doublereal *work, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= DORM2R overwrites the general real m by n matrix C with Q * C if SIDE = 'L' and TRANS = 'N', or Q'* C if SIDE = 'L' and TRANS = 'T', or C * Q if SIDE = 'R' and TRANS = 'N', or C * Q' if SIDE = 'R' and TRANS = 'T', where Q is a real orthogonal matrix defined as the product of k elementary reflectors Q = H(1) H(2) . . . H(k) as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n if SIDE = 'R'. Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply Q or Q' from the Left = 'R': apply Q or Q' from the Right TRANS (input) CHARACTER*1 = 'N': apply Q (No transpose) = 'T': apply Q' (Transpose) M (input) INTEGER The number of rows of the matrix C. M >= 0. N (input) INTEGER The number of columns of the matrix C. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= 0. A (input) DOUBLE PRECISION array, dimension (LDA,K) The i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by DGEQRF in the first k columns of its array argument A. A is modified by the routine but restored on exit. LDA (input) INTEGER The leading dimension of the array A. If SIDE = 'L', LDA >= max(1,M); if SIDE = 'R', LDA >= max(1,N). TAU (input) DOUBLE PRECISION array, dimension (K) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by DGEQRF. C (input/output) DOUBLE PRECISION array, dimension (LDC,N) On entry, the m by n matrix C. On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace) DOUBLE PRECISION array, dimension (N) if SIDE = 'L', (M) if SIDE = 'R' INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; /* Local variables */ static logical left; static integer i__; extern /* Subroutine */ int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *); extern logical lsame_(char *, char *); static integer i1, i2, i3, ic, jc, mi, ni, nq; extern /* Subroutine */ int xerbla_(char *, integer *); static logical notran; static doublereal aii; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L"); notran = lsame_(trans, "N"); /* NQ is the order of Q */ if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R")) { *info = -1; } else if (! notran && ! lsame_(trans, "T")) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < max(1,nq)) { *info = -7; } else if (*ldc < max(1,*m)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("DORM2R", &i__1); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { return 0; } if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = 1; } else { i1 = *k; i2 = 1; i3 = -1; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { if (left) { /* H(i) is applied to C(i:m,1:n) */ mi = *m - i__ + 1; ic = i__; } else { /* H(i) is applied to C(1:m,i:n) */ ni = *n - i__ + 1; jc = i__; } /* Apply H(i) */ aii = a_ref(i__, i__); a_ref(i__, i__) = 1.; dlarf_(side, &mi, &ni, &a_ref(i__, i__), &c__1, &tau[i__], &c___ref( ic, jc), ldc, &work[1]); a_ref(i__, i__) = aii; /* L10: */ } return 0; /* End of DORM2R */ } /* dorm2r_ */