/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, which is defined as the first N columns of a product of K elementary reflectors of order M Q = H(1) H(2) . . . H(k) as returned by ZGEQRF. Arguments ========= M (input) INTEGER The number of rows of the matrix Q. M >= 0. N (input) INTEGER The number of columns of the matrix Q. M >= N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. N >= K >= 0. A (input/output) COMPLEX*16 array, dimension (LDA,N) On entry, the i-th column must contain the vector which defines the elementary reflector H(i), for i = 1,2,...,k, as returned by ZGEQRF in the first k columns of its array argument A. On exit, the M-by-N matrix Q. LDA (input) INTEGER The first dimension of the array A. LDA >= max(1,M). TAU (input) COMPLEX*16 array, dimension (K) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by ZGEQRF. WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= max(1,N). For optimum performance LWORK >= N*NB, where NB is the optimal blocksize. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument has an illegal value ===================================================================== Test the input arguments Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static integer c__3 = 3; static integer c__2 = 2; /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i, j, l, nbmin, iinfo, ib, nb, ki, kk; extern /* Subroutine */ int zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static integer nx; extern /* Subroutine */ int xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer ldwork; extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static integer iws; #define TAU(I) tau[(I)-1] #define WORK(I) work[(I)-1] #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0 || *n > *m) { *info = -2; } else if (*k < 0 || *k > *n) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else if (*lwork < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGQR", &i__1); return 0; } /* Quick return if possible */ if (*n <= 0) { WORK(1).r = 1., WORK(1).i = 0.; return 0; } /* Determine the block size. */ nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1, 6L, 1L); nbmin = 2; nx = 0; iws = *n; if (nb > 1 && nb < *k) { /* Determine when to cross over from blocked to unblocked code. Computing MAX */ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGQR", " ", m, n, k, &c_n1, 6L, 1L) ; nx = max(i__1,i__2); if (nx < *k) { /* Determine if workspace is large enough for blocked co de. */ ldwork = *n; iws = ldwork * nb; if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduc e NB and determine the minimum value of NB. */ nb = *lwork / ldwork; /* Computing MAX */ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGQR", " ", m, n, k, &c_n1, 6L, 1L); nbmin = max(i__1,i__2); } } } if (nb >= nbmin && nb < *k && nx < *k) { /* Use blocked code after the last block. The first kk columns are handled by the block method. */ ki = (*k - nx - 1) / nb * nb; /* Computing MIN */ i__1 = *k, i__2 = ki + nb; kk = min(i__1,i__2); /* Set A(1:kk,kk+1:n) to zero. */ i__1 = *n; for (j = kk + 1; j <= *n; ++j) { i__2 = kk; for (i = 1; i <= kk; ++i) { i__3 = i + j * a_dim1; A(i,j).r = 0., A(i,j).i = 0.; /* L10: */ } /* L20: */ } } else { kk = 0; } /* Use unblocked code for the last or only block. */ if (kk < *n) { i__1 = *m - kk; i__2 = *n - kk; i__3 = *k - kk; zung2r_(&i__1, &i__2, &i__3, &A(kk+1,kk+1), lda, & TAU(kk + 1), &WORK(1), &iinfo); } if (kk > 0) { /* Use blocked code */ i__1 = -nb; for (i = ki + 1; -nb < 0 ? i >= 1 : i <= 1; i += -nb) { /* Computing MIN */ i__2 = nb, i__3 = *k - i + 1; ib = min(i__2,i__3); if (i + ib <= *n) { /* Form the triangular factor of the block reflec tor H = H(i) H(i+1) . . . H(i+ib-1) */ i__2 = *m - i + 1; zlarft_("Forward", "Columnwise", &i__2, &ib, &A(i,i), lda, &TAU(i), &WORK(1), &ldwork); /* Apply H to A(i:m,i+ib:n) from the left */ i__2 = *m - i + 1; i__3 = *n - i - ib + 1; zlarfb_("Left", "No transpose", "Forward", "Columnwise", & i__2, &i__3, &ib, &A(i,i), lda, &WORK(1), & ldwork, &A(i,i+ib), lda, &WORK(ib + 1), &ldwork); } /* Apply H to rows i:m of current block */ i__2 = *m - i + 1; zung2r_(&i__2, &ib, &ib, &A(i,i), lda, &TAU(i), &WORK( 1), &iinfo); /* Set rows 1:i-1 of current block to zero */ i__2 = i + ib - 1; for (j = i; j <= i+ib-1; ++j) { i__3 = i - 1; for (l = 1; l <= i-1; ++l) { i__4 = l + j * a_dim1; A(l,j).r = 0., A(l,j).i = 0.; /* L30: */ } /* L40: */ } /* L50: */ } } WORK(1).r = (doublereal) iws, WORK(1).i = 0.; return 0; /* End of ZUNGQR */ } /* zungqr_ */
/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; extern /* Subroutine */ int zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); integer ldwork; extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); integer lwkopt; logical lquery; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, */ /* which is defined as the first N columns of a product of K elementary */ /* reflectors of order M */ /* Q = H(1) H(2) . . . H(k) */ /* as returned by ZGEQRF. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix Q. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q. M >= N >= 0. */ /* K (input) INTEGER */ /* The number of elementary reflectors whose product defines the */ /* matrix Q. N >= K >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the i-th column must contain the vector which */ /* defines the elementary reflector H(i), for i = 1,2,...,k, as */ /* returned by ZGEQRF in the first k columns of its array */ /* argument A. */ /* On exit, the M-by-N matrix Q. */ /* LDA (input) INTEGER */ /* The first dimension of the array A. LDA >= max(1,M). */ /* TAU (input) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGEQRF. */ /* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= max(1,N). */ /* For optimum performance LWORK >= N*NB, where NB is the */ /* optimal blocksize. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument has an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1); lwkopt = max(1,*n) * nb; work[1].r = (doublereal) lwkopt, work[1].i = 0.; lquery = *lwork == -1; if (*m < 0) { *info = -1; } else if (*n < 0 || *n > *m) { *info = -2; } else if (*k < 0 || *k > *n) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else if (*lwork < max(1,*n) && ! lquery) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGQR", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n <= 0) { work[1].r = 1., work[1].i = 0.; return 0; } nbmin = 2; nx = 0; iws = *n; if (nb > 1 && nb < *k) { /* Determine when to cross over from blocked to unblocked code. */ /* Computing MAX */ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGQR", " ", m, n, k, &c_n1); nx = max(i__1,i__2); if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ ldwork = *n; iws = ldwork * nb; if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ nb = *lwork / ldwork; /* Computing MAX */ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGQR", " ", m, n, k, &c_n1); nbmin = max(i__1,i__2); } } } if (nb >= nbmin && nb < *k && nx < *k) { /* Use blocked code after the last block. */ /* The first kk columns are handled by the block method. */ ki = (*k - nx - 1) / nb * nb; /* Computing MIN */ i__1 = *k, i__2 = ki + nb; kk = min(i__1,i__2); /* Set A(1:kk,kk+1:n) to zero. */ i__1 = *n; for (j = kk + 1; j <= i__1; ++j) { i__2 = kk; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ } /* L20: */ } } else { kk = 0; } /* Use unblocked code for the last or only block. */ if (kk < *n) { i__1 = *m - kk; i__2 = *n - kk; i__3 = *k - kk; zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & tau[kk + 1], &work[1], &iinfo); } if (kk > 0) { /* Use blocked code */ i__1 = -nb; for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { /* Computing MIN */ i__2 = nb, i__3 = *k - i__ + 1; ib = min(i__2,i__3); if (i__ + ib <= *n) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ i__2 = *m - i__ + 1; zlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork); /* Apply H to A(i:m,i+ib:n) from the left */ i__2 = *m - i__ + 1; i__3 = *n - i__ - ib + 1; zlarfb_("Left", "No transpose", "Forward", "Columnwise", & i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & work[ib + 1], &ldwork); } /* Apply H to rows i:m of current block */ i__2 = *m - i__ + 1; zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & work[1], &iinfo); /* Set rows 1:i-1 of current block to zero */ i__2 = i__ + ib - 1; for (j = i__; j <= i__2; ++j) { i__3 = i__ - 1; for (l = 1; l <= i__3; ++l) { i__4 = l + j * a_dim1; a[i__4].r = 0., a[i__4].i = 0.; /* L30: */ } /* L40: */ } /* L50: */ } } work[1].r = (doublereal) iws, work[1].i = 0.; return 0; /* End of ZUNGQR */ } /* zungqr_ */
/*< SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) >*/ /* Subroutine */ int zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, l, ib, nb, ki=0, kk, nx, iws, nbmin, iinfo; extern /* Subroutine */ int zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); integer ldwork; extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen); integer lwkopt; logical lquery; /* -- 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 */ /* .. Scalar Arguments .. */ /*< INTEGER INFO, K, LDA, LWORK, M, N >*/ /* .. */ /* .. Array Arguments .. */ /*< COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) >*/ /* .. */ /* Purpose */ /* ======= */ /* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, */ /* which is defined as the first N columns of a product of K elementary */ /* reflectors of order M */ /* Q = H(1) H(2) . . . H(k) */ /* as returned by ZGEQRF. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix Q. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q. M >= N >= 0. */ /* K (input) INTEGER */ /* The number of elementary reflectors whose product defines the */ /* matrix Q. N >= K >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the i-th column must contain the vector which */ /* defines the elementary reflector H(i), for i = 1,2,...,k, as */ /* returned by ZGEQRF in the first k columns of its array */ /* argument A. */ /* On exit, the M-by-N matrix Q. */ /* LDA (input) INTEGER */ /* The first dimension of the array A. LDA >= max(1,M). */ /* TAU (input) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGEQRF. */ /* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= max(1,N). */ /* For optimum performance LWORK >= N*NB, where NB is the */ /* optimal blocksize. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument has an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /*< COMPLEX*16 ZERO >*/ /*< PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) >*/ /* .. */ /* .. Local Scalars .. */ /*< LOGICAL LQUERY >*/ /*< >*/ /* .. */ /* .. External Subroutines .. */ /*< EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R >*/ /* .. */ /* .. Intrinsic Functions .. */ /*< INTRINSIC MAX, MIN >*/ /* .. */ /* .. External Functions .. */ /*< INTEGER ILAENV >*/ /*< EXTERNAL ILAENV >*/ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /*< INFO = 0 >*/ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; /*< NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) >*/ nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); /*< LWKOPT = MAX( 1, N )*NB >*/ lwkopt = max(1,*n) * nb; /*< WORK( 1 ) = LWKOPT >*/ work[1].r = (doublereal) lwkopt, work[1].i = 0.; /*< LQUERY = ( LWORK.EQ.-1 ) >*/ lquery = *lwork == -1; /*< IF( M.LT.0 ) THEN >*/ if (*m < 0) { /*< INFO = -1 >*/ *info = -1; /*< ELSE IF( N.LT.0 .OR. N.GT.M ) THEN >*/ } else if (*n < 0 || *n > *m) { /*< INFO = -2 >*/ *info = -2; /*< ELSE IF( K.LT.0 .OR. K.GT.N ) THEN >*/ } else if (*k < 0 || *k > *n) { /*< INFO = -3 >*/ *info = -3; /*< ELSE IF( LDA.LT.MAX( 1, M ) ) THEN >*/ } else if (*lda < max(1,*m)) { /*< INFO = -5 >*/ *info = -5; /*< ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN >*/ } else if (*lwork < max(1,*n) && ! lquery) { /*< INFO = -8 >*/ *info = -8; /*< END IF >*/ } /*< IF( INFO.NE.0 ) THEN >*/ if (*info != 0) { /*< CALL XERBLA( 'ZUNGQR', -INFO ) >*/ i__1 = -(*info); xerbla_("ZUNGQR", &i__1, (ftnlen)6); /*< RETURN >*/ return 0; /*< ELSE IF( LQUERY ) THEN >*/ } else if (lquery) { /*< RETURN >*/ return 0; /*< END IF >*/ } /* Quick return if possible */ /*< IF( N.LE.0 ) THEN >*/ if (*n <= 0) { /*< WORK( 1 ) = 1 >*/ work[1].r = 1., work[1].i = 0.; /*< RETURN >*/ return 0; /*< END IF >*/ } /*< NBMIN = 2 >*/ nbmin = 2; /*< NX = 0 >*/ nx = 0; /*< IWS = N >*/ iws = *n; /*< IF( NB.GT.1 .AND. NB.LT.K ) THEN >*/ if (nb > 1 && nb < *k) { /* Determine when to cross over from blocked to unblocked code. */ /*< NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) >*/ /* Computing MAX */ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGQR", " ", m, n, k, &c_n1, ( ftnlen)6, (ftnlen)1); nx = max(i__1,i__2); /*< IF( NX.LT.K ) THEN >*/ if (nx < *k) { /* Determine if workspace is large enough for blocked code. */ /*< LDWORK = N >*/ ldwork = *n; /*< IWS = LDWORK*NB >*/ iws = ldwork * nb; /*< IF( LWORK.LT.IWS ) THEN >*/ if (*lwork < iws) { /* Not enough workspace to use optimal NB: reduce NB and */ /* determine the minimum value of NB. */ /*< NB = LWORK / LDWORK >*/ nb = *lwork / ldwork; /*< NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) >*/ /* Computing MAX */ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); nbmin = max(i__1,i__2); /*< END IF >*/ } /*< END IF >*/ } /*< END IF >*/ } /*< IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN >*/ if (nb >= nbmin && nb < *k && nx < *k) { /* Use blocked code after the last block. */ /* The first kk columns are handled by the block method. */ /*< KI = ( ( K-NX-1 ) / NB )*NB >*/ ki = (*k - nx - 1) / nb * nb; /*< KK = MIN( K, KI+NB ) >*/ /* Computing MIN */ i__1 = *k, i__2 = ki + nb; kk = min(i__1,i__2); /* Set A(1:kk,kk+1:n) to zero. */ /*< DO 20 J = KK + 1, N >*/ i__1 = *n; for (j = kk + 1; j <= i__1; ++j) { /*< DO 10 I = 1, KK >*/ i__2 = kk; for (i__ = 1; i__ <= i__2; ++i__) { /*< A( I, J ) = ZERO >*/ i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /*< 10 CONTINUE >*/ /* L10: */ } /*< 20 CONTINUE >*/ /* L20: */ } /*< ELSE >*/ } else { /*< KK = 0 >*/ kk = 0; /*< END IF >*/ } /* Use unblocked code for the last or only block. */ /*< >*/ if (kk < *n) { i__1 = *m - kk; i__2 = *n - kk; i__3 = *k - kk; zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & tau[kk + 1], &work[1], &iinfo); } /*< IF( KK.GT.0 ) THEN >*/ if (kk > 0) { /* Use blocked code */ /*< DO 50 I = KI + 1, 1, -NB >*/ i__1 = -nb; for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { /*< IB = MIN( NB, K-I+1 ) >*/ /* Computing MIN */ i__2 = nb, i__3 = *k - i__ + 1; ib = min(i__2,i__3); /*< IF( I+IB.LE.N ) THEN >*/ if (i__ + ib <= *n) { /* Form the triangular factor of the block reflector */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ /*< >*/ i__2 = *m - i__ + 1; zlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, (ftnlen)7, (ftnlen)10); /* Apply H to A(i:m,i+ib:n) from the left */ /*< >*/ i__2 = *m - i__ + 1; i__3 = *n - i__ - ib + 1; zlarfb_("Left", "No transpose", "Forward", "Columnwise", & i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen) 7, (ftnlen)10); /*< END IF >*/ } /* Apply H to rows i:m of current block */ /*< >*/ i__2 = *m - i__ + 1; zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & work[1], &iinfo); /* Set rows 1:i-1 of current block to zero */ /*< DO 40 J = I, I + IB - 1 >*/ i__2 = i__ + ib - 1; for (j = i__; j <= i__2; ++j) { /*< DO 30 L = 1, I - 1 >*/ i__3 = i__ - 1; for (l = 1; l <= i__3; ++l) { /*< A( L, J ) = ZERO >*/ i__4 = l + j * a_dim1; a[i__4].r = 0., a[i__4].i = 0.; /*< 30 CONTINUE >*/ /* L30: */ } /*< 40 CONTINUE >*/ /* L40: */ } /*< 50 CONTINUE >*/ /* L50: */ } /*< END IF >*/ } /*< WORK( 1 ) = IWS >*/ work[1].r = (doublereal) iws, work[1].i = 0.; /*< RETURN >*/ return 0; /* End of ZUNGQR */ /*< END >*/ } /* zungqr_ */
/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal * rwork, doublecomplex *tau, 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 September 30, 1994 Purpose ======= ZGGSVP computes unitary matrices U, V and Q such that N-K-L K L U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; L ( 0 0 A23 ) M-K-L ( 0 0 0 ) N-K-L K L = K ( 0 A12 A13 ) if M-K-L < 0; M-K ( 0 0 A23 ) N-K-L K L V'*B*Q = L ( 0 0 B13 ) P-L ( 0 0 0 ) where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the conjugate transpose of Z. This decomposition is the preprocessing step for computing the Generalized Singular Value Decomposition (GSVD), see subroutine ZGGSVD. Arguments ========= JOBU (input) CHARACTER*1 = 'U': Unitary matrix U is computed; = 'N': U is not computed. JOBV (input) CHARACTER*1 = 'V': Unitary matrix V is computed; = 'N': V is not computed. JOBQ (input) CHARACTER*1 = 'Q': Unitary matrix Q is computed; = 'N': Q is not computed. M (input) INTEGER The number of rows of the matrix A. M >= 0. P (input) INTEGER The number of rows of the matrix B. P >= 0. N (input) INTEGER The number of columns of the matrices A and B. N >= 0. A (input/output) COMPLEX*16 array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A contains the triangular (or trapezoidal) matrix described in the Purpose section. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input/output) COMPLEX*16 array, dimension (LDB,N) On entry, the P-by-N matrix B. On exit, B contains the triangular matrix described in the Purpose section. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,P). TOLA (input) DOUBLE PRECISION TOLB (input) DOUBLE PRECISION TOLA and TOLB are the thresholds to determine the effective numerical rank of matrix B and a subblock of A. Generally, they are set to TOLA = MAX(M,N)*norm(A)*MAZHEPS, TOLB = MAX(P,N)*norm(B)*MAZHEPS. The size of TOLA and TOLB may affect the size of backward errors of the decomposition. K (output) INTEGER L (output) INTEGER On exit, K and L specify the dimension of the subblocks described in Purpose section. K + L = effective numerical rank of (A',B')'. U (output) COMPLEX*16 array, dimension (LDU,M) If JOBU = 'U', U contains the unitary matrix U. If JOBU = 'N', U is not referenced. LDU (input) INTEGER The leading dimension of the array U. LDU >= max(1,M) if JOBU = 'U'; LDU >= 1 otherwise. V (output) COMPLEX*16 array, dimension (LDV,M) If JOBV = 'V', V contains the unitary matrix V. If JOBV = 'N', V is not referenced. LDV (input) INTEGER The leading dimension of the array V. LDV >= max(1,P) if JOBV = 'V'; LDV >= 1 otherwise. Q (output) COMPLEX*16 array, dimension (LDQ,N) If JOBQ = 'Q', Q contains the unitary matrix Q. If JOBQ = 'N', Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N) if JOBQ = 'Q'; LDQ >= 1 otherwise. IWORK (workspace) INTEGER array, dimension (N) RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) TAU (workspace) COMPLEX*16 array, dimension (N) WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. Further Details =============== The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization with column pivoting to detect the effective numerical rank of the a matrix. It may be replaced by a better rank determination strategy. ===================================================================== Test the input parameters Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3; doublereal d__1, d__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); static logical wantq, wantu, wantv; extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_( integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( char *, integer *), zgeqpf_(integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static logical forwrd; extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, integer *, doublecomplex *, integer *, integer *); #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 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 v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1 #define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; v_dim1 = *ldv; v_offset = 1 + v_dim1 * 1; v -= v_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --iwork; --rwork; --tau; --work; /* Function Body */ wantu = lsame_(jobu, "U"); wantv = lsame_(jobv, "V"); wantq = lsame_(jobq, "Q"); forwrd = TRUE_; *info = 0; if (! (wantu || lsame_(jobu, "N"))) { *info = -1; } else if (! (wantv || lsame_(jobv, "N"))) { *info = -2; } else if (! (wantq || lsame_(jobq, "N"))) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*p < 0) { *info = -5; } else if (*n < 0) { *info = -6; } else if (*lda < max(1,*m)) { *info = -8; } else if (*ldb < max(1,*p)) { *info = -10; } else if (*ldu < 1 || wantu && *ldu < *m) { *info = -16; } else if (*ldv < 1 || wantv && *ldv < *p) { *info = -18; } else if (*ldq < 1 || wantq && *ldq < *n) { *info = -20; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGGSVP", &i__1); return 0; } /* QR with column pivoting of B: B*P = V*( S11 S12 ) ( 0 0 ) */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = 0; /* L10: */ } zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1], info); /* Update A := A*P */ zlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); /* Determine the effective rank of matrix B. */ *l = 0; i__1 = min(*p,*n); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, i__); if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__, i__)), abs(d__2)) > *tolb) { ++(*l); } /* L20: */ } if (wantv) { /* Copy the details of V, and form V. */ zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv); if (*p > 1) { i__1 = *p - 1; zlacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv); } i__1 = min(*p,*n); zung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); } /* Clean up B */ i__1 = *l - 1; for (j = 1; j <= i__1; ++j) { i__2 = *l; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0., b[i__3].i = 0.; /* L30: */ } /* L40: */ } if (*p > *l) { i__1 = *p - *l; zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb); } if (wantq) { /* Set Q = I and Update Q := Q*P */ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); } if (*p >= *l && *n != *l) { /* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */ zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); /* Update A := A*Z' */ zunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, & tau[1], &a[a_offset], lda, &work[1], info); if (wantq) { /* Update Q := Q*Z' */ zunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset], ldb, &tau[1], &q[q_offset], ldq, &work[1], info); } /* Clean up B */ i__1 = *n - *l; zlaset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb); i__1 = *n; for (j = *n - *l + 1; j <= i__1; ++j) { i__2 = *l; for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0., b[i__3].i = 0.; /* L50: */ } /* L60: */ } } /* Let N-L L A = ( A11 A12 ) M, then the following does the complete QR decomposition of A11: A11 = U*( 0 T12 )*P1' ( 0 0 ) */ i__1 = *n - *l; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = 0; /* L70: */ } i__1 = *n - *l; zgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[ 1], info); /* Determine the effective rank of A11 */ *k = 0; /* Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = a_subscr(i__, i__); if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, i__)), abs(d__2)) > *tola) { ++(*k); } /* L80: */ } /* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); zunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, & tau[1], &a_ref(1, *n - *l + 1), lda, &work[1], info); if (wantu) { /* Copy the details of U, and form U */ zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu); if (*m > 1) { i__1 = *m - 1; i__2 = *n - *l; zlacpy_("Lower", &i__1, &i__2, &a_ref(2, 1), lda, &u_ref(2, 1), ldu); } /* Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); zung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); } if (wantq) { /* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ i__1 = *n - *l; zlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); } /* Clean up A: set the strictly lower triangular part of A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ i__1 = *k - 1; for (j = 1; j <= i__1; ++j) { i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0., a[i__3].i = 0.; /* L90: */ } /* L100: */ } if (*m > *k) { i__1 = *m - *k; i__2 = *n - *l; zlaset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a_ref(*k + 1, 1), lda); } if (*n - *l > *k) { /* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ i__1 = *n - *l; zgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); if (wantq) { /* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */ i__1 = *n - *l; zunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset], lda, &tau[1], &q[q_offset], ldq, &work[1], info); } /* Clean up A */ i__1 = *n - *l - *k; zlaset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda); i__1 = *n - *l; for (j = *n - *l - *k + 1; j <= i__1; ++j) { i__2 = *k; for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0., a[i__3].i = 0.; /* L110: */ } /* L120: */ } } if (*m > *k) { /* QR factorization of A( K+1:M,N-L+1:N ) */ i__1 = *m - *k; zgeqr2_(&i__1, l, &a_ref(*k + 1, *n - *l + 1), lda, &tau[1], &work[1], info); if (wantu) { /* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ i__1 = *m - *k; /* Computing MIN */ i__3 = *m - *k; i__2 = min(i__3,*l); zunm2r_("Right", "No transpose", m, &i__1, &i__2, &a_ref(*k + 1, * n - *l + 1), lda, &tau[1], &u_ref(1, *k + 1), ldu, &work[ 1], info); } /* Clean up */ i__1 = *n; for (j = *n - *l + 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0., a[i__3].i = 0.; /* L130: */ } /* L140: */ } } return 0; /* End of ZGGSVP */ } /* zggsvp_ */
/* Subroutine */ int zerrqr_(char *path, integer *nunit) { /* System generated locals */ integer i__1; doublereal d__1, d__2; doublecomplex z__1; /* Builtin functions */ integer s_wsle(cilist *), e_wsle(void); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static integer info; static doublecomplex a[4] /* was [2][2] */, b[2]; static integer i__, j; static doublecomplex w[2], x[2], af[4] /* was [2][2] */; extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zung2r_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical *), zgeqrf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *) , zgeqrs_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *), zungqr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); /* Fortran I/O blocks */ static cilist io___1 = { 0, 0, 0, 0, 0 }; #define a_subscr(a_1,a_2) (a_2)*2 + a_1 - 3 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*2 + a_1 - 3 #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 February 29, 1992 Purpose ======= ZERRQR tests the error exits for the COMPLEX*16 routines that use the QR decomposition of a general matrix. Arguments ========= PATH (input) CHARACTER*3 The LAPACK path name for the routines to be tested. NUNIT (input) INTEGER The unit number for output. ===================================================================== */ infoc_1.nout = *nunit; io___1.ciunit = infoc_1.nout; s_wsle(&io___1); e_wsle(); /* Set the variables to innocuous values. */ for (j = 1; j <= 2; ++j) { for (i__ = 1; i__ <= 2; ++i__) { i__1 = a_subscr(i__, j); d__1 = 1. / (doublereal) (i__ + j); d__2 = -1. / (doublereal) (i__ + j); z__1.r = d__1, z__1.i = d__2; a[i__1].r = z__1.r, a[i__1].i = z__1.i; i__1 = af_subscr(i__, j); d__1 = 1. / (doublereal) (i__ + j); d__2 = -1. / (doublereal) (i__ + j); z__1.r = d__1, z__1.i = d__2; af[i__1].r = z__1.r, af[i__1].i = z__1.i; /* L10: */ } i__1 = j - 1; b[i__1].r = 0., b[i__1].i = 0.; i__1 = j - 1; w[i__1].r = 0., w[i__1].i = 0.; i__1 = j - 1; x[i__1].r = 0., x[i__1].i = 0.; /* L20: */ } infoc_1.ok = TRUE_; /* Error exits for QR factorization ZGEQRF */ s_copy(srnamc_1.srnamt, "ZGEQRF", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info); chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info); chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info); chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info); chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZGEQR2 */ s_copy(srnamc_1.srnamt, "ZGEQR2", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info); chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info); chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info); chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZGEQRS */ s_copy(srnamc_1.srnamt, "ZGEQRS", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; zgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; zgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info); chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZUNGQR */ s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zungqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zungqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zungqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zungqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zungqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zungqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; zungqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info); chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZUNG2R */ s_copy(srnamc_1.srnamt, "ZUNG2R", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zung2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info); chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zung2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info); chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zung2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info); chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zung2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info); chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zung2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info); chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zung2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info); chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZUNMQR */ s_copy(srnamc_1.srnamt, "ZUNMQR", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zunmqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zunmqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zunmqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zunmqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunmqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zunmqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; zunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 12; zunmqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 12; zunmqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, & info); chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZUNM2R */ s_copy(srnamc_1.srnamt, "ZUNM2R", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; zunm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zunm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; zunm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zunm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; zunm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; zunm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; zunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info); chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* Print a summary line. */ alaesm_(path, &infoc_1.ok, &infoc_1.nout); return 0; /* End of ZERRQR */ } /* zerrqr_ */
/* Subroutine */ int zupgtr_(char *uplo, integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *q, integer *ldq, doublecomplex * work, integer *info) { /* System generated locals */ integer q_dim1, q_offset, i__1, i__2, i__3, i__4; /* Local variables */ integer i__, j, ij; integer iinfo; logical upper; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZUPGTR generates a complex unitary matrix Q which is defined as the */ /* product of n-1 elementary reflectors H(i) of order n, as returned by */ /* ZHPTRD using packed storage: */ /* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ /* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangular packed storage used in previous */ /* call to ZHPTRD; */ /* = 'L': Lower triangular packed storage used in previous */ /* call to ZHPTRD. */ /* N (input) INTEGER */ /* The order of the matrix Q. N >= 0. */ /* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The vectors which define the elementary reflectors, as */ /* returned by ZHPTRD. */ /* TAU (input) COMPLEX*16 array, dimension (N-1) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZHPTRD. */ /* Q (output) COMPLEX*16 array, dimension (LDQ,N) */ /* The N-by-N unitary matrix Q. */ /* LDQ (input) INTEGER */ /* The leading dimension of the array Q. LDQ >= max(1,N). */ /* WORK (workspace) COMPLEX*16 array, dimension (N-1) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* Test the input arguments */ /* Parameter adjustments */ --ap; --tau; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldq < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUPGTR", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (upper) { /* Q was determined by a call to ZHPTRD with UPLO = 'U' */ /* Unpack the vectors which define the elementary reflectors and */ /* set the last row and column of Q equal to those of the unit */ /* matrix */ ij = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * q_dim1; i__4 = ij; q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i; ++ij; } ij += 2; i__2 = *n + j * q_dim1; q[i__2].r = 0., q[i__2].i = 0.; } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + *n * q_dim1; q[i__2].r = 0., q[i__2].i = 0.; } i__1 = *n + *n * q_dim1; q[i__1].r = 1., q[i__1].i = 0.; /* Generate Q(1:n-1,1:n-1) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; zung2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & iinfo); } else { /* Q was determined by a call to ZHPTRD with UPLO = 'L'. */ /* Unpack the vectors which define the elementary reflectors and */ /* set the first row and column of Q equal to those of the unit */ /* matrix */ i__1 = q_dim1 + 1; q[i__1].r = 1., q[i__1].i = 0.; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = i__ + q_dim1; q[i__2].r = 0., q[i__2].i = 0.; } ij = 3; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j * q_dim1 + 1; q[i__2].r = 0., q[i__2].i = 0.; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * q_dim1; i__4 = ij; q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i; ++ij; } ij += 2; } if (*n > 1) { /* Generate Q(2:n,2:n) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; zung2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], &work[1], &iinfo); } } return 0; /* End of ZUPGTR */ } /* zupgtr_ */
/* Subroutine */ int zupgtr_(char *uplo, integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *q, integer *ldq, doublecomplex * work, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZUPGTR generates a complex unitary matrix Q which is defined as the product of n-1 elementary reflectors H(i) of order n, as returned by ZHPTRD using packed storage: if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangular packed storage used in previous call to ZHPTRD; = 'L': Lower triangular packed storage used in previous call to ZHPTRD. N (input) INTEGER The order of the matrix Q. N >= 0. AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) The vectors which define the elementary reflectors, as returned by ZHPTRD. TAU (input) COMPLEX*16 array, dimension (N-1) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by ZHPTRD. Q (output) COMPLEX*16 array, dimension (LDQ,N) The N-by-N unitary matrix Q. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). WORK (workspace) COMPLEX*16 array, dimension (N-1) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments Function Body */ /* System generated locals */ integer q_dim1, q_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i, j; extern logical lsame_(char *, char *); static integer iinfo; static logical upper; extern /* Subroutine */ int zung2l_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static integer ij; extern /* Subroutine */ int zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *); #define AP(I) ap[(I)-1] #define TAU(I) tau[(I)-1] #define WORK(I) work[(I)-1] #define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)] *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldq < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUPGTR", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (upper) { /* Q was determined by a call to ZHPTRD with UPLO = 'U' Unpack the vectors which define the elementary reflectors an d set the last row and column of Q equal to those of the unit matrix */ ij = 2; i__1 = *n - 1; for (j = 1; j <= *n-1; ++j) { i__2 = j - 1; for (i = 1; i <= j-1; ++i) { i__3 = i + j * q_dim1; i__4 = ij; Q(i,j).r = AP(ij).r, Q(i,j).i = AP(ij).i; ++ij; /* L10: */ } ij += 2; i__2 = *n + j * q_dim1; Q(*n,j).r = 0., Q(*n,j).i = 0.; /* L20: */ } i__1 = *n - 1; for (i = 1; i <= *n-1; ++i) { i__2 = i + *n * q_dim1; Q(i,*n).r = 0., Q(i,*n).i = 0.; /* L30: */ } i__1 = *n + *n * q_dim1; Q(*n,*n).r = 1., Q(*n,*n).i = 0.; /* Generate Q(1:n-1,1:n-1) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; zung2l_(&i__1, &i__2, &i__3, &Q(1,1), ldq, &TAU(1), &WORK(1), & iinfo); } else { /* Q was determined by a call to ZHPTRD with UPLO = 'L'. Unpack the vectors which define the elementary reflectors an d set the first row and column of Q equal to those of the unit matrix */ i__1 = q_dim1 + 1; Q(1,1).r = 1., Q(1,1).i = 0.; i__1 = *n; for (i = 2; i <= *n; ++i) { i__2 = i + q_dim1; Q(i,1).r = 0., Q(i,1).i = 0.; /* L40: */ } ij = 3; i__1 = *n; for (j = 2; j <= *n; ++j) { i__2 = j * q_dim1 + 1; Q(1,j).r = 0., Q(1,j).i = 0.; i__2 = *n; for (i = j + 1; i <= *n; ++i) { i__3 = i + j * q_dim1; i__4 = ij; Q(i,j).r = AP(ij).r, Q(i,j).i = AP(ij).i; ++ij; /* L50: */ } ij += 2; /* L60: */ } if (*n > 1) { /* Generate Q(2:n,2:n) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; zung2r_(&i__1, &i__2, &i__3, &Q(2,2), ldq, &TAU(1), &WORK(1), &iinfo); } } return 0; /* End of ZUPGTR */ } /* zupgtr_ */