#include "f2c.h" /* Mod by jack to compile huge routine on 68000 compiler: */ #if defined(__MWERKS__) && !defined(__powerc) #define BIGROUTINEHACK #endif #if defined(__MWERKS__) && defined(__powerc) /* Some routines here are too big for optimizer level 4 */ #pragma optimization_level 1 #endif static integer c__1 = 1; static integer c__0 = 0; static integer c__6 = 6; static integer c__4 = 4; static integer c__8 = 8; static integer c_n1 = -1; static integer c__65 = 65; static integer c__15 = 15; static integer c__3 = 3; static integer c__2 = 2; static logical c_false = FALSE_; static doublereal c_b48 = 1.; static doublereal c_b36 = .5; static doublereal c_b15 = -.125; static doublereal c_b71 = -1.; static doublereal c_b78 = 0.; static doublecomplex c_b5 = {1.,0.}; static doublecomplex c_b1a = {1.,0.}; static doublecomplex c_b2a = {0.,0.}; static doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; /* zlahrd.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1 #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int zlahrd_(n, k, nb, a, lda, tau, t, ldt, y, ldy) integer *n, *k, *nb; doublecomplex *a; integer *lda; doublecomplex *tau, *t; integer *ldt; doublecomplex *y; integer *ldy; { /* System generated locals */ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, i__3; doublecomplex z__1; /* Local variables */ static integer i__; extern /* Subroutine */ int zscal_(), zgemv_(), zcopy_(), zaxpy_(), ztrmv_(); static doublecomplex ei; extern /* Subroutine */ int zlarfg_(), zlacgv_(); /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */ /* matrix A so that elements below the k-th subdiagonal are zero. The */ /* reduction is performed by a unitary similarity transformation */ /* Q' * A * Q. The routine returns the matrices V and T which determine */ /* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */ /* This is an auxiliary routine called by ZGEHRD. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. */ /* K (input) INTEGER */ /* The offset for the reduction. Elements below the k-th */ /* subdiagonal in the first NB columns are reduced to zero. */ /* NB (input) INTEGER */ /* The number of columns to be reduced. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */ /* On entry, the n-by-(n-k+1) general matrix A. */ /* On exit, the elements on and above the k-th subdiagonal in */ /* the first NB columns are overwritten with the corresponding */ /* elements of the reduced matrix; the elements below the k-th */ /* subdiagonal, with the array TAU, represent the matrix Q as a */ /* product of elementary reflectors. The other columns of A are */ /* unchanged. See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* TAU (output) COMPLEX*16 array, dimension (NB) */ /* The scalar factors of the elementary reflectors. See Further */ /* Details. */ /* T (output) COMPLEX*16 array, dimension (NB,NB) */ /* The upper triangular matrix T. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= NB. */ /* Y (output) COMPLEX*16 array, dimension (LDY,NB) */ /* The n-by-nb matrix Y. */ /* LDY (input) INTEGER */ /* The leading dimension of the array Y. LDY >= max(1,N). */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of nb elementary reflectors */ /* Q = H(1) H(2) . . . H(nb). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ /* A(i+k+1:n,i), and tau in TAU(i). */ /* The elements of the vectors v together form the (n-k+1)-by-nb matrix */ /* V which is needed, with T and Y, to apply the transformation to the */ /* unreduced part of the matrix, using an update of the form: */ /* A := (I - V*T*V') * (A - Y*V'). */ /* The contents of A on exit are illustrated by the following example */ /* with n = 7, k = 3 and nb = 2: */ /* ( a h a a a ) */ /* ( a h a a a ) */ /* ( a h a a a ) */ /* ( h h a a a ) */ /* ( v1 h a a a ) */ /* ( v1 v2 a a a ) */ /* ( v1 v2 a a a ) */ /* where a denotes an element of the original matrix A, h denotes a */ /* modified element of the upper Hessenberg matrix H, and vi denotes an */ /* element of the vector defining H(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* Parameter adjustments */ --tau; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; t_dim1 = *ldt; t_offset = t_dim1 + 1; t -= t_offset; y_dim1 = *ldy; y_offset = y_dim1 + 1; y -= y_offset; /* Function Body */ if (*n <= 1) { return 0; } i__1 = *nb; for (i__ = 1; i__ <= i__1; ++i__) { if (i__ > 1) { /* Update A(1:n,i) */ /* Compute i-th column of A - Y * V' */ i__2 = i__ - 1; zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); i__2 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], & c__1, 12L); i__2 = i__ - 1; zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); /* Apply I - V * T' * V' to this column (call it b) from the */ /* left, using the last column of T as workspace */ /* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ /* ( V2 ) ( b2 ) */ /* where V1 is unit lower triangular */ /* w := V1' * b1 */ i__2 = i__ - 1; zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + 1], &c__1); i__2 = i__ - 1; ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 + a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1, 5L, 19L, 4L); /* w := w + V2'*b2 */ i__2 = *n - *k - i__ + 1; i__3 = i__ - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, & t[*nb * t_dim1 + 1], &c__1, 19L); /* w := T'*w */ i__2 = i__ - 1; ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[ t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1, 5L, 19L, 8L); /* b2 := b2 - V2*w */ i__2 = *n - *k - i__ + 1; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ + i__ * a_dim1], &c__1, 12L); /* b1 := b1 - V1*w */ i__2 = i__ - 1; ztrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1] , lda, &t[*nb * t_dim1 + 1], &c__1, 5L, 12L, 4L); i__2 = i__ - 1; z__1.r = -1., z__1.i = 0.; zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ * a_dim1], &c__1); i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1; a[i__2].r = ei.r, a[i__2].i = ei.i; } /* Generate the elementary reflector H(i) to annihilate */ /* A(k+i+1:n,i) */ i__2 = *k + i__ + i__ * a_dim1; ei.r = a[i__2].r, ei.i = a[i__2].i; i__2 = *n - *k - i__ + 1; /* Computing MIN */ i__3 = *k + i__ + 1; zlarfg_(&i__2, &ei, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]) ; i__2 = *k + i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Compute Y(1:n,i) */ i__2 = *n - *k - i__ + 1; zgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ * y_dim1 + 1], &c__1, 12L); i__2 = *n - *k - i__ + 1; i__3 = i__ - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[ i__ * t_dim1 + 1], &c__1, 19L); i__2 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1, 12L); zscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1); /* Compute T(1:i,i) */ i__2 = i__ - 1; i__3 = i__; z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1); i__2 = i__ - 1; ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, 5L, 12L, 8L); i__2 = i__ + i__ * t_dim1; i__3 = i__; t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; /* L10: */ } i__1 = *k + *nb + *nb * a_dim1; a[i__1].r = ei.r, a[i__1].i = ei.i; return 0; /* End of ZLAHRD */ } /* zlahrd_ */ /* zunmqr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zunmqr_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *c__; integer *ldc; doublecomplex *work; integer *lwork, *info; ftnlen side_len; ftnlen trans_len; { /* 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(); /* Local variables */ static logical left; static integer i__; static doublecomplex t[4160] /* was [65][64] */; extern logical lsame_(); static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc, nb, mi, ni; extern /* Subroutine */ int zunm2r_(); static integer nq, nw; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(); static logical notran; static integer ldwork; extern /* Subroutine */ int zlarft_(); static integer iws; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNMQR 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 ZGEQRF. 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. */ /* A (input) COMPLEX*16 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 */ /* ZGEQRF 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) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGEQRF. */ /* 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**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*16 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. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); /* 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", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "C", 1L, 1L)) { *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)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNMQR", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { work[1].r = 1., work[1].i = 0.; 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, 2L); i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMQR", ch__1, m, n, k, &c_n1, 6L, 2L); 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, 2L); i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMQR", ch__1, m, n, k, &c_n1, 6L, 2L); nbmin = max(i__1,i__2); } } else { iws = nw; } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ zunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo, 1L, 1L); } 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; zlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65, 7L, 10L); 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' */ zlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 10L); /* L10: */ } } work[1].r = (doublereal) iws, work[1].i = 0.; return 0; /* End of ZUNMQR */ } /* zunmqr_ */ /* zgeev.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgeev_(jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr, work, lwork, rwork, info, jobvl_len, jobvr_len) char *jobvl, *jobvr; integer *n; doublecomplex *a; integer *lda; doublecomplex *w, *vl; integer *ldvl; doublecomplex *vr; integer *ldvr; doublecomplex *work; integer *lwork; doublereal *rwork; integer *info; ftnlen jobvl_len; ftnlen jobvr_len; { /* System generated locals */ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1, z__2; /* Builtin functions */ double sqrt(), d_imag(); void d_cnjg(); /* Local variables */ static integer ibal; static char side[1]; static integer maxb; static doublereal anrm; static integer ierr, itau, iwrk, nout, i__, k; extern logical lsame_(); extern /* Subroutine */ int zscal_(), dlabad_(); extern doublereal dznrm2_(); static logical scalea; extern doublereal dlamch_(); static doublereal cscale; extern /* Subroutine */ int zgebak_(), zgebal_(); extern integer idamax_(); extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); static logical select[1]; extern /* Subroutine */ int zdscal_(); static doublereal bignum; extern doublereal zlange_(); extern /* Subroutine */ int zgehrd_(), zlascl_(), zlacpy_(); static integer minwrk, maxwrk; static logical wantvl; static doublereal smlnum; static integer hswork, irwork; extern /* Subroutine */ int zhseqr_(), ztrevc_(); static logical wantvr; extern /* Subroutine */ int zunghr_(); static integer ihi; static doublereal scl; static integer ilo; static doublereal dum[1], eps; static doublecomplex tmp; /* -- LAPACK driver routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the */ /* eigenvalues and, optionally, the left and/or right eigenvectors. */ /* The right eigenvector v(j) of A satisfies */ /* A * v(j) = lambda(j) * v(j) */ /* where lambda(j) is its eigenvalue. */ /* The left eigenvector u(j) of A satisfies */ /* u(j)**H * A = lambda(j) * u(j)**H */ /* where u(j)**H denotes the conjugate transpose of u(j). */ /* The computed eigenvectors are normalized to have Euclidean norm */ /* equal to 1 and largest component real. */ /* Arguments */ /* ========= */ /* JOBVL (input) CHARACTER*1 */ /* = 'N': left eigenvectors of A are not computed; */ /* = 'V': left eigenvectors of are computed. */ /* JOBVR (input) CHARACTER*1 */ /* = 'N': right eigenvectors of A are not computed; */ /* = 'V': right eigenvectors of A are computed. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* On exit, A has been overwritten. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* W (output) COMPLEX*16 array, dimension (N) */ /* W contains the computed eigenvalues. */ /* VL (output) COMPLEX*16 array, dimension (LDVL,N) */ /* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ /* after another in the columns of VL, in the same order */ /* as their eigenvalues. */ /* If JOBVL = 'N', VL is not referenced. */ /* u(j) = VL(:,j), the j-th column of VL. */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= 1; if */ /* JOBVL = 'V', LDVL >= N. */ /* VR (output) COMPLEX*16 array, dimension (LDVR,N) */ /* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ /* after another in the columns of VR, in the same order */ /* as their eigenvalues. */ /* If JOBVR = 'N', VR is not referenced. */ /* v(j) = VR(:,j), the j-th column of VR. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1; if */ /* JOBVR = 'V', LDVR >= N. */ /* 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,2*N). */ /* For good performance, LWORK must generally be larger. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the QR algorithm failed to compute all the */ /* eigenvalues, and no eigenvectors have been computed; */ /* elements and i+1:N of W contain eigenvalues which have */ /* converged. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --w; vl_dim1 = *ldvl; vl_offset = vl_dim1 + 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = vr_dim1 + 1; vr -= vr_offset; --work; --rwork; /* Function Body */ *info = 0; wantvl = lsame_(jobvl, "V", 1L, 1L); wantvr = lsame_(jobvr, "V", 1L, 1L); if (! wantvl && ! lsame_(jobvl, "N", 1L, 1L)) { *info = -1; } else if (! wantvr && ! lsame_(jobvr, "N", 1L, 1L)) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldvl < 1 || wantvl && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || wantvr && *ldvr < *n) { *info = -10; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* CWorkspace refers to complex workspace, and RWorkspace to real */ /* workspace. NB refers to the optimal block size for the */ /* immediately following subroutine, as returned by ILAENV. */ /* HSWORK refers to the workspace preferred by ZHSEQR, as */ /* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ /* the worst case.) */ minwrk = 1; if (*info == 0 && *lwork >= 1) { maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &c__0, 6L, 1L); if (! wantvl && ! wantvr) { /* Computing MAX */ i__1 = 1, i__2 = *n << 1; minwrk = max(i__1,i__2); /* Computing MAX */ i__1 = ilaenv_(&c__8, "ZHSEQR", "EN", n, &c__1, n, &c_n1, 6L, 2L); maxb = max(i__1,2); /* Computing MIN */ /* Computing MAX */ i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "EN", n, &c__1, n, & c_n1, 6L, 2L); i__1 = min(maxb,*n), i__2 = max(i__3,i__4); k = min(i__1,i__2); /* Computing MAX */ i__1 = k * (k + 2), i__2 = *n << 1; hswork = max(i__1,i__2); maxwrk = max(maxwrk,hswork); } else { /* Computing MAX */ i__1 = 1, i__2 = *n << 1; minwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", " ", n, &c__1, n, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = ilaenv_(&c__8, "ZHSEQR", "SV", n, &c__1, n, &c_n1, 6L, 2L); maxb = max(i__1,2); /* Computing MIN */ /* Computing MAX */ i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SV", n, &c__1, n, & c_n1, 6L, 2L); i__1 = min(maxb,*n), i__2 = max(i__3,i__4); k = min(i__1,i__2); /* Computing MAX */ i__1 = k * (k + 2), i__2 = *n << 1; hswork = max(i__1,i__2); /* Computing MAX */ i__1 = max(maxwrk,hswork), i__2 = *n << 1; maxwrk = max(i__1,i__2); } work[1].r = (doublereal) maxwrk, work[1].i = 0.; } if (*lwork < minwrk) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEEV ", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = dlamch_("P", 1L); smlnum = dlamch_("S", 1L); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1. / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = zlange_("M", n, n, &a[a_offset], lda, dum, 1L); scalea = FALSE_; if (anrm > 0. && anrm < smlnum) { scalea = TRUE_; cscale = smlnum; } else if (anrm > bignum) { scalea = TRUE_; cscale = bignum; } if (scalea) { zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr, 1L); } /* Balance the matrix */ /* (CWorkspace: none) */ /* (RWorkspace: need N) */ ibal = 1; zgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr, 1L); /* Reduce to upper Hessenberg form */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: none) */ itau = 1; iwrk = itau + *n; i__1 = *lwork - iwrk + 1; zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &ierr); if (wantvl) { /* Want left eigenvectors */ /* Copy Householder vectors to VL */ *(unsigned char *)side = 'L'; zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl, 1L); /* Generate unitary matrix in VL */ /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwrk + 1; zunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VL */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[iwrk], &i__1, info, 1L, 1L); if (wantvr) { /* Want left and right eigenvectors */ /* Copy Schur vectors to VR */ *(unsigned char *)side = 'B'; zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, 1L) ; } } else if (wantvr) { /* Want right eigenvectors */ /* Copy Householder vectors to VR */ *(unsigned char *)side = 'R'; zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr, 1L); /* Generate unitary matrix in VR */ /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwrk + 1; zunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VR */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info, 1L, 1L); } else { /* Compute eigenvalues only */ /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ /* (RWorkspace: none) */ iwrk = itau; i__1 = *lwork - iwrk + 1; zhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info, 1L, 1L); } /* If INFO > 0 from ZHSEQR, then quit */ if (*info > 0) { goto L50; } if (wantvl || wantvr) { /* Compute left and/or right eigenvectors */ /* (CWorkspace: need 2*N) */ /* (RWorkspace: need 2*N) */ irwork = ibal + *n; ztrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork], &ierr, 1L, 1L); } if (wantvl) { /* Undo balancing of left eigenvectors */ /* (CWorkspace: none) */ /* (RWorkspace: need N) */ zgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset], ldvl, &ierr, 1L, 1L); /* Normalize left eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + i__ * vl_dim1; /* Computing 2nd power */ d__1 = vl[i__3].r; /* Computing 2nd power */ d__2 = d_imag(&vl[k + i__ * vl_dim1]); rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2; /* L10: */ } k = idamax_(n, &rwork[irwork], &c__1); d_cnjg(&z__2, &vl[k + i__ * vl_dim1]); d__1 = sqrt(rwork[irwork + k - 1]); z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; tmp.r = z__1.r, tmp.i = z__1.i; zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1); i__2 = k + i__ * vl_dim1; i__3 = k + i__ * vl_dim1; d__1 = vl[i__3].r; z__1.r = d__1, z__1.i = 0.; vl[i__2].r = z__1.r, vl[i__2].i = z__1.i; /* L20: */ } } if (wantvr) { /* Undo balancing of right eigenvectors */ /* (CWorkspace: none) */ /* (RWorkspace: need N) */ zgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset], ldvr, &ierr, 1L, 1L); /* Normalize right eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + i__ * vr_dim1; /* Computing 2nd power */ d__1 = vr[i__3].r; /* Computing 2nd power */ d__2 = d_imag(&vr[k + i__ * vr_dim1]); rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2; /* L30: */ } k = idamax_(n, &rwork[irwork], &c__1); d_cnjg(&z__2, &vr[k + i__ * vr_dim1]); d__1 = sqrt(rwork[irwork + k - 1]); z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; tmp.r = z__1.r, tmp.i = z__1.i; zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1); i__2 = k + i__ * vr_dim1; i__3 = k + i__ * vr_dim1; d__1 = vr[i__3].r; z__1.r = d__1, z__1.i = 0.; vr[i__2].r = z__1.r, vr[i__2].i = z__1.i; /* L40: */ } } /* Undo scaling if necessary */ L50: if (scalea) { i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = max(i__3,1); zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1] , &i__2, &ierr, 1L); if (*info > 0) { i__1 = ilo - 1; zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n, &ierr, 1L); } } work[1].r = (doublereal) maxwrk, work[1].i = 0.; return 0; /* End of ZGEEV */ } /* zgeev_ */ /* zgetrf.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1a /* Subroutine */ int zgetrf_(m, n, a, lda, ipiv, info) integer *m, *n; doublecomplex *a; integer *lda, *ipiv, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1; /* Local variables */ static integer i__, j, iinfo; extern /* Subroutine */ int zgemm_(), ztrsm_(), zgetf2_(); static integer jb, nb; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlaswp_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGETRF computes an LU factorization of a general M-by-N matrix A */ /* using partial pivoting with row interchanges. */ /* The factorization has the form */ /* A = P * L * U */ /* where P is a permutation matrix, L is lower triangular with unit */ /* diagonal elements (lower trapezoidal if m > n), and U is upper */ /* triangular (upper trapezoidal if m < n). */ /* This is the right-looking Level 3 BLAS version of the algorithm. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the M-by-N matrix to be factored. */ /* On exit, the factors L and U from the factorization */ /* A = P*L*U; the unit diagonal elements of L are not stored. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* IPIV (output) INTEGER array, dimension (min(M,N)) */ /* The pivot indices; for 1 <= i <= min(M,N), row i of the */ /* matrix was interchanged with row IPIV(i). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ /* has been completed, but the factor U is exactly */ /* singular, and division by zero will occur if it is used */ /* to solve a system of equations. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --ipiv; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGETRF", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, "ZGETRF", " ", m, n, &c_n1, &c_n1, 6L, 1L); if (nb <= 1 || nb >= min(*m,*n)) { /* Use unblocked code. */ zgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info); } else { /* Use blocked code. */ i__1 = min(*m,*n); i__2 = nb; for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Computing MIN */ i__3 = min(*m,*n) - j + 1; jb = min(i__3,nb); /* Factor diagonal and subdiagonal blocks and test for e xact */ /* singularity. */ i__3 = *m - j + 1; zgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo); /* Adjust INFO and the pivot indices. */ if (*info == 0 && iinfo > 0) { *info = iinfo + j - 1; } /* Computing MIN */ i__4 = *m, i__5 = j + jb - 1; i__3 = min(i__4,i__5); for (i__ = j; i__ <= i__3; ++i__) { ipiv[i__] = j - 1 + ipiv[i__]; /* L10: */ } /* Apply interchanges to columns 1:J-1. */ i__3 = j - 1; i__4 = j + jb - 1; zlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); if (j + jb <= *n) { /* Apply interchanges to columns J+JB:N. */ i__3 = *n - j - jb + 1; i__4 = j + jb - 1; zlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, & ipiv[1], &c__1); /* Compute block row of U. */ i__3 = *n - j - jb + 1; ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, & c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, 4L, 5L, 12L, 4L); if (j + jb <= *m) { /* Update trailing submatrix. */ i__3 = *m - j - jb + 1; i__4 = *n - j - jb + 1; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, &z__1, &a[j + jb + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, &c_b1, &a[j + jb + (j + jb) * a_dim1], lda, 12L, 12L); } } /* L20: */ } } return 0; /* End of ZGETRF */ } /* zgetrf_ */ /* zlaset.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlaset_(uplo, m, n, alpha, beta, a, lda, uplo_len) char *uplo; integer *m, *n; doublecomplex *alpha, *beta, *a; integer *lda; ftnlen uplo_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ static integer i__, j; extern logical lsame_(); /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLASET initializes a 2-D array A to BETA on the diagonal and */ /* ALPHA on the offdiagonals. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies the part of the matrix A to be set. */ /* = 'U': Upper triangular part is set. The lower triangle */ /* is unchanged. */ /* = 'L': Lower triangular part is set. The upper triangle */ /* is unchanged. */ /* Otherwise: All of the matrix A is set. */ /* M (input) INTEGER */ /* On entry, M specifies the number of rows of A. */ /* N (input) INTEGER */ /* On entry, N specifies the number of columns of A. */ /* ALPHA (input) COMPLEX*16 */ /* All the offdiagonal array elements are set to ALPHA. */ /* BETA (input) COMPLEX*16 */ /* All the diagonal array elements are set to BETA. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; */ /* A(i,i) = BETA , 1 <= i <= min(m,n) */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (lsame_(uplo, "U", 1L, 1L)) { /* Set the diagonal to BETA and the strictly upper triangular */ /* part of the array to ALPHA. */ i__1 = *n; for (j = 2; j <= i__1; ++j) { /* Computing MIN */ i__3 = j - 1; i__2 = min(i__3,*m); for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = alpha->r, a[i__3].i = alpha->i; /* L10: */ } /* L20: */ } i__1 = min(*n,*m); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * a_dim1; a[i__2].r = beta->r, a[i__2].i = beta->i; /* L30: */ } } else if (lsame_(uplo, "L", 1L, 1L)) { /* Set the diagonal to BETA and the strictly lower triangular */ /* part of the array to ALPHA. */ i__1 = min(*m,*n); for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = alpha->r, a[i__3].i = alpha->i; /* L40: */ } /* L50: */ } i__1 = min(*n,*m); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * a_dim1; a[i__2].r = beta->r, a[i__2].i = beta->i; /* L60: */ } } else { /* Set the array to BETA on the diagonal and ALPHA on the */ /* offdiagonal. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = alpha->r, a[i__3].i = alpha->i; /* L70: */ } /* L80: */ } i__1 = min(*m,*n); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * a_dim1; a[i__2].r = beta->r, a[i__2].i = beta->i; /* L90: */ } } return 0; /* End of ZLASET */ } /* zlaset_ */ /* zlatrs.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b36 #undef c_b36 #endif #define c_b36 c_b36 /* Subroutine */ int zlatrs_(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info, uplo_len, trans_len, diag_len, normin_len) char *uplo, *trans, *diag, *normin; integer *n; doublecomplex *a; integer *lda; doublecomplex *x; doublereal *scale, *cnorm; integer *info; ftnlen uplo_len; ftnlen trans_len; ftnlen diag_len; ftnlen normin_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ double d_imag(); void d_cnjg(); /* Local variables */ static integer jinc; static doublereal xbnd; static integer imax; static doublereal tmax; static doublecomplex tjjs; static doublereal xmax, grow; static integer i__, j; extern /* Subroutine */ int dscal_(); extern logical lsame_(); static doublereal tscal; static doublecomplex uscal; static integer jlast; static doublecomplex csumj; extern /* Double Complex */ VOID zdotc_(); static logical upper; extern /* Double Complex */ VOID zdotu_(); extern /* Subroutine */ int zaxpy_(), ztrsv_(), dlabad_(); extern doublereal dlamch_(); static doublereal xj; extern integer idamax_(); extern /* Subroutine */ int xerbla_(), zdscal_(); static doublereal bignum; extern integer izamax_(); extern /* Double Complex */ VOID zladiv_(); static logical notran; static integer jfirst; extern doublereal dzasum_(); static doublereal smlnum; static logical nounit; static doublereal rec, tjj; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* June 30, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLATRS solves one of the triangular systems */ /* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ /* with scaling to prevent overflow. Here A is an upper or lower */ /* triangular matrix, A**T denotes the transpose of A, A**H denotes the */ /* conjugate transpose of A, x and b are n-element vectors, and s is a */ /* scaling factor, usually less than or equal to 1, chosen so that the */ /* components of x will be less than the overflow threshold. If the */ /* unscaled problem will not cause overflow, the Level 2 BLAS routine */ /* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */ /* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Specifies the operation applied to A. */ /* = 'N': Solve A * x = s*b (No transpose) */ /* = 'T': Solve A**T * x = s*b (Transpose) */ /* = 'C': Solve A**H * x = s*b (Conjugate transpose) */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* NORMIN (input) CHARACTER*1 */ /* Specifies whether CNORM has been set or not. */ /* = 'Y': CNORM contains the column norms on entry */ /* = 'N': CNORM is not set on entry. On exit, the norms will */ /* be computed and stored in CNORM. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The triangular matrix A. If UPLO = 'U', the leading n by n */ /* upper triangular part of the array A contains the upper */ /* triangular matrix, and the strictly lower triangular part of */ /* A is not referenced. If UPLO = 'L', the leading n by n lower */ /* triangular part of the array A contains the lower triangular */ /* matrix, and the strictly upper triangular part of A is not */ /* referenced. If DIAG = 'U', the diagonal elements of A are */ /* also not referenced and are assumed to be 1. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max (1,N). */ /* X (input/output) COMPLEX*16 array, dimension (N) */ /* On entry, the right hand side b of the triangular system. */ /* On exit, X is overwritten by the solution vector x. */ /* SCALE (output) DOUBLE PRECISION */ /* The scaling factor s for the triangular system */ /* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ /* If SCALE = 0, the matrix A is singular or badly scaled, and */ /* the vector x is an exact or approximate solution to A*x = 0. */ /* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ /* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ /* contains the norm of the off-diagonal part of the j-th column */ /* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ /* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ /* must be greater than or equal to the 1-norm. */ /* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ /* returns the 1-norm of the offdiagonal part of the j-th column */ /* of A. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -k, the k-th argument had an illegal value */ /* Further Details */ /* ======= ======= */ /* A rough bound on x is computed; if that is less than overflow, ZTRSV */ /* is called, otherwise, specific code is used which checks for possible */ /* overflow or divide-by-zero at every operation. */ /* A columnwise scheme is used for solving A*x = b. The basic algorithm */ /* if A is lower triangular is */ /* x[1:n] := b[1:n] */ /* for j = 1, ..., n */ /* x(j) := x(j) / A(j,j) */ /* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ /* end */ /* Define bounds on the components of x after j iterations of the loop: */ /* M(j) = bound on x[1:j] */ /* G(j) = bound on x[j+1:n] */ /* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ /* Then for iteration j+1 we have */ /* M(j+1) <= G(j) / | A(j+1,j+1) | */ /* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ /* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ /* where CNORM(j+1) is greater than or equal to the infinity-norm of */ /* column j+1 of A, not counting the diagonal. Hence */ /* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ /* 1<=i<=j */ /* and */ /* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ /* 1<=i< j */ /* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */ /* reciprocal of the largest M(j), j=1,..,n, is larger than */ /* max(underflow, 1/overflow). */ /* The bound on x(j) is also used to determine when a step in the */ /* columnwise method can be performed without fear of overflow. If */ /* the computed bound is greater than a large constant, x is scaled to */ /* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ /* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ /* Similarly, a row-wise scheme is used to solve A**T *x = b or */ /* A**H *x = b. The basic algorithm for A upper triangular is */ /* for j = 1, ..., n */ /* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ /* end */ /* We simultaneously compute two bounds */ /* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ /* M(j) = bound on x(i), 1<=i<=j */ /* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ /* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ /* Then the bound on x(j) is */ /* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ /* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ /* 1<=i<=j */ /* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */ /* than max(underflow, 1/overflow). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --x; --cnorm; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); nounit = lsame_(diag, "N", 1L, 1L); /* Test the input parameters. */ if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { *info = -2; } else if (! nounit && ! lsame_(diag, "U", 1L, 1L)) { *info = -3; } else if (! lsame_(normin, "Y", 1L, 1L) && ! lsame_(normin, "N", 1L, 1L)) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZLATRS", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine machine dependent parameters to control overflow. */ smlnum = dlamch_("Safe minimum", 12L); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); smlnum /= dlamch_("Precision", 9L); bignum = 1. / smlnum; *scale = 1.; if (lsame_(normin, "N", 1L, 1L)) { /* Compute the 1-norm of each column, not including the diagona l. */ if (upper) { /* A is upper triangular. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1); /* L10: */ } } else { /* A is lower triangular. */ i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); /* L20: */ } cnorm[*n] = 0.; } } /* Scale the column norms by TSCAL if the maximum element in CNORM is */ /* greater than BIGNUM/2. */ imax = idamax_(n, &cnorm[1], &c__1); tmax = cnorm[imax]; if (tmax <= bignum * .5) { tscal = 1.; } else { tscal = .5 / (smlnum * tmax); dscal_(n, &tscal, &cnorm[1], &c__1); } /* Compute a bound on the computed solution vector to see if the */ /* Level 2 BLAS routine ZTRSV can be used. */ xmax = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = j; d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 = d_imag(&x[j]) / 2., abs(d__2)); xmax = max(d__3,d__4); /* L30: */ } xbnd = xmax; if (notran) { /* Compute the growth in A * x = b. */ if (upper) { jfirst = *n; jlast = 1; jinc = -1; } else { jfirst = 1; jlast = *n; jinc = 1; } if (tscal != 1.) { grow = 0.; goto L60; } if (nounit) { /* A is non-unit triangular. */ /* Compute GROW = 1/G(j) and XBND = 1/M(j). */ /* Initially, G(0) = max{x(i), i=1,...,n}. */ grow = .5 / max(xbnd,smlnum); xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L60; } i__3 = j + j * a_dim1; tjjs.r = a[i__3].r, tjjs.i = a[i__3].i; tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj >= smlnum) { /* M(j) = G(j-1) / abs(A(j,j)) */ /* Computing MIN */ d__1 = xbnd, d__2 = min(1.,tjj) * grow; xbnd = min(d__1,d__2); } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.; } if (tjj + cnorm[j] >= smlnum) { /* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j, j)) ) */ grow *= tjj / (tjj + cnorm[j]); } else { /* G(j) could overflow, set GROW to 0. */ grow = 0.; } /* L40: */ } grow = xbnd; } else { /* A is unit triangular. */ /* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,... ,n}. */ /* Computing MIN */ d__1 = 1., d__2 = .5 / max(xbnd,smlnum); grow = min(d__1,d__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L60; } /* G(j) = G(j-1)*( 1 + CNORM(j) ) */ grow *= 1. / (cnorm[j] + 1.); /* L50: */ } } L60: ; } else { /* Compute the growth in A**T * x = b or A**H * x = b. */ if (upper) { jfirst = 1; jlast = *n; jinc = 1; } else { jfirst = *n; jlast = 1; jinc = -1; } if (tscal != 1.) { grow = 0.; goto L90; } if (nounit) { /* A is non-unit triangular. */ /* Compute GROW = 1/G(j) and XBND = 1/M(j). */ /* Initially, M(0) = max{x(i), i=1,...,n}. */ grow = .5 / max(xbnd,smlnum); xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L90; } /* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ xj = cnorm[j] + 1.; /* Computing MIN */ d__1 = grow, d__2 = xbnd / xj; grow = min(d__1,d__2); i__3 = j + j * a_dim1; tjjs.r = a[i__3].r, tjjs.i = a[i__3].i; tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj >= smlnum) { /* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A( j,j)) */ if (xj > tjj) { xbnd *= tjj / xj; } } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.; } /* L70: */ } grow = min(grow,xbnd); } else { /* A is unit triangular. */ /* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,... ,n}. */ /* Computing MIN */ d__1 = 1., d__2 = .5 / max(xbnd,smlnum); grow = min(d__1,d__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Exit the loop if the growth factor is too smal l. */ if (grow <= smlnum) { goto L90; } /* G(j) = ( 1 + CNORM(j) )*G(j-1) */ xj = cnorm[j] + 1.; grow /= xj; /* L80: */ } } L90: ; } if (grow * tscal > smlnum) { /* Use the Level 2 BLAS solve if the reciprocal of the bound on */ /* elements of X is not too small. */ ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, 1L, 1L, 1L); } else { /* Use a Level 1 BLAS solve, scaling intermediate results. */ if (xmax > bignum * .5) { /* Scale X so that its components are less than or equal to */ /* BIGNUM in absolute value. */ *scale = bignum * .5 / xmax; zdscal_(n, scale, &x[1], &c__1); xmax = bignum; } else { xmax *= 2.; } if (notran) { /* Solve A * x = b */ i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Compute x(j) = b(j) / A(j,j), scaling x if nec essary. */ i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); if (nounit) { i__3 = j + j * a_dim1; z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L110; } } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale x by 1/b(j). */ rec = 1. / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs( A(j,j))*BIGNUM */ /* to avoid overflow when dividi ng by A(j,j). */ rec = tjj * bignum / xj; if (cnorm[j] > 1.) { /* Scale by 1/CNORM(j) to avoid overflow when */ /* multiplying x(j) times column j. */ rec /= cnorm[j]; } zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0, and compute a solution to A*x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0., x[i__4].i = 0.; /* L100: */ } i__3 = j; x[i__3].r = 1., x[i__3].i = 0.; xj = 1.; *scale = 0.; xmax = 0.; } L110: /* Scale x if necessary to avoid overflow when ad ding a */ /* multiple of column j of A. */ if (xj > 1.) { rec = 1. / xj; if (cnorm[j] > (bignum - xmax) * rec) { /* Scale x by 1/(2*abs(x(j))). */ rec *= .5; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } else if (xj * cnorm[j] > bignum - xmax) { /* Scale x by 1/2. */ zdscal_(n, &c_b36, &x[1], &c__1); *scale *= .5; } if (upper) { if (j > 1) { /* Compute the update */ /* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ i__3 = j - 1; i__4 = j; z__2.r = -x[i__4].r, z__2.i = -x[i__4].i; z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); i__3 = j - 1; i__ = izamax_(&i__3, &x[1], &c__1); i__3 = i__; xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2)); } } else { if (j < *n) { /* Compute the update */ /* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ i__3 = *n - j; i__4 = j; z__2.r = -x[i__4].r, z__2.i = -x[i__4].i; z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); i__3 = *n - j; i__ = j + izamax_(&i__3, &x[j + 1], &c__1); i__3 = i__; xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2)); } } /* L120: */ } } else if (lsame_(trans, "T", 1L, 1L)) { /* Solve A**T * x = b */ i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). */ /* k<>j */ i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); uscal.r = tscal, uscal.i = 0.; rec = 1. / max(xmax,1.); if (cnorm[j] > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2 *XMAX). */ rec *= .5; if (nounit) { i__3 = j + j * a_dim1; z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3] .i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > 1.) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. */ /* Computing MIN */ d__1 = 1., d__2 = rec * tjj; rec = min(d__1,d__2); zladiv_(&z__1, &uscal, &tjjs); uscal.r = z__1.r, uscal.i = z__1.i; } if (rec < 1.) { zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0., csumj.i = 0.; if (uscal.r == 1. && uscal.i == 0.) { /* If the scaling needed for A in the dot product is 1, */ /* call ZDOTU to perform the dot product. */ if (upper) { i__3 = j - 1; zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } else if (j < *n) { i__3 = *n - j; zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { i__3 = j - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + j * a_dim1; z__3.r = a[i__4].r * uscal.r - a[i__4].i * uscal.i, z__3.i = a[i__4].r * uscal.i + a[ i__4].i * uscal.r; i__5 = i__; z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L130: */ } } else if (j < *n) { i__3 = *n; for (i__ = j + 1; i__ <= i__3; ++i__) { i__4 = i__ + j * a_dim1; z__3.r = a[i__4].r * uscal.r - a[i__4].i * uscal.i, z__3.i = a[i__4].r * uscal.i + a[ i__4].i * uscal.r; i__5 = i__; z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L140: */ } } } z__1.r = tscal, z__1.i = 0.; if (uscal.r == z__1.r && uscal.i == z__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j, j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ i__3 = j; i__4 = j; z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); if (nounit) { i__3 = j + j * a_dim1; z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3] .i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L160; } } /* Compute x(j) = x(j) / A(j,j), scalin g if necessary. */ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale X by 1/ab s(x(j)). */ rec = 1. / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j) ))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0 and compute a solut ion to A**T *x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0., x[i__4].i = 0.; /* L150: */ } i__3 = j; x[i__3].r = 1., x[i__3].i = 0.; *scale = 0.; xmax = 0.; } L160: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ i f the dot */ /* product has already been divided by 1/A (j,j). */ i__3 = j; zladiv_(&z__2, &x[j], &tjjs); z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; } /* Computing MAX */ i__3 = j; d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); xmax = max(d__3,d__4); /* L170: */ } } else { /* Solve A**H * x = b */ i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). */ /* k<>j */ i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); uscal.r = tscal, uscal.i = 0.; rec = 1. / max(xmax,1.); if (cnorm[j] > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2 *XMAX). */ rec *= .5; if (nounit) { d_cnjg(&z__2, &a[j + j * a_dim1]); z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; } tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > 1.) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. */ /* Computing MIN */ d__1 = 1., d__2 = rec * tjj; rec = min(d__1,d__2); zladiv_(&z__1, &uscal, &tjjs); uscal.r = z__1.r, uscal.i = z__1.i; } if (rec < 1.) { zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0., csumj.i = 0.; if (uscal.r == 1. && uscal.i == 0.) { /* If the scaling needed for A in the dot product is 1, */ /* call ZDOTC to perform the dot product. */ if (upper) { i__3 = j - 1; zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } else if (j < *n) { i__3 = *n - j; zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); csumj.r = z__1.r, csumj.i = z__1.i; } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { i__3 = j - 1; for (i__ = 1; i__ <= i__3; ++i__) { d_cnjg(&z__4, &a[i__ + j * a_dim1]); z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; i__4 = i__; z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L180: */ } } else if (j < *n) { i__3 = *n; for (i__ = j + 1; i__ <= i__3; ++i__) { d_cnjg(&z__4, &a[i__ + j * a_dim1]); z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; i__4 = i__; z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + z__2.i; csumj.r = z__1.r, csumj.i = z__1.i; /* L190: */ } } } z__1.r = tscal, z__1.i = 0.; if (uscal.r == z__1.r && uscal.i == z__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j, j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ i__3 = j; i__4 = j; z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; i__3 = j; xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2)); if (nounit) { d_cnjg(&z__2, &a[j + j * a_dim1]); z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; tjjs.r = z__1.r, tjjs.i = z__1.i; } else { tjjs.r = tscal, tjjs.i = 0.; if (tscal == 1.) { goto L210; } } /* Compute x(j) = x(j) / A(j,j), scalin g if necessary. */ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.) { if (xj > tjj * bignum) { /* Scale X by 1/ab s(x(j)). */ rec = 1. / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else if (tjj > 0.) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j) ))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; zdscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; zladiv_(&z__1, &x[j], &tjjs); x[i__3].r = z__1.r, x[i__3].i = z__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0 and compute a solut ion to A**H *x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0., x[i__4].i = 0.; /* L200: */ } i__3 = j; x[i__3].r = 1., x[i__3].i = 0.; *scale = 0.; xmax = 0.; } L210: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ i f the dot */ /* product has already been divided by 1/A (j,j). */ i__3 = j; zladiv_(&z__2, &x[j], &tjjs); z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; x[i__3].r = z__1.r, x[i__3].i = z__1.i; } /* Computing MAX */ i__3 = j; d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); xmax = max(d__3,d__4); /* L220: */ } } *scale /= tscal; } /* Scale the column norms by 1/TSCAL for return. */ if (tscal != 1.) { d__1 = 1. / tscal; dscal_(n, &d__1, &cnorm[1], &c__1); } return 0; /* End of ZLATRS */ } /* zlatrs_ */ /* zlarfx.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1 #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int zlarfx_(side, m, n, v, tau, c__, ldc, work, side_len) char *side; integer *m, *n; doublecomplex *v, *tau, *c__; integer *ldc; doublecomplex *work; ftnlen side_len; { /* System generated locals */ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11; doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10, z__11, z__12, z__13, z__14, z__15, z__16, z__17, z__18, z__19; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer j; extern logical lsame_(); extern /* Subroutine */ int zgerc_(), zgemv_(); static doublecomplex t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, v8, v9, t10, v10, sum; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLARFX applies a complex elementary reflector H to a complex 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 complex scalar and v is a complex vector. */ /* If tau = 0, then H is taken to be the unit matrix */ /* This version uses inline code if H has order < 11. */ /* 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. */ /* V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L' */ /* or (N) if SIDE = 'R' */ /* The vector v in the representation of H. */ /* TAU (input) COMPLEX*16 */ /* The value tau in the representation of H. */ /* C (input/output) COMPLEX*16 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. LDA >= max(1,M). */ /* WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L' */ /* or (M) if SIDE = 'R' */ /* WORK is not referenced if H has order < 11. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --v; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ if (tau->r == 0. && tau->i == 0.) { return 0; } if (lsame_(side, "L", 1L, 1L)) { /* Form H * C, where H has order m. */ switch ((int)*m) { case 1: goto L10; case 2: goto L30; case 3: goto L50; #ifndef BIGROUTINEHACK case 4: goto L70; case 5: goto L90; case 6: goto L110; case 7: goto L130; case 8: goto L150; case 9: goto L170; case 10: goto L190; #endif /* BIGROUTINEHACK */ } /* Code for general M */ /* w := C'*v */ zgemv_("Conjugate transpose", m, n, &c_b2, &c__[c_offset], ldc, &v[1], &c__1, &c_b1, &work[1], &c__1, 19L); /* C := C - tau * v * w' */ z__1.r = -tau->r, z__1.i = -tau->i; zgerc_(m, n, &z__1, &v[1], &c__1, &work[1], &c__1, &c__[c_offset], ldc); goto L410; L10: /* Special code for 1 x 1 Householder */ z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i + tau->i * v[1].r; d_cnjg(&z__4, &v[1]); z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + z__3.i * z__4.r; z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; t1.r = z__1.r, t1.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r * c__[i__3].i + t1.i * c__[i__3].r; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L20: */ } goto L410; L30: /* Special code for 2 x 2 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L40: */ } goto L410; L50: /* Special code for 3 x 3 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; i__4 = j * c_dim1 + 3; z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L60: */ } goto L410; #ifndef BIGROUTINEHACK L70: /* Special code for 4 x 4 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i; i__4 = j * c_dim1 + 3; z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i; i__5 = j * c_dim1 + 4; z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L80: */ } goto L410; L90: /* Special code for 5 x 5 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; d_cnjg(&z__1, &v[5]); v5.r = z__1.r, v5.i = z__1.i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i; i__4 = j * c_dim1 + 3; z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i; i__5 = j * c_dim1 + 4; z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i; i__6 = j * c_dim1 + 5; z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 5; i__3 = j * c_dim1 + 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L100: */ } goto L410; L110: /* Special code for 6 x 6 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; d_cnjg(&z__1, &v[5]); v5.r = z__1.r, v5.i = z__1.i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; d_cnjg(&z__1, &v[6]); v6.r = z__1.r, v6.i = z__1.i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i; i__4 = j * c_dim1 + 3; z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i; i__5 = j * c_dim1 + 4; z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i; i__6 = j * c_dim1 + 5; z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i; i__7 = j * c_dim1 + 6; z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 5; i__3 = j * c_dim1 + 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 6; i__3 = j * c_dim1 + 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L120: */ } goto L410; L130: /* Special code for 7 x 7 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; d_cnjg(&z__1, &v[5]); v5.r = z__1.r, v5.i = z__1.i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; d_cnjg(&z__1, &v[6]); v6.r = z__1.r, v6.i = z__1.i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; d_cnjg(&z__1, &v[7]); v7.r = z__1.r, v7.i = z__1.i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i; i__4 = j * c_dim1 + 3; z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i; i__5 = j * c_dim1 + 4; z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i; i__6 = j * c_dim1 + 5; z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i; i__7 = j * c_dim1 + 6; z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i; i__8 = j * c_dim1 + 7; z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 5; i__3 = j * c_dim1 + 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 6; i__3 = j * c_dim1 + 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 7; i__3 = j * c_dim1 + 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L140: */ } goto L410; L150: /* Special code for 8 x 8 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; d_cnjg(&z__1, &v[5]); v5.r = z__1.r, v5.i = z__1.i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; d_cnjg(&z__1, &v[6]); v6.r = z__1.r, v6.i = z__1.i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; d_cnjg(&z__1, &v[7]); v7.r = z__1.r, v7.i = z__1.i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; d_cnjg(&z__1, &v[8]); v8.r = z__1.r, v8.i = z__1.i; d_cnjg(&z__2, &v8); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t8.r = z__1.r, t8.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i; i__4 = j * c_dim1 + 3; z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i; i__5 = j * c_dim1 + 4; z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i; i__6 = j * c_dim1 + 5; z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i; i__7 = j * c_dim1 + 6; z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i; i__8 = j * c_dim1 + 7; z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i; i__9 = j * c_dim1 + 8; z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r * c__[i__9].i + v8.i * c__[i__9].r; z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 5; i__3 = j * c_dim1 + 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 6; i__3 = j * c_dim1 + 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 7; i__3 = j * c_dim1 + 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 8; i__3 = j * c_dim1 + 8; z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + sum.i * t8.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L160: */ } goto L410; L170: /* Special code for 9 x 9 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; d_cnjg(&z__1, &v[5]); v5.r = z__1.r, v5.i = z__1.i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; d_cnjg(&z__1, &v[6]); v6.r = z__1.r, v6.i = z__1.i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; d_cnjg(&z__1, &v[7]); v7.r = z__1.r, v7.i = z__1.i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; d_cnjg(&z__1, &v[8]); v8.r = z__1.r, v8.i = z__1.i; d_cnjg(&z__2, &v8); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t8.r = z__1.r, t8.i = z__1.i; d_cnjg(&z__1, &v[9]); v9.r = z__1.r, v9.i = z__1.i; d_cnjg(&z__2, &v9); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t9.r = z__1.r, t9.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i; i__4 = j * c_dim1 + 3; z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i; i__5 = j * c_dim1 + 4; z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i; i__6 = j * c_dim1 + 5; z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i; i__7 = j * c_dim1 + 6; z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i; i__8 = j * c_dim1 + 7; z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i; i__9 = j * c_dim1 + 8; z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r * c__[i__9].i + v8.i * c__[i__9].r; z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i; i__10 = j * c_dim1 + 9; z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i = v9.r * c__[i__10].i + v9.i * c__[i__10].r; z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 5; i__3 = j * c_dim1 + 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 6; i__3 = j * c_dim1 + 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 7; i__3 = j * c_dim1 + 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 8; i__3 = j * c_dim1 + 8; z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + sum.i * t8.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 9; i__3 = j * c_dim1 + 9; z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + sum.i * t9.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L180: */ } goto L410; L190: /* Special code for 10 x 10 Householder */ d_cnjg(&z__1, &v[1]); v1.r = z__1.r, v1.i = z__1.i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; d_cnjg(&z__1, &v[2]); v2.r = z__1.r, v2.i = z__1.i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; d_cnjg(&z__1, &v[3]); v3.r = z__1.r, v3.i = z__1.i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; d_cnjg(&z__1, &v[4]); v4.r = z__1.r, v4.i = z__1.i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; d_cnjg(&z__1, &v[5]); v5.r = z__1.r, v5.i = z__1.i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; d_cnjg(&z__1, &v[6]); v6.r = z__1.r, v6.i = z__1.i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; d_cnjg(&z__1, &v[7]); v7.r = z__1.r, v7.i = z__1.i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; d_cnjg(&z__1, &v[8]); v8.r = z__1.r, v8.i = z__1.i; d_cnjg(&z__2, &v8); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t8.r = z__1.r, t8.i = z__1.i; d_cnjg(&z__1, &v[9]); v9.r = z__1.r, v9.i = z__1.i; d_cnjg(&z__2, &v9); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t9.r = z__1.r, t9.i = z__1.i; d_cnjg(&z__1, &v[10]); v10.r = z__1.r, v10.i = z__1.i; d_cnjg(&z__2, &v10); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t10.r = z__1.r, t10.i = z__1.i; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j * c_dim1 + 1; z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j * c_dim1 + 2; z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i; i__4 = j * c_dim1 + 3; z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i; i__5 = j * c_dim1 + 4; z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i; i__6 = j * c_dim1 + 5; z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i; i__7 = j * c_dim1 + 6; z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i; i__8 = j * c_dim1 + 7; z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i; i__9 = j * c_dim1 + 8; z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r * c__[i__9].i + v8.i * c__[i__9].r; z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i; i__10 = j * c_dim1 + 9; z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i = v9.r * c__[i__10].i + v9.i * c__[i__10].r; z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i; i__11 = j * c_dim1 + 10; z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i = v10.r * c__[i__11].i + v10.i * c__[i__11].r; z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j * c_dim1 + 1; i__3 = j * c_dim1 + 1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 2; i__3 = j * c_dim1 + 2; z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 3; i__3 = j * c_dim1 + 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 4; i__3 = j * c_dim1 + 4; z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 5; i__3 = j * c_dim1 + 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 6; i__3 = j * c_dim1 + 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 7; i__3 = j * c_dim1 + 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 8; i__3 = j * c_dim1 + 8; z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + sum.i * t8.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 9; i__3 = j * c_dim1 + 9; z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + sum.i * t9.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j * c_dim1 + 10; i__3 = j * c_dim1 + 10; z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i + sum.i * t10.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L200: */ } #endif /* BIGROUTINEHACK */ goto L410; } else { /* Form C * H, where H has order n. */ switch ((int)*n) { case 1: goto L210; case 2: goto L230; case 3: goto L250; #ifndef BIGROUTINEHACK case 4: goto L270; case 5: goto L290; case 6: goto L310; case 7: goto L330; case 8: goto L350; case 9: goto L370; case 10: goto L390; #endif /* BIGROUTINEHACK */ } /* Code for general N */ /* w := C * v */ zgemv_("No transpose", m, n, &c_b2, &c__[c_offset], ldc, &v[1], &c__1, &c_b1, &work[1], &c__1, 12L); /* C := C - tau * w * v' */ z__1.r = -tau->r, z__1.i = -tau->i; zgerc_(m, n, &z__1, &work[1], &c__1, &v[1], &c__1, &c__[c_offset], ldc); goto L410; L210: /* Special code for 1 x 1 Householder */ z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i + tau->i * v[1].r; d_cnjg(&z__4, &v[1]); z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + z__3.i * z__4.r; z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; t1.r = z__1.r, t1.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; i__3 = j + c_dim1; z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r * c__[i__3].i + t1.i * c__[i__3].r; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L220: */ } goto L410; L230: /* Special code for 2 x 2 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L240: */ } goto L410; L250: /* Special code for 3 x 3 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; i__4 = j + c_dim1 * 3; z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L260: */ } goto L410; #ifndef BIGROUTINEHACK L270: /* Special code for 4 x 4 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i; i__4 = j + c_dim1 * 3; z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i; i__5 = j + (c_dim1 << 2); z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L280: */ } goto L410; L290: /* Special code for 5 x 5 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; v5.r = v[5].r, v5.i = v[5].i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i; i__4 = j + c_dim1 * 3; z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i; i__5 = j + (c_dim1 << 2); z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i; i__6 = j + c_dim1 * 5; z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 5; i__3 = j + c_dim1 * 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L300: */ } goto L410; L310: /* Special code for 6 x 6 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; v5.r = v[5].r, v5.i = v[5].i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; v6.r = v[6].r, v6.i = v[6].i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i; i__4 = j + c_dim1 * 3; z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i; i__5 = j + (c_dim1 << 2); z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i; i__6 = j + c_dim1 * 5; z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i; i__7 = j + c_dim1 * 6; z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 5; i__3 = j + c_dim1 * 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 6; i__3 = j + c_dim1 * 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L320: */ } goto L410; L330: /* Special code for 7 x 7 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; v5.r = v[5].r, v5.i = v[5].i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; v6.r = v[6].r, v6.i = v[6].i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; v7.r = v[7].r, v7.i = v[7].i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i; i__4 = j + c_dim1 * 3; z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i; i__5 = j + (c_dim1 << 2); z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i; i__6 = j + c_dim1 * 5; z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i; i__7 = j + c_dim1 * 6; z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i; i__8 = j + c_dim1 * 7; z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 5; i__3 = j + c_dim1 * 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 6; i__3 = j + c_dim1 * 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 7; i__3 = j + c_dim1 * 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L340: */ } goto L410; L350: /* Special code for 8 x 8 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; v5.r = v[5].r, v5.i = v[5].i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; v6.r = v[6].r, v6.i = v[6].i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; v7.r = v[7].r, v7.i = v[7].i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; v8.r = v[8].r, v8.i = v[8].i; d_cnjg(&z__2, &v8); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t8.r = z__1.r, t8.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i; i__4 = j + c_dim1 * 3; z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i; i__5 = j + (c_dim1 << 2); z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i; i__6 = j + c_dim1 * 5; z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i; i__7 = j + c_dim1 * 6; z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i; i__8 = j + c_dim1 * 7; z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i; i__9 = j + (c_dim1 << 3); z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r * c__[i__9].i + v8.i * c__[i__9].r; z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 5; i__3 = j + c_dim1 * 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 6; i__3 = j + c_dim1 * 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 7; i__3 = j + c_dim1 * 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 3); i__3 = j + (c_dim1 << 3); z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + sum.i * t8.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L360: */ } goto L410; L370: /* Special code for 9 x 9 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; v5.r = v[5].r, v5.i = v[5].i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; v6.r = v[6].r, v6.i = v[6].i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; v7.r = v[7].r, v7.i = v[7].i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; v8.r = v[8].r, v8.i = v[8].i; d_cnjg(&z__2, &v8); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t8.r = z__1.r, t8.i = z__1.i; v9.r = v[9].r, v9.i = v[9].i; d_cnjg(&z__2, &v9); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t9.r = z__1.r, t9.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i; i__4 = j + c_dim1 * 3; z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i; i__5 = j + (c_dim1 << 2); z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i; i__6 = j + c_dim1 * 5; z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i; i__7 = j + c_dim1 * 6; z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i; i__8 = j + c_dim1 * 7; z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i; i__9 = j + (c_dim1 << 3); z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r * c__[i__9].i + v8.i * c__[i__9].r; z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i; i__10 = j + c_dim1 * 9; z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i = v9.r * c__[i__10].i + v9.i * c__[i__10].r; z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 5; i__3 = j + c_dim1 * 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 6; i__3 = j + c_dim1 * 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 7; i__3 = j + c_dim1 * 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 3); i__3 = j + (c_dim1 << 3); z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + sum.i * t8.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 9; i__3 = j + c_dim1 * 9; z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + sum.i * t9.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L380: */ } goto L410; L390: /* Special code for 10 x 10 Householder */ v1.r = v[1].r, v1.i = v[1].i; d_cnjg(&z__2, &v1); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t1.r = z__1.r, t1.i = z__1.i; v2.r = v[2].r, v2.i = v[2].i; d_cnjg(&z__2, &v2); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t2.r = z__1.r, t2.i = z__1.i; v3.r = v[3].r, v3.i = v[3].i; d_cnjg(&z__2, &v3); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t3.r = z__1.r, t3.i = z__1.i; v4.r = v[4].r, v4.i = v[4].i; d_cnjg(&z__2, &v4); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t4.r = z__1.r, t4.i = z__1.i; v5.r = v[5].r, v5.i = v[5].i; d_cnjg(&z__2, &v5); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t5.r = z__1.r, t5.i = z__1.i; v6.r = v[6].r, v6.i = v[6].i; d_cnjg(&z__2, &v6); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t6.r = z__1.r, t6.i = z__1.i; v7.r = v[7].r, v7.i = v[7].i; d_cnjg(&z__2, &v7); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t7.r = z__1.r, t7.i = z__1.i; v8.r = v[8].r, v8.i = v[8].i; d_cnjg(&z__2, &v8); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t8.r = z__1.r, t8.i = z__1.i; v9.r = v[9].r, v9.i = v[9].i; d_cnjg(&z__2, &v9); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t9.r = z__1.r, t9.i = z__1.i; v10.r = v[10].r, v10.i = v[10].i; d_cnjg(&z__2, &v10); z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + tau->i * z__2.r; t10.r = z__1.r, t10.i = z__1.i; i__1 = *m; for (j = 1; j <= i__1; ++j) { i__2 = j + c_dim1; z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r * c__[i__2].i + v1.i * c__[i__2].r; i__3 = j + (c_dim1 << 1); z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r * c__[i__3].i + v2.i * c__[i__3].r; z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i; i__4 = j + c_dim1 * 3; z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r * c__[i__4].i + v3.i * c__[i__4].r; z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i; i__5 = j + (c_dim1 << 2); z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r * c__[i__5].i + v4.i * c__[i__5].r; z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i; i__6 = j + c_dim1 * 5; z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r * c__[i__6].i + v5.i * c__[i__6].r; z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i; i__7 = j + c_dim1 * 6; z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r * c__[i__7].i + v6.i * c__[i__7].r; z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i; i__8 = j + c_dim1 * 7; z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r * c__[i__8].i + v7.i * c__[i__8].r; z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i; i__9 = j + (c_dim1 << 3); z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r * c__[i__9].i + v8.i * c__[i__9].r; z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i; i__10 = j + c_dim1 * 9; z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i = v9.r * c__[i__10].i + v9.i * c__[i__10].r; z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i; i__11 = j + c_dim1 * 10; z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i = v10.r * c__[i__11].i + v10.i * c__[i__11].r; z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i; sum.r = z__1.r, sum.i = z__1.i; i__2 = j + c_dim1; i__3 = j + c_dim1; z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + sum.i * t1.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 1); i__3 = j + (c_dim1 << 1); z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + sum.i * t2.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 3; i__3 = j + c_dim1 * 3; z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + sum.i * t3.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 2); i__3 = j + (c_dim1 << 2); z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + sum.i * t4.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 5; i__3 = j + c_dim1 * 5; z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + sum.i * t5.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 6; i__3 = j + c_dim1 * 6; z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + sum.i * t6.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 7; i__3 = j + c_dim1 * 7; z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + sum.i * t7.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + (c_dim1 << 3); i__3 = j + (c_dim1 << 3); z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + sum.i * t8.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 9; i__3 = j + c_dim1 * 9; z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + sum.i * t9.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; i__2 = j + c_dim1 * 10; i__3 = j + c_dim1 * 10; z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i + sum.i * t10.r; z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; /* L400: */ } goto L410; #endif /* BIGROUTINEHACK */ } L410: return 0; /* End of ZLARFX */ } /* zlarfx_ */ /* zlacgv.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlacgv_(n, x, incx) integer *n; doublecomplex *x; integer *incx; { /* System generated locals */ integer i__1, i__2; doublecomplex z__1; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer ioff, i__; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLACGV conjugates a complex vector of length N. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The length of the vector X. N >= 0. */ /* X (input/output) COMPLEX*16 array, dimension */ /* (1+(N-1)*abs(INCX)) */ /* On entry, the vector of length N to be conjugated. */ /* On exit, X is overwritten with conjg(X). */ /* INCX (input) INTEGER */ /* The spacing between successive elements of X. */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --x; /* Function Body */ if (*incx == 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; d_cnjg(&z__1, &x[i__]); x[i__2].r = z__1.r, x[i__2].i = z__1.i; /* L10: */ } } else { ioff = 1; if (*incx < 0) { ioff = 1 - (*n - 1) * *incx; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = ioff; d_cnjg(&z__1, &x[ioff]); x[i__2].r = z__1.r, x[i__2].i = z__1.i; ioff += *incx; /* L20: */ } } return 0; /* End of ZLACGV */ } /* zlacgv_ */ /* zunglq.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zunglq_(m, n, k, a, lda, tau, work, lwork, info) integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; { /* 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; extern /* Subroutine */ int zungl2_(); static integer ki, kk, nx; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(); static integer ldwork; extern /* Subroutine */ int zlarft_(); static integer iws; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, */ /* which is defined as the first M rows of a product of K elementary */ /* reflectors of order N */ /* Q = H(k)' . . . H(2)' H(1)' */ /* as returned by ZGELQF. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix Q. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q. N >= M. */ /* K (input) INTEGER */ /* The number of elementary reflectors whose product defines the */ /* matrix Q. M >= K >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the i-th row must contain the vector which defines */ /* the elementary reflector H(i), for i = 1,2,...,k, as returned */ /* by ZGELQF in the first k rows of its array argument A. */ /* On exit, the M-by-N matrix Q. */ /* LDA (input) INTEGER */ /* The first dimension of the array A. LDA >= max(1,M). */ /* TAU (input) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGELQF. */ /* 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,M). */ /* For optimum performance LWORK >= M*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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < *m) { *info = -2; } else if (*k < 0 || *k > *m) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else if (*lwork < max(1,*m)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGLQ", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m <= 0) { work[1].r = 1., work[1].i = 0.; return 0; } /* Determine the block size. */ nb = ilaenv_(&c__1, "ZUNGLQ", " ", m, n, k, &c_n1, 6L, 1L); nbmin = 2; nx = 0; iws = *m; 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, "ZUNGLQ", " ", 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 = *m; 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, "ZUNGLQ", " ", 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 rows 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(kk+1:m,1:kk) to zero. */ i__1 = kk; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = kk + 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 < *m) { i__1 = *m - kk; i__2 = *n - kk; i__3 = *k - kk; zungl2_(&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 <= *m) { /* Form the triangular factor of the block reflec tor */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ i__2 = *n - i__ + 1; zlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L); /* Apply H' to A(i+ib:m,i:n) from the right */ i__2 = *m - i__ - ib + 1; i__3 = *n - i__ + 1; zlarfb_("Right", "Conjugate transpose", "Forward", "Rowwise", &i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ 1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ ib + 1], &ldwork, 5L, 19L, 7L, 7L); } /* Apply H' to columns i:n of current block */ i__2 = *n - i__ + 1; zungl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & work[1], &iinfo); /* Set columns 1:i-1 of current block to zero */ i__2 = i__ - 1; for (j = 1; j <= i__2; ++j) { i__3 = i__ + ib - 1; for (l = i__; 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 ZUNGLQ */ } /* zunglq_ */ /* zlascl.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlascl_(type__, kl, ku, cfrom, cto, m, n, a, lda, info, type_len) char *type__; integer *kl, *ku; doublereal *cfrom, *cto; integer *m, *n; doublecomplex *a; integer *lda, *info; ftnlen type_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1; /* Local variables */ static logical done; static doublereal ctoc; static integer i__, j; extern logical lsame_(); static integer itype, k1, k2, k3, k4; static doublereal cfrom1; extern doublereal dlamch_(); static doublereal cfromc; extern /* Subroutine */ int xerbla_(); static doublereal bignum, smlnum, mul, cto1; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* February 29, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLASCL multiplies the M by N complex matrix A by the real scalar */ /* CTO/CFROM. This is done without over/underflow as long as the final */ /* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */ /* A may be full, upper triangular, lower triangular, upper Hessenberg, */ /* or banded. */ /* Arguments */ /* ========= */ /* TYPE (input) CHARACTER*1 */ /* TYPE indices the storage type of the input matrix. */ /* = 'G': A is a full matrix. */ /* = 'L': A is a lower triangular matrix. */ /* = 'U': A is an upper triangular matrix. */ /* = 'H': A is an upper Hessenberg matrix. */ /* = 'B': A is a symmetric band matrix with lower bandwidth KL */ /* and upper bandwidth KU and with the only the lower */ /* half stored. */ /* = 'Q': A is a symmetric band matrix with lower bandwidth KL */ /* and upper bandwidth KU and with the only the upper */ /* half stored. */ /* = 'Z': A is a band matrix with lower bandwidth KL and upper */ /* bandwidth KU. */ /* KL (input) INTEGER */ /* The lower bandwidth of A. Referenced only if TYPE = 'B', */ /* 'Q' or 'Z'. */ /* KU (input) INTEGER */ /* The upper bandwidth of A. Referenced only if TYPE = 'B', */ /* 'Q' or 'Z'. */ /* CFROM (input) DOUBLE PRECISION */ /* CTO (input) DOUBLE PRECISION */ /* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */ /* without over/underflow if the final result CTO*A(I,J)/CFROM */ /* can be represented without over/underflow. CFROM must be */ /* nonzero. */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,M) */ /* The matrix to be multiplied by CTO/CFROM. See TYPE for the */ /* storage type. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* INFO (output) INTEGER */ /* 0 - successful exit */ /* <0 - if INFO = -i, the i-th argument had an illegal value. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ *info = 0; if (lsame_(type__, "G", 1L, 1L)) { itype = 0; } else if (lsame_(type__, "L", 1L, 1L)) { itype = 1; } else if (lsame_(type__, "U", 1L, 1L)) { itype = 2; } else if (lsame_(type__, "H", 1L, 1L)) { itype = 3; } else if (lsame_(type__, "B", 1L, 1L)) { itype = 4; } else if (lsame_(type__, "Q", 1L, 1L)) { itype = 5; } else if (lsame_(type__, "Z", 1L, 1L)) { itype = 6; } else { itype = -1; } if (itype == -1) { *info = -1; } else if (*cfrom == 0.) { *info = -4; } else if (*m < 0) { *info = -6; } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { *info = -7; } else if (itype <= 3 && *lda < max(1,*m)) { *info = -9; } else if (itype >= 4) { /* Computing MAX */ i__1 = *m - 1; if (*kl < 0 || *kl > max(i__1,0)) { *info = -2; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = *n - 1; if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && *kl != *ku) { *info = -3; } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { *info = -9; } } } if (*info != 0) { i__1 = -(*info); xerbla_("ZLASCL", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n == 0 || *m == 0) { return 0; } /* Get machine parameters */ smlnum = dlamch_("S", 1L); bignum = 1. / smlnum; cfromc = *cfrom; ctoc = *cto; L10: cfrom1 = cfromc * smlnum; cto1 = ctoc / bignum; if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { mul = smlnum; done = FALSE_; cfromc = cfrom1; } else if (abs(cto1) > abs(cfromc)) { mul = bignum; done = FALSE_; ctoc = cto1; } else { mul = ctoc / cfromc; done = TRUE_; } if (itype == 0) { /* Full matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L20: */ } /* L30: */ } } else if (itype == 1) { /* Lower triangular matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L40: */ } /* L50: */ } } else if (itype == 2) { /* Upper triangular matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(j,*m); for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L60: */ } /* L70: */ } } else if (itype == 3) { /* Upper Hessenberg matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = j + 1; i__2 = min(i__3,*m); for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L80: */ } /* L90: */ } } else if (itype == 4) { /* Lower half of a symmetric band matrix */ k3 = *kl + 1; k4 = *n + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = k3, i__4 = k4 - j; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L100: */ } /* L110: */ } } else if (itype == 5) { /* Upper half of a symmetric band matrix */ k1 = *ku + 2; k3 = *ku + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = k1 - j; i__3 = k3; for (i__ = max(i__2,1); i__ <= i__3; ++i__) { i__2 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L120: */ } /* L130: */ } } else if (itype == 6) { /* Band matrix */ k1 = *kl + *ku + 2; k2 = *kl + 1; k3 = (*kl << 1) + *ku + 1; k4 = *kl + *ku + 1 + *m; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__3 = k1 - j; /* Computing MIN */ i__4 = k3, i__5 = k4 - j; i__2 = min(i__4,i__5); for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L140: */ } /* L150: */ } } if (! done) { goto L10; } return 0; /* End of ZLASCL */ } /* zlascl_ */ /* zungqr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zungqr_(m, n, k, a, lda, tau, work, lwork, info) integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; { /* 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_(); static integer nx; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(); static integer ldwork; extern /* Subroutine */ int zlarft_(); static integer iws; /* -- 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 */ /* .. 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 (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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *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, 6L); 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 <= 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 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__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L); /* 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, 4L, 12L, 7L, 10L); } /* 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_ */ /* zlarfb.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1a /* Subroutine */ int zlarfb_(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c__, ldc, work, ldwork, side_len, trans_len, direct_len, storev_len) char *side, *trans, *direct, *storev; integer *m, *n, *k; doublecomplex *v; integer *ldv; doublecomplex *t; integer *ldt; doublecomplex *c__; integer *ldc; doublecomplex *work; integer *ldwork; ftnlen side_len; ftnlen trans_len; ftnlen direct_len; ftnlen storev_len; { /* System generated locals */ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1, z__2; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer i__, j; extern logical lsame_(); extern /* Subroutine */ int zgemm_(), zcopy_(), ztrmm_(), zlacgv_(); static char transt[1]; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLARFB applies a complex block reflector H or its transpose H' to a */ /* complex M-by-N matrix C, from either the left or the right. */ /* Arguments */ /* ========= */ /* SIDE (input) CHARACTER*1 */ /* = 'L': apply H or H' from the Left */ /* = 'R': apply H or H' from the Right */ /* TRANS (input) CHARACTER*1 */ /* = 'N': apply H (No transpose) */ /* = 'C': apply H' (Conjugate transpose) */ /* DIRECT (input) CHARACTER*1 */ /* Indicates how H is formed from a product of elementary */ /* reflectors */ /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ /* STOREV (input) CHARACTER*1 */ /* Indicates how the vectors which define the elementary */ /* reflectors are stored: */ /* = 'C': Columnwise */ /* = 'R': Rowwise */ /* M (input) INTEGER */ /* The number of rows of the matrix C. */ /* N (input) INTEGER */ /* The number of columns of the matrix C. */ /* K (input) INTEGER */ /* The order of the matrix T (= the number of elementary */ /* reflectors whose product defines the block reflector). */ /* V (input) COMPLEX*16 array, dimension */ /* (LDV,K) if STOREV = 'C' */ /* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ /* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ /* The matrix V. See further details. */ /* LDV (input) INTEGER */ /* The leading dimension of the array V. */ /* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ /* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ /* if STOREV = 'R', LDV >= K. */ /* T (input) COMPLEX*16 array, dimension (LDT,K) */ /* The triangular K-by-K matrix T in the representation of the */ /* block reflector. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= K. */ /* C (input/output) COMPLEX*16 array, dimension (LDC,N) */ /* On entry, the M-by-N matrix C. */ /* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ /* LDC (input) INTEGER */ /* The leading dimension of the array C. LDC >= max(1,M). */ /* WORK (workspace) COMPLEX*16 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). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* Parameter adjustments */ v_dim1 = *ldv; v_offset = v_dim1 + 1; v -= v_offset; t_dim1 = *ldt; t_offset = t_dim1 + 1; t -= t_offset; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; work_dim1 = *ldwork; work_offset = work_dim1 + 1; work -= work_offset; /* Function Body */ if (*m <= 0 || *n <= 0) { return 0; } if (lsame_(trans, "N", 1L, 1L)) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'N'; } if (lsame_(storev, "C", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { /* Let V = ( V1 ) (first K rows) */ /* ( V2 ) */ /* where V1 is unit lower triangular. */ if (lsame_(side, "L", 1L, 1L)) { /* 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) { zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L10: */ } /* W := W * V1 */ ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*m > *k) { /* W := W + C2'*V2 */ i__1 = *m - *k; zgemm_("Conjugate transpose", "No transpose", n, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b1, &work[work_offset], ldwork, 19L, 12L); } /* W := W * T' or W * T */ ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - V * W' */ if (*m > *k) { /* C2 := C2 - V2 * W' */ i__1 = *m - *k; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", &i__1, n, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[ work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] , ldc, 12L, 19L); } /* W := W * V1' */ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 19L, 4L); /* C1 := C1 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + i__ * c_dim1; i__4 = j + i__ * c_dim1; d_cnjg(&z__2, &work[i__ + j * work_dim1]); z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L20: */ } /* L30: */ } } else if (lsame_(side, "R", 1L, 1L)) { /* Form C * H or C * H' where C = ( C1 C2 ) */ /* W := C * V = (C1*V1 + C2*V2) (stored in WOR K) */ /* W := C1 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); /* L40: */ } /* W := W * V1 */ ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*n > *k) { /* W := W + C2 * V2 */ i__1 = *n - *k; zgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b1, &work[work_offset], ldwork, 12L, 12L); } /* W := W * T or W * T' */ ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - W * V' */ if (*n > *k) { /* C2 := C2 - W * V2' */ i__1 = *n - *k; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", m, &i__1, k, &z__1, &work[work_offset], ldwork, &v[*k + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, 12L, 19L); } /* W := W * V1' */ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 19L, 4L); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * c_dim1; i__4 = i__ + j * c_dim1; i__5 = i__ + j * work_dim1; z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L50: */ } /* L60: */ } } } else { /* Let V = ( V1 ) */ /* ( V2 ) (last K rows) */ /* where V2 is unit upper triangular. */ if (lsame_(side, "L", 1L, 1L)) { /* 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) { zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L70: */ } /* W := W * V2 */ ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*m > *k) { /* W := W + C1'*V1 */ i__1 = *m - *k; zgemm_("Conjugate transpose", "No transpose", n, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b1, &work[work_offset], ldwork, 19L, 12L); } /* W := W * T' or W * T */ ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - V * W' */ if (*m > *k) { /* C1 := C1 - V1 * W' */ i__1 = *m - *k; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", &i__1, n, k, &z__1, &v[v_offset], ldv, &work[work_offset], ldwork, &c_b1, &c__[c_offset], ldc, 12L, 19L); } /* W := W * V2' */ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[ work_offset], ldwork, 5L, 5L, 19L, 4L); /* C2 := C2 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *m - *k + j + i__ * c_dim1; i__4 = *m - *k + j + i__ * c_dim1; d_cnjg(&z__2, &work[i__ + j * work_dim1]); z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L80: */ } /* L90: */ } } else if (lsame_(side, "R", 1L, 1L)) { /* Form C * H or C * H' where C = ( C1 C2 ) */ /* W := C * V = (C1*V1 + C2*V2) (stored in WOR K) */ /* W := C2 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ j * work_dim1 + 1], &c__1); /* L100: */ } /* W := W * V2 */ ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*n > *k) { /* W := W + C1 * V1 */ i__1 = *n - *k; zgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, & work[work_offset], ldwork, 12L, 12L); } /* W := W * T or W * T' */ ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - W * V' */ if (*n > *k) { /* C1 := C1 - W * V1' */ i__1 = *n - *k; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", m, &i__1, k, &z__1, &work[work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[c_offset], ldc, 12L, 19L); } /* W := W * V2' */ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[ work_offset], ldwork, 5L, 5L, 19L, 4L); /* C2 := C2 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + (*n - *k + j) * c_dim1; i__4 = i__ + (*n - *k + j) * c_dim1; i__5 = i__ + j * work_dim1; z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L110: */ } /* L120: */ } } } } else if (lsame_(storev, "R", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { /* Let V = ( V1 V2 ) (V1: first K columns) */ /* where V1 is unit upper triangular. */ if (lsame_(side, "L", 1L, 1L)) { /* Form H * C or H' * C where C = ( C1 ) */ /* ( C2 ) */ /* W := C' * V' = (C1'*V1' + C2'*V2') (stored i n WORK) */ /* W := C1' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L130: */ } /* W := W * V1' */ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 19L, 4L); if (*m > *k) { /* W := W + C2'*V2' */ i__1 = *m - *k; zgemm_("Conjugate transpose", "Conjugate transpose", n, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] , ldwork, 19L, 19L); } /* W := W * T' or W * T */ ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - V' * W' */ if (*m > *k) { /* C2 := C2 - V2' * W' */ i__1 = *m - *k; z__1.r = -1., z__1.i = 0.; zgemm_("Conjugate transpose", "Conjugate transpose", & i__1, n, k, &z__1, &v[(*k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1], ldc, 19L, 19L); } /* W := W * V1 */ ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); /* C1 := C1 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + i__ * c_dim1; i__4 = j + i__ * c_dim1; d_cnjg(&z__2, &work[i__ + j * work_dim1]); z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L140: */ } /* L150: */ } } else if (lsame_(side, "R", 1L, 1L)) { /* 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) { zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); /* L160: */ } /* W := W * V1' */ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 19L, 4L); if (*n > *k) { /* W := W + C2 * V2' */ i__1 = *n - *k; zgemm_("No transpose", "Conjugate transpose", m, k, &i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] , ldwork, 12L, 19L); } /* W := W * T or W * T' */ ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - W * V */ if (*n > *k) { /* C2 := C2 - W * V2 */ i__1 = *n - *k; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "No transpose", m, &i__1, k, &z__1, &work[work_offset], ldwork, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, 12L, 12L); } /* W := W * V1 */ ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * c_dim1; i__4 = i__ + j * c_dim1; i__5 = i__ + j * work_dim1; z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L170: */ } /* L180: */ } } } else { /* Let V = ( V1 V2 ) (V2: last K columns) */ /* where V2 is unit lower triangular. */ if (lsame_(side, "L", 1L, 1L)) { /* Form H * C or H' * C where C = ( C1 ) */ /* ( C2 ) */ /* W := C' * V' = (C1'*V1' + C2'*V2') (stored i n WORK) */ /* W := C2' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); zlacgv_(n, &work[j * work_dim1 + 1], &c__1); /* L190: */ } /* W := W * V2' */ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork, 5L, 5L, 19L, 4L); if (*m > *k) { /* W := W + C1'*V1' */ i__1 = *m - *k; zgemm_("Conjugate transpose", "Conjugate transpose", n, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &work[work_offset], ldwork, 19L, 19L); } /* W := W * T' or W * T */ ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - V' * W' */ if (*m > *k) { /* C1 := C1 - V1' * W' */ i__1 = *m - *k; z__1.r = -1., z__1.i = 0.; zgemm_("Conjugate transpose", "Conjugate transpose", & i__1, n, k, &z__1, &v[v_offset], ldv, &work[ work_offset], ldwork, &c_b1, &c__[c_offset], ldc, 19L, 19L); } /* W := W * V2 */ ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork, 5L, 5L, 12L, 4L); /* C2 := C2 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *m - *k + j + i__ * c_dim1; i__4 = *m - *k + j + i__ * c_dim1; d_cnjg(&z__2, &work[i__ + j * work_dim1]); z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L200: */ } /* L210: */ } } else if (lsame_(side, "R", 1L, 1L)) { /* 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) { zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ j * work_dim1 + 1], &c__1); /* L220: */ } /* W := W * V2' */ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, &c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork, 5L, 5L, 19L, 4L); if (*n > *k) { /* W := W + C1 * V1' */ i__1 = *n - *k; zgemm_("No transpose", "Conjugate transpose", m, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b1, &work[work_offset], ldwork, 12L, 19L); } /* W := W * T or W * T' */ ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); /* C := C - W * V */ if (*n > *k) { /* C1 := C1 - W * V1 */ i__1 = *n - *k; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "No transpose", m, &i__1, k, &z__1, &work[work_offset], ldwork, &v[v_offset], ldv, & c_b1, &c__[c_offset], ldc, 12L, 12L); } /* W := W * V2 */ ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork, 5L, 5L, 12L, 4L); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + (*n - *k + j) * c_dim1; i__4 = i__ + (*n - *k + j) * c_dim1; i__5 = i__ + j * work_dim1; z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L230: */ } /* L240: */ } } } } return 0; /* End of ZLARFB */ } /* zlarfb_ */ /* zungl2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zungl2_(m, n, k, a, lda, tau, work, info) integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1, z__2; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer i__, j, l; extern /* Subroutine */ int zscal_(), zlarf_(), xerbla_(), zlacgv_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */ /* which is defined as the first m rows of a product of k elementary */ /* reflectors of order n */ /* Q = H(k)' . . . H(2)' H(1)' */ /* as returned by ZGELQF. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix Q. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q. N >= M. */ /* K (input) INTEGER */ /* The number of elementary reflectors whose product defines the */ /* matrix Q. M >= K >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the i-th row must contain the vector which defines */ /* the elementary reflector H(i), for i = 1,2,...,k, as returned */ /* by ZGELQF in the first k rows of its array argument A. */ /* On exit, the m by n matrix Q. */ /* LDA (input) INTEGER */ /* The first dimension of the array A. LDA >= max(1,M). */ /* TAU (input) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGELQF. */ /* WORK (workspace) COMPLEX*16 array, dimension (M) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument has an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < *m) { *info = -2; } else if (*k < 0 || *k > *m) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGL2", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m <= 0) { return 0; } if (*k < *m) { /* Initialise rows k+1:m to rows of the unit matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (l = *k + 1; l <= i__2; ++l) { i__3 = l + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ } if (j > *k && j <= *m) { i__2 = j + j * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; } /* L20: */ } } for (i__ = *k; i__ >= 1; --i__) { /* Apply H(i)' to A(i:m,i:n) from the right */ if (i__ < *n) { i__1 = *n - i__; zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); if (i__ < *m) { i__1 = i__ + i__ * a_dim1; a[i__1].r = 1., a[i__1].i = 0.; i__1 = *m - i__; i__2 = *n - i__ + 1; d_cnjg(&z__1, &tau[i__]); zlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & z__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L); } i__1 = *n - i__; i__2 = i__; z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda); i__1 = *n - i__; zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); } i__1 = i__ + i__ * a_dim1; d_cnjg(&z__2, &tau[i__]); z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Set A(1:i-1,i) to zero */ i__1 = i__ - 1; for (l = 1; l <= i__1; ++l) { i__2 = i__ + l * a_dim1; a[i__2].r = 0., a[i__2].i = 0.; /* L30: */ } /* L40: */ } return 0; /* End of ZUNGL2 */ } /* zungl2_ */ /* zlassq.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlassq_(n, x, incx, scale, sumsq) integer *n; doublecomplex *x; integer *incx; doublereal *scale, *sumsq; { /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; /* Builtin functions */ double d_imag(); /* Local variables */ static doublereal temp1; static integer ix; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLASSQ returns the values scl and ssq such that */ /* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ /* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is */ /* assumed to be at least unity and the value of ssq will then satisfy */ /* 1.0 .le. ssq .le. ( sumsq + 2*n ). */ /* scale is assumed to be non-negative and scl returns the value */ /* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), */ /* i */ /* scale and sumsq must be supplied in SCALE and SUMSQ respectively. */ /* SCALE and SUMSQ are overwritten by scl and ssq respectively. */ /* The routine makes only one pass through the vector X. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of elements to be used from the vector X. */ /* X (input) DOUBLE PRECISION */ /* The vector x as described above. */ /* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ /* INCX (input) INTEGER */ /* The increment between successive values of the vector X. */ /* INCX > 0. */ /* SCALE (input/output) DOUBLE PRECISION */ /* On entry, the value scale in the equation above. */ /* On exit, SCALE is overwritten with the value scl . */ /* SUMSQ (input/output) DOUBLE PRECISION */ /* On entry, the value sumsq in the equation above. */ /* On exit, SUMSQ is overwritten with the value ssq . */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --x; /* Function Body */ if (*n > 0) { i__1 = (*n - 1) * *incx + 1; i__2 = *incx; for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { i__3 = ix; if (x[i__3].r != 0.) { i__3 = ix; temp1 = (d__1 = x[i__3].r, abs(d__1)); if (*scale < temp1) { /* Computing 2nd power */ d__1 = *scale / temp1; *sumsq = *sumsq * (d__1 * d__1) + 1; *scale = temp1; } else { /* Computing 2nd power */ d__1 = temp1 / *scale; *sumsq += d__1 * d__1; } } if (d_imag(&x[ix]) != 0.) { temp1 = (d__1 = d_imag(&x[ix]), abs(d__1)); if (*scale < temp1) { /* Computing 2nd power */ d__1 = *scale / temp1; *sumsq = *sumsq * (d__1 * d__1) + 1; *scale = temp1; } else { /* Computing 2nd power */ d__1 = temp1 / *scale; *sumsq += d__1 * d__1; } } /* L10: */ } } return 0; /* End of ZLASSQ */ } /* zlassq_ */ /* zhseqr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1 #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int zhseqr_(job, compz, n, ilo, ihi, h__, ldh, w, z__, ldz, work, lwork, info, job_len, compz_len) char *job, *compz; integer *n, *ilo, *ihi; doublecomplex *h__; integer *ldh; doublecomplex *w, *z__; integer *ldz; doublecomplex *work; integer *lwork, *info; ftnlen job_len; ftnlen compz_len; { /* System generated locals */ address a__1[2]; integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2], i__5, i__6; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; char ch__1[2]; /* Builtin functions */ double d_imag(); void d_cnjg(); /* Subroutine */ int s_cat(); /* Local variables */ static integer maxb, ierr; static doublereal unfl; static doublecomplex temp; static doublereal ovfl; static integer i__, j, k, l; static doublecomplex s[225] /* was [15][15] */, v[16]; extern logical lsame_(); extern /* Subroutine */ int zscal_(); static integer itemp; static doublereal rtemp; static integer i1, i2; extern /* Subroutine */ int zgemv_(); static logical initz, wantt, wantz; static doublereal rwork[1]; extern /* Subroutine */ int zcopy_(); extern doublereal dlapy2_(); extern /* Subroutine */ int dlabad_(); static integer ii, nh; extern doublereal dlamch_(); static integer nr, ns, nv; static doublecomplex vv[16]; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zdscal_(), zlarfg_(); extern integer izamax_(); extern doublereal zlanhs_(); extern /* Subroutine */ int zlahqr_(), zlacpy_(), zlaset_(), zlarfx_(); static doublereal smlnum; static integer itn; static doublecomplex tau; static integer its; static doublereal ulp, tst1; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZHSEQR computes the eigenvalues of a complex upper Hessenberg */ /* matrix H, and, optionally, the matrices T and Z from the Schur */ /* decomposition H = Z T Z**H, where T is an upper triangular matrix */ /* (the Schur form), and Z is the unitary matrix of Schur vectors. */ /* Optionally Z may be postmultiplied into an input unitary matrix Q, */ /* so that this routine can give the Schur factorization of a matrix A */ /* which has been reduced to the Hessenberg form H by the unitary */ /* matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* = 'E': compute eigenvalues only; */ /* = 'S': compute eigenvalues and the Schur form T. */ /* COMPZ (input) CHARACTER*1 */ /* = 'N': no Schur vectors are computed; */ /* = 'I': Z is initialized to the unit matrix and the matrix Z */ /* of Schur vectors of H is returned; */ /* = 'V': Z must contain an unitary matrix Q on entry, and */ /* the product Q*Z is returned. */ /* N (input) INTEGER */ /* The order of the matrix H. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that H is already upper triangular in rows */ /* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ /* set by a previous call to ZGEBAL, and then passed to CGEHRD */ /* when the matrix output by ZGEBAL is reduced to Hessenberg */ /* form. Otherwise ILO and IHI should be set to 1 and N */ /* respectively. */ /* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ /* H (input/output) COMPLEX*16 array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if JOB = 'S', H contains the upper triangular matrix */ /* T from the Schur decomposition (the Schur form). If */ /* JOB = 'E', the contents of H are unspecified on exit. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH >= max(1,N). */ /* W (output) COMPLEX*16 array, dimension (N) */ /* The computed eigenvalues. If JOB = 'S', the eigenvalues are */ /* stored in the same order as on the diagonal of the Schur form */ /* returned in H, with W(i) = H(i,i). */ /* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */ /* If COMPZ = 'N': Z is not referenced. */ /* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */ /* contains the unitary matrix Z of the Schur vectors of H. */ /* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */ /* which is assumed to be equal to the unit matrix except for */ /* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */ /* Normally Q is the unitary matrix generated by ZUNGHR after */ /* the call to ZGEHRD which formed the Hessenberg matrix H. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. */ /* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */ /* WORK (workspace) COMPLEX*16 array, dimension (N) */ /* LWORK (input) INTEGER */ /* This argument is currently redundant. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, ZHSEQR failed to compute all the */ /* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */ /* elements 1:ilo-1 and i+1:n of W contain those */ /* eigenvalues which have been successfully computed. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = h_dim1 + 1; h__ -= h_offset; --w; z_dim1 = *ldz; z_offset = z_dim1 + 1; z__ -= z_offset; --work; /* Function Body */ wantt = lsame_(job, "S", 1L, 1L); initz = lsame_(compz, "I", 1L, 1L); wantz = initz || lsame_(compz, "V", 1L, 1L); *info = 0; if (! lsame_(job, "E", 1L, 1L) && ! wantt) { *info = -1; } else if (! lsame_(compz, "N", 1L, 1L) && ! wantz) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -4; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -5; } else if (*ldh < max(1,*n)) { *info = -7; } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHSEQR", &i__1, 6L); return 0; } /* Initialize Z, if necessary */ if (initz) { zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz, 4L); } /* Store the eigenvalues isolated by ZGEBAL. */ i__1 = *ilo - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; i__3 = i__ + i__ * h_dim1; w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i; /* L10: */ } i__1 = *n; for (i__ = *ihi + 1; i__ <= i__1; ++i__) { i__2 = i__; i__3 = i__ + i__ * h_dim1; w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i; /* L20: */ } /* Quick return if possible. */ if (*n == 0) { return 0; } if (*ilo == *ihi) { i__1 = *ilo; i__2 = *ilo + *ilo * h_dim1; w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; return 0; } /* Set rows and columns ILO to IHI to zero below the first */ /* subdiagonal. */ i__1 = *ihi - 2; for (j = *ilo; j <= i__1; ++j) { i__2 = *n; for (i__ = j + 2; i__ <= i__2; ++i__) { i__3 = i__ + j * h_dim1; h__[i__3].r = 0., h__[i__3].i = 0.; /* L30: */ } /* L40: */ } nh = *ihi - *ilo + 1; /* I1 and I2 are the indices of the first row and last column of H */ /* to which transformations must be applied. If eigenvalues only are */ /* being computed, I1 and I2 are re-set inside the main loop. */ if (wantt) { i1 = 1; i2 = *n; } else { i1 = *ilo; i2 = *ihi; } /* Ensure that the subdiagonal elements are real. */ i__1 = *ihi; for (i__ = *ilo + 1; i__ <= i__1; ++i__) { i__2 = i__ + (i__ - 1) * h_dim1; temp.r = h__[i__2].r, temp.i = h__[i__2].i; if (d_imag(&temp) != 0.) { d__1 = temp.r; d__2 = d_imag(&temp); rtemp = dlapy2_(&d__1, &d__2); i__2 = i__ + (i__ - 1) * h_dim1; h__[i__2].r = rtemp, h__[i__2].i = 0.; z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp; temp.r = z__1.r, temp.i = z__1.i; if (i2 > i__) { i__2 = i2 - i__; d_cnjg(&z__1, &temp); zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh); } i__2 = i__ - i1; zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1); if (i__ < *ihi) { i__2 = i__ + 1 + i__ * h_dim1; i__3 = i__ + 1 + i__ * h_dim1; z__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, z__1.i = temp.r * h__[i__3].i + temp.i * h__[i__3].r; h__[i__2].r = z__1.r, h__[i__2].i = z__1.i; } if (wantz) { zscal_(&nh, &temp, &z__[*ilo + i__ * z_dim1], &c__1); } } /* L50: */ } /* Determine the order of the multi-shift QR algorithm to be used. */ /* Writing concatenation */ i__4[0] = 1, a__1[0] = job; i__4[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__4, &c__2, 2L); ns = ilaenv_(&c__4, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L); /* Writing concatenation */ i__4[0] = 1, a__1[0] = job; i__4[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__4, &c__2, 2L); maxb = ilaenv_(&c__8, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L); if (ns <= 1 || ns > nh || maxb >= nh) { /* Use the standard double-shift algorithm */ zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, info); return 0; } maxb = max(2,maxb); /* Computing MIN */ i__1 = min(ns,maxb); ns = min(i__1,15); /* Now 1 < NS <= MAXB < NH. */ /* Set machine-dependent constants for the stopping criterion. */ /* If norm(H) <= sqrt(OVFL), overflow should not occur. */ unfl = dlamch_("Safe minimum", 12L); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("Precision", 9L); smlnum = unfl * (nh / ulp); /* ITN is the total number of multiple-shift QR iterations allowed. */ itn = nh * 30; /* The main loop begins here. I is the loop index and decreases from */ /* IHI to ILO in steps of at most MAXB. Each iteration of the loop */ /* works with the active submatrix in rows and columns L to I. */ /* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */ /* H(L,L-1) is negligible so that the matrix splits. */ i__ = *ihi; L60: if (i__ < *ilo) { goto L180; } /* Perform multiple-shift QR iterations on rows and columns ILO to I */ /* until a submatrix of order at most MAXB splits off at the bottom */ /* because a subdiagonal element has become negligible. */ l = *ilo; i__1 = itn; for (its = 0; its <= i__1; ++its) { /* Look for a single small subdiagonal element. */ i__2 = l + 1; for (k = i__; k >= i__2; --k) { i__3 = k - 1 + (k - 1) * h_dim1; i__5 = k + k * h_dim1; tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[k - 1 + (k - 1) * h_dim1]), abs(d__2)) + ((d__3 = h__[i__5].r, abs(d__3)) + (d__4 = d_imag(&h__[k + k * h_dim1]), abs( d__4))); if (tst1 == 0.) { i__3 = i__ - l + 1; tst1 = zlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, rwork, 1L); } i__3 = k + (k - 1) * h_dim1; /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) { goto L80; } /* L70: */ } L80: l = k; if (l > *ilo) { /* H(L,L-1) is negligible. */ i__2 = l + (l - 1) * h_dim1; h__[i__2].r = 0., h__[i__2].i = 0.; } /* Exit from loop if a submatrix of order <= MAXB has split off . */ if (l >= i__ - maxb + 1) { goto L170; } /* Now the active submatrix is in rows and columns L to I. If */ /* eigenvalues only are being computed, only the active submatr ix */ /* need be transformed. */ if (! wantt) { i1 = l; i2 = i__; } if (its == 20 || its == 30) { /* Exceptional shifts. */ i__2 = i__; for (ii = i__ - ns + 1; ii <= i__2; ++ii) { i__3 = ii; i__5 = ii + (ii - 1) * h_dim1; i__6 = ii + ii * h_dim1; d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = h__[i__6].r, abs(d__2))) * 1.5; w[i__3].r = d__3, w[i__3].i = 0.; /* L90: */ } } else { /* Use eigenvalues of trailing submatrix of order NS as shifts. */ zlacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) * h_dim1], ldh, s, &c__15, 4L); zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ - ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr); if (ierr > 0) { /* If ZLAHQR failed to compute all NS eigenvalues , use the */ /* unconverged diagonal elements as the remaining shifts. */ i__2 = ierr; for (ii = 1; ii <= i__2; ++ii) { i__3 = i__ - ns + ii; i__5 = ii + ii * 15 - 16; w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i; /* L100: */ } } } /* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) */ /* where G is the Hessenberg submatrix H(L:I,L:I) and w is */ /* the vector of shifts (stored in W). The result is */ /* stored in the local array V. */ v[0].r = 1., v[0].i = 0.; i__2 = ns + 1; for (ii = 2; ii <= i__2; ++ii) { i__3 = ii - 1; v[i__3].r = 0., v[i__3].i = 0.; /* L110: */ } nv = 1; i__2 = i__; for (j = i__ - ns + 1; j <= i__2; ++j) { i__3 = nv + 1; zcopy_(&i__3, v, &c__1, vv, &c__1); i__3 = nv + 1; i__5 = j; z__1.r = -w[i__5].r, z__1.i = -w[i__5].i; zgemv_("No transpose", &i__3, &nv, &c_b2, &h__[l + l * h_dim1], ldh, vv, &c__1, &z__1, v, &c__1, 12L); ++nv; /* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zer o, */ /* reset it to the unit vector. */ itemp = izamax_(&nv, v, &c__1); i__3 = itemp - 1; rtemp = (d__1 = v[i__3].r, abs(d__1)) + (d__2 = d_imag(&v[itemp - 1]), abs(d__2)); if (rtemp == 0.) { v[0].r = 1., v[0].i = 0.; i__3 = nv; for (ii = 2; ii <= i__3; ++ii) { i__5 = ii - 1; v[i__5].r = 0., v[i__5].i = 0.; /* L120: */ } } else { rtemp = max(rtemp,smlnum); d__1 = 1. / rtemp; zdscal_(&nv, &d__1, v, &c__1); } /* L130: */ } /* Multiple-shift QR step */ i__2 = i__ - 1; for (k = l; k <= i__2; ++k) { /* The first iteration of this loop determines a reflect ion G */ /* from the vector V and applies it from left and right to H, */ /* thus creating a nonzero bulge below the subdiagonal. */ /* Each subsequent iteration determines a reflection G t o */ /* restore the Hessenberg form in the (K-1)th column, an d thus */ /* chases the bulge one step toward the bottom of the ac tive */ /* submatrix. NR is the order of G. */ /* Computing MIN */ i__3 = ns + 1, i__5 = i__ - k + 1; nr = min(i__3,i__5); if (k > l) { zcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); } zlarfg_(&nr, v, &v[1], &c__1, &tau); if (k > l) { i__3 = k + (k - 1) * h_dim1; h__[i__3].r = v[0].r, h__[i__3].i = v[0].i; i__3 = i__; for (ii = k + 1; ii <= i__3; ++ii) { i__5 = ii + (k - 1) * h_dim1; h__[i__5].r = 0., h__[i__5].i = 0.; /* L140: */ } } v[0].r = 1., v[0].i = 0.; /* Apply G' from the left to transform the rows of the m atrix */ /* in columns K to I2. */ i__3 = i2 - k + 1; d_cnjg(&z__1, &tau); zlarfx_("Left", &nr, &i__3, v, &z__1, &h__[k + k * h_dim1], ldh, & work[1], 4L); /* Apply G from the right to transform the columns of th e */ /* matrix in rows I1 to min(K+NR,I). */ /* Computing MIN */ i__5 = k + nr; i__3 = min(i__5,i__) - i1 + 1; zlarfx_("Right", &i__3, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh, &work[1], 5L); if (wantz) { /* Accumulate transformations in the matrix Z */ zlarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1], ldz, &work[1], 5L); } /* L150: */ } /* Ensure that H(I,I-1) is real. */ i__2 = i__ + (i__ - 1) * h_dim1; temp.r = h__[i__2].r, temp.i = h__[i__2].i; if (d_imag(&temp) != 0.) { d__1 = temp.r; d__2 = d_imag(&temp); rtemp = dlapy2_(&d__1, &d__2); i__2 = i__ + (i__ - 1) * h_dim1; h__[i__2].r = rtemp, h__[i__2].i = 0.; z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp; temp.r = z__1.r, temp.i = z__1.i; if (i2 > i__) { i__2 = i2 - i__; d_cnjg(&z__1, &temp); zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh); } i__2 = i__ - i1; zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1); if (wantz) { zscal_(&nh, &temp, &z__[*ilo + i__ * z_dim1], &c__1); } } /* L160: */ } /* Failure to converge in remaining number of iterations */ *info = i__; return 0; L170: /* A submatrix of order <= MAXB in rows and columns L to I has split */ /* off. Use the double-shift QR algorithm to handle it. */ zlahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, info); if (*info > 0) { return 0; } /* Decrement number of remaining iterations, and return to start of */ /* the main loop with a new value of I. */ itn -= its; i__ = l - 1; goto L60; L180: return 0; /* End of ZHSEQR */ } /* zhseqr_ */ /* zunm2r.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zunm2r_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *c__; integer *ldc; doublecomplex *work; integer *info; ftnlen side_len; ftnlen trans_len; { /* 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(); /* Local variables */ static logical left; static doublecomplex taui; static integer i__; extern logical lsame_(); extern /* Subroutine */ int zlarf_(); static integer i1, i2, i3, ic, jc, mi, ni, nq; extern /* Subroutine */ int xerbla_(); static logical notran; static doublecomplex aii; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNM2R 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 ZGEQRF. 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. */ /* A (input) COMPLEX*16 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 */ /* ZGEQRF 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) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGEQRF. */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); /* NQ is the order of Q */ if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "C", 1L, 1L)) { *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_("ZUNM2R", &i__1, 6L); 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) 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; } i__3 = i__ + i__ * a_dim1; aii.r = a[i__3].r, aii.i = a[i__3].i; i__3 = i__ + i__ * a_dim1; a[i__3].r = 1., a[i__3].i = 0.; zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic + jc * c_dim1], ldc, &work[1], 1L); i__3 = i__ + i__ * a_dim1; a[i__3].r = aii.r, a[i__3].i = aii.i; /* L10: */ } return 0; /* End of ZUNM2R */ } /* zunm2r_ */ /* zgesv.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zgesv_(n, nrhs, a, lda, ipiv, b, ldb, info) integer *n, *nrhs; doublecomplex *a; integer *lda, *ipiv; doublecomplex *b; integer *ldb, *info; { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; /* Local variables */ extern /* Subroutine */ int xerbla_(), zgetrf_(), zgetrs_(); /* -- LAPACK driver routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* March 31, 1993 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGESV computes the solution to a complex system of linear equations */ /* A * X = B, */ /* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ /* The LU decomposition with partial pivoting and row interchanges is */ /* used to factor A as */ /* A = P * L * U, */ /* where P is a permutation matrix, L is unit lower triangular, and U is */ /* upper triangular. The factored form of A is then used to solve the */ /* system of equations A * X = B. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of linear equations, i.e., the order of the */ /* matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrix B. NRHS >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the N-by-N coefficient matrix A. */ /* On exit, the factors L and U from the factorization */ /* A = P*L*U; the unit diagonal elements of L are not stored. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* IPIV (output) INTEGER array, dimension (N) */ /* The pivot indices that define the permutation matrix P; */ /* row i of the matrix was interchanged with row IPIV(i). */ /* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */ /* On entry, the N-by-NRHS matrix of right hand side matrix B. */ /* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ /* has been completed, but the factor U is exactly */ /* singular, so the solution could not be computed. */ /* ===================================================================== */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --ipiv; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*nrhs < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGESV ", &i__1, 6L); return 0; } /* Compute the LU factorization of A. */ zgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); if (*info == 0) { /* Solve the system A*X = B, overwriting B with X. */ zgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ b_offset], ldb, info, 12L); } return 0; /* End of ZGESV */ } /* zgesv_ */ /* zungbr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zungbr_(vect, m, n, k, a, lda, tau, work, lwork, info, vect_len) char *vect; integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; ftnlen vect_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ static integer i__, j; extern logical lsame_(); static integer iinfo; static logical wantq; extern /* Subroutine */ int xerbla_(), zunglq_(), zungqr_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNGBR generates one of the complex unitary matrices Q or P**H */ /* determined by ZGEBRD 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) or G(i) respectively. */ /* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */ /* is of order M: */ /* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n */ /* columns of Q, where m >= n >= k; */ /* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an */ /* M-by-M matrix. */ /* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H */ /* is of order N: */ /* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m */ /* rows of P**H, where n >= m >= k; */ /* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as */ /* an N-by-N matrix. */ /* Arguments */ /* ========= */ /* VECT (input) CHARACTER*1 */ /* Specifies whether the matrix Q or the matrix P**H is */ /* required, as defined in the transformation applied by ZGEBRD: */ /* = 'Q': generate Q; */ /* = 'P': generate P**H. */ /* M (input) INTEGER */ /* The number of rows of the matrix Q or P**H to be returned. */ /* M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix Q or P**H to be returned. */ /* N >= 0. */ /* If VECT = 'Q', M >= N >= min(M,K); */ /* if VECT = 'P', N >= M >= min(N,K). */ /* K (input) INTEGER */ /* If VECT = 'Q', the number of columns in the original M-by-K */ /* matrix reduced by ZGEBRD. */ /* If VECT = 'P', the number of rows in the original K-by-N */ /* matrix reduced by ZGEBRD. */ /* K >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the vectors which define the elementary reflectors, */ /* as returned by ZGEBRD. */ /* On exit, the M-by-N matrix Q or P**H. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= M. */ /* TAU (input) COMPLEX*16 array, dimension */ /* (min(M,K)) if VECT = 'Q' */ /* (min(N,K)) if VECT = 'P' */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i) or G(i), which determines Q or P**H, as */ /* returned by ZGEBRD in its array argument TAUQ or TAUP. */ /* 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,min(M,N)). */ /* For optimum performance LWORK >= min(M,N)*NB, where NB */ /* is the optimal blocksize. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; wantq = lsame_(vect, "Q", 1L, 1L); if (! wantq && ! lsame_(vect, "P", 1L, 1L)) { *info = -1; } else if (*m < 0) { *info = -2; } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && ( *m > *n || *m < min(*n,*k))) { *info = -3; } else if (*k < 0) { *info = -4; } else if (*lda < max(1,*m)) { *info = -6; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = 1, i__2 = min(*m,*n); if (*lwork < max(i__1,i__2)) { *info = -9; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGBR", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { work[1].r = 1., work[1].i = 0.; return 0; } if (wantq) { /* Form Q, determined by a call to ZGEBRD to reduce an m-by-k */ /* matrix */ if (*m >= *k) { /* If m >= k, assume m >= n >= k */ zungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & iinfo); } else { /* If m < k, assume m = n */ /* Shift the vectors which define the elementary reflect ors one */ /* column to the right, and set the first row and column of Q */ /* to those of the unit matrix */ for (j = *m; j >= 2; --j) { i__1 = j * a_dim1 + 1; a[i__1].r = 0., a[i__1].i = 0.; i__1 = *m; for (i__ = j + 1; i__ <= i__1; ++i__) { i__2 = i__ + j * a_dim1; i__3 = i__ + (j - 1) * a_dim1; a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; /* L10: */ } /* L20: */ } i__1 = a_dim1 + 1; a[i__1].r = 1., a[i__1].i = 0.; i__1 = *m; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = i__ + a_dim1; a[i__2].r = 0., a[i__2].i = 0.; /* L30: */ } if (*m > 1) { /* Form Q(2:m,2:m) */ i__1 = *m - 1; i__2 = *m - 1; i__3 = *m - 1; zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ 1], &work[1], lwork, &iinfo); } } } else { /* Form P', determined by a call to ZGEBRD to reduce a k-by-n */ /* matrix */ if (*k < *n) { /* If k < n, assume k <= m <= n */ zunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & iinfo); } else { /* If k >= n, assume m = n */ /* Shift the vectors which define the elementary reflect ors one */ /* row downward, and set the first row and column of P' to */ /* those of the unit matrix */ i__1 = a_dim1 + 1; a[i__1].r = 1., a[i__1].i = 0.; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = i__ + a_dim1; a[i__2].r = 0., a[i__2].i = 0.; /* L40: */ } i__1 = *n; for (j = 2; j <= i__1; ++j) { for (i__ = j - 1; i__ >= 2; --i__) { i__2 = i__ + j * a_dim1; i__3 = i__ - 1 + j * a_dim1; a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; /* L50: */ } i__2 = j * a_dim1 + 1; a[i__2].r = 0., a[i__2].i = 0.; /* L60: */ } if (*n > 1) { /* Form P'(2:n,2:n) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; zunglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ 1], &work[1], lwork, &iinfo); } } } return 0; /* End of ZUNGBR */ } /* zungbr_ */ /* zgelq2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zgelq2_(m, n, a, lda, tau, work, info) integer *m, *n; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ static integer i__, k; static doublecomplex alpha; extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_(), zlacgv_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGELQ2 computes an LQ factorization of a complex m by n matrix A: */ /* A = L * Q. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, the elements on and below the diagonal of the array */ /* contain the m by min(m,n) lower trapezoidal matrix L (L is */ /* lower triangular if m <= n); the elements above the diagonal, */ /* with the array TAU, represent the unitary matrix Q as a */ /* product of elementary reflectors (see Further Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX*16 array, dimension (M) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */ /* A(i,i+1:n), and tau in TAU(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGELQ2", &i__1, 6L); return 0; } k = min(*m,*n); i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, &tau[i__] ); if (i__ < *m) { /* Apply H(i) to A(i+1:m,i:n) from the right */ i__2 = i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; i__2 = *m - i__; i__3 = *n - i__ + 1; zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L); } i__2 = i__ + i__ * a_dim1; a[i__2].r = alpha.r, a[i__2].i = alpha.i; i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); /* L10: */ } return 0; /* End of ZGELQ2 */ } /* zgelq2_ */ /* zgehrd.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int zgehrd_(n, ilo, ihi, a, lda, tau, work, lwork, info) integer *n, *ilo, *ihi; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; doublecomplex z__1; /* Local variables */ static integer i__; static doublecomplex t[4160] /* was [65][64] */; static integer nbmin, iinfo; extern /* Subroutine */ int zgemm_(), zgehd2_(); static integer ib; static doublecomplex ei; static integer nb, nh, nx; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(), zlahrd_(); static integer ldwork, iws; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H */ /* by a unitary similarity transformation: Q' * A * Q = H . */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that A is already upper triangular in rows */ /* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ /* set by a previous call to ZGEBAL; otherwise they should be */ /* set to 1 and N respectively. See Further Details. */ /* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the N-by-N general matrix to be reduced. */ /* On exit, the upper triangle and the first subdiagonal of A */ /* are overwritten with the upper Hessenberg matrix H, and the */ /* elements below the first subdiagonal, with the array TAU, */ /* represent the unitary matrix Q as a product of elementary */ /* reflectors. See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* TAU (output) COMPLEX*16 array, dimension (N-1) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */ /* zero. */ /* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The length of the array WORK. LWORK >= max(1,N). */ /* For optimum performance LWORK >= N*NB, where NB is the */ /* optimal blocksize. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of (ihi-ilo) elementary */ /* reflectors */ /* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ /* exit in A(i+2:ihi,i), and tau in TAU(i). */ /* The contents of A are illustrated by the following example, with */ /* n = 7, ilo = 2 and ihi = 6: */ /* on entry, on exit, */ /* ( a a a a a a a ) ( a a h h h h a ) */ /* ( a a a a a a ) ( a h h h h a ) */ /* ( a a a a a a ) ( h h h h h h ) */ /* ( a a a a a a ) ( v2 h h h h h ) */ /* ( a a a a a a ) ( v2 v3 h h h h ) */ /* ( a a a a a a ) ( v2 v3 v4 h h h ) */ /* ( a ) ( a ) */ /* where a denotes an element of the original matrix A, h denotes a */ /* modified element of the upper Hessenberg matrix H, and vi denotes an */ /* element of the vector defining H(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -2; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*lwork < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEHRD", &i__1, 6L); return 0; } /* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */ i__1 = *ilo - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; tau[i__2].r = 0., tau[i__2].i = 0.; /* L10: */ } i__1 = *n - 1; for (i__ = max(1,*ihi); i__ <= i__1; ++i__) { i__2 = i__; tau[i__2].r = 0., tau[i__2].i = 0.; /* L20: */ } /* Quick return if possible */ nh = *ihi - *ilo + 1; if (nh <= 1) { work[1].r = 1., work[1].i = 0.; return 0; } /* Determine the block size. */ /* Computing MIN */ i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1, 6L, 1L); nb = min(i__1,i__2); nbmin = 2; iws = 1; if (nb > 1 && nb < nh) { /* Determine when to cross over from blocked to unblocked code */ /* (last block is always handled by unblocked code). */ /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1, 6L, 1L); nx = max(i__1,i__2); if (nx < nh) { /* Determine if workspace is large enough for blocked co de. */ iws = *n * nb; if (*lwork < iws) { /* Not enough workspace to use optimal NB: deter mine the */ /* minimum value of NB, and reduce NB or force us e of */ /* unblocked code. */ /* Computing MAX */ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEHRD", " ", n, ilo, ihi, & c_n1, 6L, 1L); nbmin = max(i__1,i__2); if (*lwork >= *n * nbmin) { nb = *lwork / *n; } else { nb = 1; } } } } ldwork = *n; if (nb < nbmin || nb >= nh) { /* Use unblocked code below */ i__ = *ilo; } else { /* Use blocked code */ i__1 = *ihi - 1 - nx; i__2 = nb; for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = nb, i__4 = *ihi - i__; ib = min(i__3,i__4); /* Reduce columns i:i+ib-1 to Hessenberg form, returning the */ /* matrices V and T of the block reflector H = I - V*T*V ' */ /* which performs the reduction, and also the matrix Y = A*V*T */ zlahrd_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, & c__65, &work[1], &ldwork); /* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */ /* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */ /* to 1. */ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1; ei.r = a[i__3].r, ei.i = a[i__3].i; i__3 = i__ + ib + (i__ + ib - 1) * a_dim1; a[i__3].r = 1., a[i__3].i = 0.; i__3 = *ihi - i__ - ib + 1; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, & z__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &c_b2, &a[(i__ + ib) * a_dim1 + 1], lda, 12L, 19L); i__3 = i__ + ib + (i__ + ib - 1) * a_dim1; a[i__3].r = ei.r, a[i__3].i = ei.i; /* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */ /* left */ i__3 = *ihi - i__; i__4 = *n - i__ - ib + 1; zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", & i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, & c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], & ldwork, 4L, 19L, 7L, 10L); /* L30: */ } } /* Use unblocked code to reduce the rest of the matrix */ zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo); work[1].r = (doublereal) iws, work[1].i = 0.; return 0; /* End of ZGEHRD */ } /* zgehrd_ */ /* zgebd2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgebd2_(m, n, a, lda, d__, e, tauq, taup, work, info) integer *m, *n; doublecomplex *a; integer *lda; doublereal *d__, *e; doublecomplex *tauq, *taup, *work; integer *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; doublecomplex z__1; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer i__; static doublecomplex alpha; extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_(), zlacgv_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEBD2 reduces a complex general m by n matrix A to upper or lower */ /* real bidiagonal form B by a unitary transformation: Q' * A * P = B. */ /* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows in the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns in the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the m by n general matrix to be reduced. */ /* On exit, */ /* if m >= n, the diagonal and the first superdiagonal are */ /* overwritten with the upper bidiagonal matrix B; the */ /* elements below the diagonal, with the array TAUQ, represent */ /* the unitary matrix Q as a product of elementary */ /* reflectors, and the elements above the first superdiagonal, */ /* with the array TAUP, represent the unitary matrix P as */ /* a product of elementary reflectors; */ /* if m < n, the diagonal and the first subdiagonal are */ /* overwritten with the lower bidiagonal matrix B; the */ /* elements below the first subdiagonal, with the array TAUQ, */ /* represent the unitary matrix Q as a product of */ /* elementary reflectors, and the elements above the diagonal, */ /* with the array TAUP, represent the unitary matrix P as */ /* a product of elementary reflectors. */ /* See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ /* The diagonal elements of the bidiagonal matrix B: */ /* D(i) = A(i,i). */ /* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ /* The off-diagonal elements of the bidiagonal matrix B: */ /* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ /* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ /* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix Q. See Further Details. */ /* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix P. See Further Details. */ /* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* Further Details */ /* =============== */ /* The matrices Q and P are represented as products of elementary */ /* reflectors: */ /* If m >= n, */ /* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ /* Each H(i) and G(i) has the form: */ /* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ /* where tauq and taup are complex scalars, and v and u are complex */ /* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */ /* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */ /* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* If m < n, */ /* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ /* Each H(i) and G(i) has the form: */ /* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ /* where tauq and taup are complex scalars, v and u are complex vectors; */ /* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */ /* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */ /* tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* The contents of A on exit are illustrated by the following examples: */ /* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ /* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ /* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ /* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ /* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ /* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ /* ( v1 v2 v3 v4 v5 ) */ /* where d and e denote diagonal and off-diagonal elements of B, vi */ /* denotes an element of the vector defining H(i), and ui an element of */ /* the vector defining G(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --d__; --e; --tauq; --taup; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info < 0) { i__1 = -(*info); xerbla_("ZGEBD2", &i__1, 6L); return 0; } if (*m >= *n) { /* Reduce to upper bidiagonal form */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) to annihilate A(i+ 1:m,i) */ i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *m - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, & tauq[i__]); i__2 = i__; d__[i__2] = alpha.r; i__2 = i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Apply H(i)' to A(i:m,i+1:n) from the left */ i__2 = *m - i__ + 1; i__3 = *n - i__; d_cnjg(&z__1, &tauq[i__]); zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L); i__2 = i__ + i__ * a_dim1; i__3 = i__; a[i__2].r = d__[i__3], a[i__2].i = 0.; if (i__ < *n) { /* Generate elementary reflector G(i) to annihila te */ /* A(i,i+2:n) */ i__2 = *n - i__; zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); i__2 = i__ + (i__ + 1) * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__; /* Computing MIN */ i__3 = i__ + 2; zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, & taup[i__]); i__2 = i__; e[i__2] = alpha.r; i__2 = i__ + (i__ + 1) * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Apply G(i) to A(i+1:m,i+1:n) from the right */ i__2 = *m - i__; i__3 = *n - i__; zlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], 5L); i__2 = *n - i__; zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); i__2 = i__ + (i__ + 1) * a_dim1; i__3 = i__; a[i__2].r = e[i__3], a[i__2].i = 0.; } else { i__2 = i__; taup[i__2].r = 0., taup[i__2].i = 0.; } /* L10: */ } } else { /* Reduce to lower bidiagonal form */ i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector G(i) to annihilate A(i, i+1:n) */ i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, & taup[i__]); i__2 = i__; d__[i__2] = alpha.r; i__2 = i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Apply G(i) to A(i+1:m,i:n) from the right */ i__2 = *m - i__; i__3 = *n - i__ + 1; /* Computing MIN */ i__4 = i__ + 1; zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &taup[ i__], &a[min(i__4,*m) + i__ * a_dim1], lda, &work[1], 5L); i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ + i__ * a_dim1; i__3 = i__; a[i__2].r = d__[i__3], a[i__2].i = 0.; if (i__ < *m) { /* Generate elementary reflector H(i) to annihila te */ /* A(i+2:m,i) */ i__2 = i__ + 1 + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *m - i__; /* Computing MIN */ i__3 = i__ + 2; zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &tauq[i__]); i__2 = i__; e[i__2] = alpha.r; i__2 = i__ + 1 + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Apply H(i)' to A(i+1:m,i+1:n) from the left */ i__2 = *m - i__; i__3 = *n - i__; d_cnjg(&z__1, &tauq[i__]); zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & c__1, &z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, & work[1], 4L); i__2 = i__ + 1 + i__ * a_dim1; i__3 = i__; a[i__2].r = e[i__3], a[i__2].i = 0.; } else { i__2 = i__; tauq[i__2].r = 0., tauq[i__2].i = 0.; } /* L20: */ } } return 0; /* End of ZGEBD2 */ } /* zgebd2_ */ /* zdrot.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zdrot_(n, cx, incx, cy, incy, c__, s) integer *n; doublecomplex *cx; integer *incx; doublecomplex *cy; integer *incy; doublereal *c__, *s; { /* System generated locals */ integer i__1, i__2, i__3, i__4; doublecomplex z__1, z__2, z__3; /* Local variables */ static integer i__; static doublecomplex ctemp; static integer ix, iy; /* applies a plane rotation, where the cos and sin (c and s) are real */ /* and the vectors cx and cy are complex. */ /* jack dongarra, linpack, 3/11/78. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* ===================================================================== */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --cy; --cx; /* Function Body */ if (*n <= 0) { return 0; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments not equal */ /* to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = ix; z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i; i__3 = iy; z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__2 = iy; i__3 = iy; z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i; i__4 = ix; z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; cy[i__2].r = z__1.r, cy[i__2].i = z__1.i; i__2 = ix; cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; ix += *incx; iy += *incy; /* L10: */ } return 0; /* code for both increments equal to 1 */ L20: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i; i__3 = i__; z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__2 = i__; i__3 = i__; z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i; i__4 = i__; z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; cy[i__2].r = z__1.r, cy[i__2].i = z__1.i; i__2 = i__; cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; /* L30: */ } return 0; } /* zdrot_ */ /* zlarft.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2a /* Subroutine */ int zlarft_(direct, storev, n, k, v, ldv, tau, t, ldt, direct_len, storev_len) char *direct, *storev; integer *n, *k; doublecomplex *v; integer *ldv; doublecomplex *tau, *t; integer *ldt; ftnlen direct_len; ftnlen storev_len; { /* System generated locals */ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; doublecomplex z__1; /* Local variables */ static integer i__, j; extern logical lsame_(); extern /* Subroutine */ int zgemv_(), ztrmv_(), zlacgv_(); static doublecomplex vii; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLARFT forms the triangular factor T of a complex block reflector H */ /* of order n, which is defined as a product of k elementary reflectors. */ /* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ /* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ /* If STOREV = 'C', the vector which defines the elementary reflector */ /* H(i) is stored in the i-th column of the array V, and */ /* H = I - V * T * V' */ /* If STOREV = 'R', the vector which defines the elementary reflector */ /* H(i) is stored in the i-th row of the array V, and */ /* H = I - V' * T * V */ /* Arguments */ /* ========= */ /* DIRECT (input) CHARACTER*1 */ /* Specifies the order in which the elementary reflectors are */ /* multiplied to form the block reflector: */ /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ /* STOREV (input) CHARACTER*1 */ /* Specifies how the vectors which define the elementary */ /* reflectors are stored (see also Further Details): */ /* = 'C': columnwise */ /* = 'R': rowwise */ /* N (input) INTEGER */ /* The order of the block reflector H. N >= 0. */ /* K (input) INTEGER */ /* The order of the triangular factor T (= the number of */ /* elementary reflectors). K >= 1. */ /* V (input/output) COMPLEX*16 array, dimension */ /* (LDV,K) if STOREV = 'C' */ /* (LDV,N) if STOREV = 'R' */ /* The matrix V. See further details. */ /* LDV (input) INTEGER */ /* The leading dimension of the array V. */ /* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ /* TAU (input) COMPLEX*16 array, dimension (K) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i). */ /* T (output) COMPLEX*16 array, dimension (LDT,K) */ /* The k by k triangular factor T of the block reflector. */ /* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ /* lower triangular. The rest of the array is not used. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= K. */ /* Further Details */ /* =============== */ /* The shape of the matrix V and the storage of the vectors which define */ /* the H(i) is best illustrated by the following example with n = 5 and */ /* k = 3. The elements equal to 1 are not stored; the corresponding */ /* array elements are modified but restored on exit. The rest of the */ /* array is not used. */ /* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ /* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ /* ( v1 1 ) ( 1 v2 v2 v2 ) */ /* ( v1 v2 1 ) ( 1 v3 v3 ) */ /* ( v1 v2 v3 ) */ /* ( v1 v2 v3 ) */ /* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ /* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ /* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ /* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ /* ( 1 v3 ) */ /* ( 1 ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* Parameter adjustments */ v_dim1 = *ldv; v_offset = v_dim1 + 1; v -= v_offset; --tau; t_dim1 = *ldt; t_offset = t_dim1 + 1; t -= t_offset; /* Function Body */ if (*n == 0) { return 0; } if (lsame_(direct, "F", 1L, 1L)) { i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; if (tau[i__2].r == 0. && tau[i__2].i == 0.) { /* H(i) = I */ i__2 = i__; for (j = 1; j <= i__2; ++j) { i__3 = j + i__ * t_dim1; t[i__3].r = 0., t[i__3].i = 0.; /* L10: */ } } else { /* general case */ i__2 = i__ + i__ * v_dim1; vii.r = v[i__2].r, vii.i = v[i__2].i; i__2 = i__ + i__ * v_dim1; v[i__2].r = 1., v[i__2].i = 0.; if (lsame_(storev, "C", 1L, 1L)) { /* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */ i__2 = *n - i__ + 1; i__3 = i__ - 1; i__4 = i__; z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, & c_b2, &t[i__ * t_dim1 + 1], &c__1, 19L); } else { /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */ if (i__ < *n) { i__2 = *n - i__; zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); } i__2 = i__ - 1; i__3 = *n - i__ + 1; i__4 = i__; z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; zgemv_("No transpose", &i__2, &i__3, &z__1, &v[i__ * v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & c_b2, &t[i__ * t_dim1 + 1], &c__1, 12L); if (i__ < *n) { i__2 = *n - i__; zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); } } i__2 = i__ + i__ * v_dim1; v[i__2].r = vii.r, v[i__2].i = vii.i; /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ i__2 = i__ - 1; ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, 5L, 12L, 8L); i__2 = i__ + i__ * t_dim1; i__3 = i__; t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; } /* L20: */ } } else { for (i__ = *k; i__ >= 1; --i__) { i__1 = i__; if (tau[i__1].r == 0. && tau[i__1].i == 0.) { /* H(i) = I */ i__1 = *k; for (j = i__; j <= i__1; ++j) { i__2 = j + i__ * t_dim1; t[i__2].r = 0., t[i__2].i = 0.; /* L30: */ } } else { /* general case */ if (i__ < *k) { if (lsame_(storev, "C", 1L, 1L)) { i__1 = *n - *k + i__ + i__ * v_dim1; vii.r = v[i__1].r, vii.i = v[i__1].i; i__1 = *n - *k + i__ + i__ * v_dim1; v[i__1].r = 1., v[i__1].i = 0.; /* T(i+1:k,i) := */ /* - tau(i) * V(1:n-k+i,i+1 :k)' * V(1:n-k+i,i) */ i__1 = *n - *k + i__; i__2 = *k - i__; i__3 = i__; z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[ (i__ + 1) * v_dim1 + 1], ldv, &v[i__ * v_dim1 + 1], &c__1, &c_b2, &t[i__ + 1 + i__ * t_dim1] , &c__1, 19L); i__1 = *n - *k + i__ + i__ * v_dim1; v[i__1].r = vii.r, v[i__1].i = vii.i; } else { i__1 = i__ + (*n - *k + i__) * v_dim1; vii.r = v[i__1].r, vii.i = v[i__1].i; i__1 = i__ + (*n - *k + i__) * v_dim1; v[i__1].r = 1., v[i__1].i = 0.; /* T(i+1:k,i) := */ /* - tau(i) * V(i+1:k,1:n-k +i) * V(i,1:n-k+i)' */ i__1 = *n - *k + i__ - 1; zlacgv_(&i__1, &v[i__ + v_dim1], ldv); i__1 = *k - i__; i__2 = *n - *k + i__; i__3 = i__; z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; zgemv_("No transpose", &i__1, &i__2, &z__1, &v[i__ + 1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, & c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1, 12L); i__1 = *n - *k + i__ - 1; zlacgv_(&i__1, &v[i__ + v_dim1], ldv); i__1 = i__ + (*n - *k + i__) * v_dim1; v[i__1].r = vii.r, v[i__1].i = vii.i; } /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k, i) */ i__1 = *k - i__; ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1], &c__1, 5L, 12L, 8L); } i__1 = i__ + i__ * t_dim1; i__2 = i__; t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; } /* L40: */ } } return 0; /* End of ZLARFT */ } /* zlarft_ */ /* zunghr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zunghr_(n, ilo, ihi, a, lda, tau, work, lwork, info) integer *n, *ilo, *ihi; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i__, j, iinfo, nh; extern /* Subroutine */ int xerbla_(), zungqr_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNGHR generates a complex unitary matrix Q which is defined as the */ /* product of IHI-ILO elementary reflectors of order N, as returned by */ /* ZGEHRD: */ /* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix Q. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* ILO and IHI must have the same values as in the previous call */ /* of ZGEHRD. Q is equal to the unit matrix except in the */ /* submatrix Q(ilo+1:ihi,ilo+1:ihi). */ /* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the vectors which define the elementary reflectors, */ /* as returned by ZGEHRD. */ /* On exit, the N-by-N unitary matrix Q. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* TAU (input) COMPLEX*16 array, dimension (N-1) */ /* TAU(i) must contain the scalar factor of the elementary */ /* reflector H(i), as returned by ZGEHRD. */ /* 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 >= IHI-ILO. */ /* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */ /* the optimal blocksize. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -2; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = 1, i__2 = *ihi - *ilo; if (*lwork < max(i__1,i__2)) { *info = -8; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNGHR", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n == 0) { work[1].r = 1., work[1].i = 0.; return 0; } /* Shift the vectors which define the elementary reflectors one */ /* column to the right, and set the first ilo and the last n-ihi */ /* rows and columns to those of the unit matrix */ i__1 = *ilo + 1; for (j = *ihi; j >= i__1; --j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ } i__2 = *ihi; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + (j - 1) * a_dim1; a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; /* L20: */ } i__2 = *n; for (i__ = *ihi + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L30: */ } /* L40: */ } i__1 = *ilo; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L50: */ } i__2 = j + j * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* L60: */ } i__1 = *n; for (j = *ihi + 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L70: */ } i__2 = j + j * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* L80: */ } nh = *ihi - *ilo; if (nh > 0) { /* Generate Q(ilo+1:ihi,ilo+1:ihi) */ zungqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[* ilo], &work[1], lwork, &iinfo); } return 0; /* End of ZUNGHR */ } /* zunghr_ */ /* zgehd2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgehd2_(n, ilo, ihi, a, lda, tau, work, info) integer *n, *ilo, *ihi; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer i__; static doublecomplex alpha; extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H */ /* by a unitary similarity transformation: Q' * A * Q = H . */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that A is already upper triangular in rows */ /* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ /* set by a previous call to ZGEBAL; otherwise they should be */ /* set to 1 and N respectively. See Further Details. */ /* 1 <= ILO <= IHI <= max(1,N). */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the n by n general matrix to be reduced. */ /* On exit, the upper triangle and the first subdiagonal of A */ /* are overwritten with the upper Hessenberg matrix H, and the */ /* elements below the first subdiagonal, with the array TAU, */ /* represent the unitary matrix Q as a product of elementary */ /* reflectors. See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* TAU (output) COMPLEX*16 array, dimension (N-1) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX*16 array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of (ihi-ilo) elementary */ /* reflectors */ /* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ /* exit in A(i+2:ihi,i), and tau in TAU(i). */ /* The contents of A are illustrated by the following example, with */ /* n = 7, ilo = 2 and ihi = 6: */ /* on entry, on exit, */ /* ( a a a a a a a ) ( a a h h h h a ) */ /* ( a a a a a a ) ( a h h h h a ) */ /* ( a a a a a a ) ( h h h h h h ) */ /* ( a a a a a a ) ( v2 h h h h h ) */ /* ( a a a a a a ) ( v2 v3 h h h h ) */ /* ( a a a a a a ) ( v2 v3 v4 h h h ) */ /* ( a ) ( a ) */ /* where a denotes an element of the original matrix A, h denotes a */ /* modified element of the upper Hessenberg matrix H, and vi denotes an */ /* element of the vector defining H(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -2; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEHD2", &i__1, 6L); return 0; } i__1 = *ihi - 1; for (i__ = *ilo; i__ <= i__1; ++i__) { /* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */ i__2 = i__ + 1 + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *ihi - i__; /* Computing MIN */ i__3 = i__ + 2; zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[ i__]); i__2 = i__ + 1 + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Apply H(i) to A(1:ihi,i+1:ihi) from the right */ i__2 = *ihi - i__; zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1], 5L); /* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */ i__2 = *ihi - i__; i__3 = *n - i__; d_cnjg(&z__1, &tau[i__]); zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], 4L); i__2 = i__ + 1 + i__ * a_dim1; a[i__2].r = alpha.r, a[i__2].i = alpha.i; /* L10: */ } return 0; /* End of ZGEHD2 */ } /* zgehd2_ */ /* zladiv.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Double Complex */ VOID zladiv_( ret_val, x, y) doublecomplex * ret_val; doublecomplex *x, *y; { /* System generated locals */ doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; /* Builtin functions */ double d_imag(); /* Local variables */ static doublereal zi; extern /* Subroutine */ int dladiv_(); static doublereal zr; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y */ /* will not overflow on an intermediary step unless the results */ /* overflows. */ /* Arguments */ /* ========= */ /* X (input) COMPLEX*16 */ /* Y (input) COMPLEX*16 */ /* The complex scalars X and Y. */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ d__1 = x->r; d__2 = d_imag(x); d__3 = y->r; d__4 = d_imag(y); dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi); z__1.r = zr, z__1.i = zi; ret_val->r = z__1.r, ret_val->i = z__1.i; return ; /* End of ZLADIV */ } /* zladiv_ */ /* zgebrd.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1a /* Subroutine */ int zgebrd_(m, n, a, lda, d__, e, tauq, taup, work, lwork, info) integer *m, *n; doublecomplex *a; integer *lda; doublereal *d__, *e; doublecomplex *tauq, *taup, *work; integer *lwork, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1; /* Local variables */ static integer i__, j, nbmin, iinfo, minmn; extern /* Subroutine */ int zgemm_(), zgebd2_(); static integer nb, nx; static doublereal ws; extern /* Subroutine */ int xerbla_(), zlabrd_(); extern integer ilaenv_(); static integer ldwrkx, ldwrky; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower */ /* bidiagonal form B by a unitary transformation: Q**H * A * P = B. */ /* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows in the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns in the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the M-by-N general matrix to be reduced. */ /* On exit, */ /* if m >= n, the diagonal and the first superdiagonal are */ /* overwritten with the upper bidiagonal matrix B; the */ /* elements below the diagonal, with the array TAUQ, represent */ /* the unitary matrix Q as a product of elementary */ /* reflectors, and the elements above the first superdiagonal, */ /* with the array TAUP, represent the unitary matrix P as */ /* a product of elementary reflectors; */ /* if m < n, the diagonal and the first subdiagonal are */ /* overwritten with the lower bidiagonal matrix B; the */ /* elements below the first subdiagonal, with the array TAUQ, */ /* represent the unitary matrix Q as a product of */ /* elementary reflectors, and the elements above the diagonal, */ /* with the array TAUP, represent the unitary matrix P as */ /* a product of elementary reflectors. */ /* See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ /* The diagonal elements of the bidiagonal matrix B: */ /* D(i) = A(i,i). */ /* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ /* The off-diagonal elements of the bidiagonal matrix B: */ /* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ /* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ /* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix Q. See Further Details. */ /* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix P. See Further Details. */ /* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The length of the array WORK. LWORK >= max(1,M,N). */ /* For optimum performance LWORK >= (M+N)*NB, where NB */ /* is the optimal blocksize. */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* Further Details */ /* =============== */ /* The matrices Q and P are represented as products of elementary */ /* reflectors: */ /* If m >= n, */ /* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ /* Each H(i) and G(i) has the form: */ /* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ /* where tauq and taup are complex scalars, and v and u are complex */ /* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */ /* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */ /* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* If m < n, */ /* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ /* Each H(i) and G(i) has the form: */ /* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ /* where tauq and taup are complex scalars, and v and u are complex */ /* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in */ /* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in */ /* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* The contents of A on exit are illustrated by the following examples: */ /* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ /* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ /* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ /* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ /* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ /* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ /* ( v1 v2 v3 v4 v5 ) */ /* where d and e denote diagonal and off-diagonal elements of B, vi */ /* denotes an element of the vector defining H(i), and ui an element of */ /* the vector defining G(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --d__; --e; --tauq; --taup; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = max(1,*m); if (*lwork < max(i__1,*n)) { *info = -10; } } if (*info < 0) { i__1 = -(*info); xerbla_("ZGEBRD", &i__1, 6L); return 0; } /* Quick return if possible */ minmn = min(*m,*n); if (minmn == 0) { work[1].r = 1., work[1].i = 0.; return 0; } ws = (doublereal) max(*m,*n); ldwrkx = *m; ldwrky = *n; /* Set the block size NB and the crossover point NX. */ /* Computing MAX */ i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L) ; nb = max(i__1,i__2); if (nb > 1 && nb < minmn) { /* Determine when to switch from blocked to unblocked code. */ /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L); nx = max(i__1,i__2); if (nx < minmn) { ws = (doublereal) ((*m + *n) * nb); if ((doublereal) (*lwork) < ws) { /* Not enough work space for the optimal NB, cons ider using */ /* a smaller block size. */ nbmin = ilaenv_(&c__2, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L); if (*lwork >= (*m + *n) * nbmin) { nb = *lwork / (*m + *n); } else { nb = 1; nx = minmn; } } } } else { nx = minmn; } i__1 = minmn - nx; i__2 = nb; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Reduce rows and columns i:i+ib-1 to bidiagonal form and retu rn */ /* the matrices X and Y which are needed to update the unreduce d */ /* part of the matrix */ i__3 = *m - i__ + 1; i__4 = *n - i__ + 1; zlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx * nb + 1], &ldwrky); /* Update the trailing submatrix A(i+ib:m,i+ib:n), using */ /* an update of the form A := A - V*Y' - X*U' */ i__3 = *m - i__ - nb + 1; i__4 = *n - i__ - nb + 1; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "Conjugate transpose", &i__3, &i__4, &nb, & z__1, &a[i__ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], &ldwrky, &c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], lda, 12L, 19L); i__3 = *m - i__ - nb + 1; i__4 = *n - i__ - nb + 1; z__1.r = -1., z__1.i = 0.; zgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &z__1, & work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], lda, 12L, 12L); /* Copy diagonal and off-diagonal elements of B back into A */ if (*m >= *n) { i__3 = i__ + nb - 1; for (j = i__; j <= i__3; ++j) { i__4 = j + j * a_dim1; i__5 = j; a[i__4].r = d__[i__5], a[i__4].i = 0.; i__4 = j + (j + 1) * a_dim1; i__5 = j; a[i__4].r = e[i__5], a[i__4].i = 0.; /* L10: */ } } else { i__3 = i__ + nb - 1; for (j = i__; j <= i__3; ++j) { i__4 = j + j * a_dim1; i__5 = j; a[i__4].r = d__[i__5], a[i__4].i = 0.; i__4 = j + 1 + j * a_dim1; i__5 = j; a[i__4].r = e[i__5], a[i__4].i = 0.; /* L20: */ } } /* L30: */ } /* Use unblocked code to reduce the remainder of the matrix */ i__2 = *m - i__ + 1; i__1 = *n - i__ + 1; zgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], & tauq[i__], &taup[i__], &work[1], &iinfo); work[1].r = ws, work[1].i = 0.; return 0; /* End of ZGEBRD */ } /* zgebrd_ */ /* zgeqr2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgeqr2_(m, n, a, lda, tau, work, info) integer *m, *n; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1; /* Builtin functions */ void d_cnjg(); /* Local variables */ static integer i__, k; static doublecomplex alpha; extern /* Subroutine */ int zlarf_(), xerbla_(), zlarfg_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEQR2 computes a QR factorization of a complex m by n matrix A: */ /* A = Q * R. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the m by n matrix A. */ /* On exit, the elements on and above the diagonal of the array */ /* contain the min(m,n) by n upper trapezoidal matrix R (R is */ /* upper triangular if m >= n); the elements below the diagonal, */ /* with the array TAU, represent the unitary matrix Q as a */ /* product of elementary reflectors (see Further Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace) COMPLEX*16 array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(1) H(2) . . . H(k), where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */ /* and tau in TAU(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEQR2", &i__1, 6L); return 0; } k = min(*m,*n); i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { /* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ i__2 = *m - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; zlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1] , &c__1, &tau[i__]); if (i__ < *n) { /* Apply H(i)' to A(i:m,i+1:n) from the left */ i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; i__2 = *m - i__ + 1; i__3 = *n - i__; d_cnjg(&z__1, &tau[i__]); zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L); i__2 = i__ + i__ * a_dim1; a[i__2].r = alpha.r, a[i__2].i = alpha.i; } /* L10: */ } return 0; /* End of ZGEQR2 */ } /* zgeqr2_ */ /* zgetf2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1a /* Subroutine */ int zgetf2_(m, n, a, lda, ipiv, info) integer *m, *n; doublecomplex *a; integer *lda, *ipiv, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1; /* Builtin functions */ void z_div(); /* Local variables */ static integer j; extern /* Subroutine */ int zscal_(), zgeru_(), zswap_(); static integer jp; extern /* Subroutine */ int xerbla_(); extern integer izamax_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGETF2 computes an LU factorization of a general m-by-n matrix A */ /* using partial pivoting with row interchanges. */ /* The factorization has the form */ /* A = P * L * U */ /* where P is a permutation matrix, L is lower triangular with unit */ /* diagonal elements (lower trapezoidal if m > n), and U is upper */ /* triangular (upper trapezoidal if m < n). */ /* This is the right-looking Level 2 BLAS version of the algorithm. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the m by n matrix to be factored. */ /* On exit, the factors L and U from the factorization */ /* A = P*L*U; the unit diagonal elements of L are not stored. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* IPIV (output) INTEGER array, dimension (min(M,N)) */ /* The pivot indices; for 1 <= i <= min(M,N), row i of the */ /* matrix was interchanged with row IPIV(i). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -k, the k-th argument had an illegal value */ /* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */ /* has been completed, but the factor U is exactly */ /* singular, and division by zero will occur if it is used */ /* to solve a system of equations. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --ipiv; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGETF2", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } i__1 = min(*m,*n); for (j = 1; j <= i__1; ++j) { /* Find pivot and test for singularity. */ i__2 = *m - j + 1; jp = j - 1 + izamax_(&i__2, &a[j + j * a_dim1], &c__1); ipiv[j] = jp; i__2 = jp + j * a_dim1; if (a[i__2].r != 0. || a[i__2].i != 0.) { /* Apply the interchange to columns 1:N. */ if (jp != j) { zswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); } /* Compute elements J+1:M of J-th column. */ if (j < *m) { i__2 = *m - j; z_div(&z__1, &c_b1, &a[j + j * a_dim1]); zscal_(&i__2, &z__1, &a[j + 1 + j * a_dim1], &c__1); } } else if (*info == 0) { *info = j; } if (j < min(*m,*n)) { /* Update trailing submatrix. */ i__2 = *m - j; i__3 = *n - j; z__1.r = -1., z__1.i = 0.; zgeru_(&i__2, &i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda) ; } /* L10: */ } return 0; /* End of ZGETF2 */ } /* zgetf2_ */ /* zgetrs.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1a /* Subroutine */ int zgetrs_(trans, n, nrhs, a, lda, ipiv, b, ldb, info, trans_len) char *trans; integer *n, *nrhs; doublecomplex *a; integer *lda, *ipiv; doublecomplex *b; integer *ldb, *info; ftnlen trans_len; { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1; /* Local variables */ extern logical lsame_(); extern /* Subroutine */ int ztrsm_(), xerbla_(); static logical notran; extern /* Subroutine */ int zlaswp_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGETRS solves a system of linear equations */ /* A * X = B, A**T * X = B, or A**H * X = B */ /* with a general N-by-N matrix A using the LU factorization computed */ /* by ZGETRF. */ /* Arguments */ /* ========= */ /* TRANS (input) CHARACTER*1 */ /* Specifies the form of the system of equations: */ /* = 'N': A * X = B (No transpose) */ /* = 'T': A**T * X = B (Transpose) */ /* = 'C': A**H * X = B (Conjugate transpose) */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrix B. NRHS >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The factors L and U from the factorization A = P*L*U */ /* as computed by ZGETRF. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices from ZGETRF; for 1<=i<=N, row i of the */ /* matrix was interchanged with row IPIV(i). */ /* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */ /* On entry, the right hand side matrix B. */ /* On exit, the solution matrix X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --ipiv; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; /* Function Body */ *info = 0; notran = lsame_(trans, "N", 1L, 1L); if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGETRS", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { return 0; } if (notran) { /* Solve A * X = B. */ /* Apply row interchanges to the right hand sides. */ zlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); /* Solve L*X = B, overwriting B with X. */ ztrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b1, &a[ a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 4L); /* Solve U*X = B, overwriting B with X. */ ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, & a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 8L); } else { /* Solve A**T * X = B or A**H * X = B. */ /* Solve U'*X = B, overwriting B with X. */ ztrsm_("Left", "Upper", trans, "Non-unit", n, nrhs, &c_b1, &a[ a_offset], lda, &b[b_offset], ldb, 4L, 5L, 1L, 8L); /* Solve L'*X = B, overwriting B with X. */ ztrsm_("Left", "Lower", trans, "Unit", n, nrhs, &c_b1, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 1L, 4L); /* Apply row interchanges to the solution vectors. */ zlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); } return 0; /* End of ZGETRS */ } /* zgetrs_ */ /* zlasr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlasr_(side, pivot, direct, m, n, c__, s, a, lda, side_len, pivot_len, direct_len) char *side, *pivot, *direct; integer *m, *n; doublereal *c__, *s; doublecomplex *a; integer *lda; ftnlen side_len; ftnlen pivot_len; ftnlen direct_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; doublecomplex z__1, z__2, z__3; /* Local variables */ static integer info; static doublecomplex temp; static integer i__, j; extern logical lsame_(); static doublereal ctemp, stemp; extern /* Subroutine */ int xerbla_(); /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLASR performs the transformation */ /* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) */ /* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) */ /* where A is an m by n complex matrix and P is an orthogonal matrix, */ /* consisting of a sequence of plane rotations determined by the */ /* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' */ /* and z = n when SIDE = 'R' or 'r' ): */ /* When DIRECT = 'F' or 'f' ( Forward sequence ) then */ /* P = P( z - 1 )*...*P( 2 )*P( 1 ), */ /* and when DIRECT = 'B' or 'b' ( Backward sequence ) then */ /* P = P( 1 )*P( 2 )*...*P( z - 1 ), */ /* where P( k ) is a plane rotation matrix for the following planes: */ /* when PIVOT = 'V' or 'v' ( Variable pivot ), */ /* the plane ( k, k + 1 ) */ /* when PIVOT = 'T' or 't' ( Top pivot ), */ /* the plane ( 1, k + 1 ) */ /* when PIVOT = 'B' or 'b' ( Bottom pivot ), */ /* the plane ( k, z ) */ /* c( k ) and s( k ) must contain the cosine and sine that define the */ /* matrix P( k ). The two by two plane rotation part of the matrix */ /* P( k ), R( k ), is assumed to be of the form */ /* R( k ) = ( c( k ) s( k ) ). */ /* ( -s( k ) c( k ) ) */ /* Arguments */ /* ========= */ /* SIDE (input) CHARACTER*1 */ /* Specifies whether the plane rotation matrix P is applied to */ /* A on the left or the right. */ /* = 'L': Left, compute A := P*A */ /* = 'R': Right, compute A:= A*P' */ /* DIRECT (input) CHARACTER*1 */ /* Specifies whether P is a forward or backward sequence of */ /* plane rotations. */ /* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) */ /* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) */ /* PIVOT (input) CHARACTER*1 */ /* Specifies the plane for which P(k) is a plane rotation */ /* matrix. */ /* = 'V': Variable pivot, the plane (k,k+1) */ /* = 'T': Top pivot, the plane (1,k+1) */ /* = 'B': Bottom pivot, the plane (k,z) */ /* M (input) INTEGER */ /* The number of rows of the matrix A. If m <= 1, an immediate */ /* return is effected. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. If n <= 1, an */ /* immediate return is effected. */ /* C, S (input) DOUBLE PRECISION arrays, dimension */ /* (M-1) if SIDE = 'L' */ /* (N-1) if SIDE = 'R' */ /* c(k) and s(k) contain the cosine and sine that define the */ /* matrix P(k). The two by two plane rotation part of the */ /* matrix P(k), R(k), is assumed to be of the form */ /* R( k ) = ( c( k ) s( k ) ). */ /* ( -s( k ) c( k ) ) */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* The m by n matrix A. On exit, A is overwritten by P*A if */ /* SIDE = 'R' or by A*P' if SIDE = 'L'. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ --c__; --s; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ info = 0; if (! (lsame_(side, "L", 1L, 1L) || lsame_(side, "R", 1L, 1L))) { info = 1; } else if (! (lsame_(pivot, "V", 1L, 1L) || lsame_(pivot, "T", 1L, 1L) || lsame_(pivot, "B", 1L, 1L))) { info = 2; } else if (! (lsame_(direct, "F", 1L, 1L) || lsame_(direct, "B", 1L, 1L))) { info = 3; } else if (*m < 0) { info = 4; } else if (*n < 0) { info = 5; } else if (*lda < max(1,*m)) { info = 9; } if (info != 0) { xerbla_("ZLASR ", &info, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } if (lsame_(side, "L", 1L, 1L)) { /* Form P * A */ if (lsame_(pivot, "V", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *m - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + 1 + i__ * a_dim1; temp.r = a[i__3].r, temp.i = a[i__3].i; i__3 = j + 1 + i__ * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__4 = j + i__ * a_dim1; z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ i__4].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; i__3 = j + i__ * a_dim1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__4 = j + i__ * a_dim1; z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ i__4].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L10: */ } } /* L20: */ } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *m - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = j + 1 + i__ * a_dim1; temp.r = a[i__2].r, temp.i = a[i__2].i; i__2 = j + 1 + i__ * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__3 = j + i__ * a_dim1; z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ i__3].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = j + i__ * a_dim1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__3 = j + i__ * a_dim1; z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L30: */ } } /* L40: */ } } } else if (lsame_(pivot, "T", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *m; for (j = 2; j <= i__1; ++j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + i__ * a_dim1; temp.r = a[i__3].r, temp.i = a[i__3].i; i__3 = j + i__ * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__4 = i__ * a_dim1 + 1; z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ i__4].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; i__3 = i__ * a_dim1 + 1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__4 = i__ * a_dim1 + 1; z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ i__4].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ } } /* L60: */ } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *m; j >= 2; --j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = j + i__ * a_dim1; temp.r = a[i__2].r, temp.i = a[i__2].i; i__2 = j + i__ * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__3 = i__ * a_dim1 + 1; z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ i__3].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = i__ * a_dim1 + 1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__3 = i__ * a_dim1 + 1; z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L70: */ } } /* L80: */ } } } else if (lsame_(pivot, "B", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *m - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + i__ * a_dim1; temp.r = a[i__3].r, temp.i = a[i__3].i; i__3 = j + i__ * a_dim1; i__4 = *m + i__ * a_dim1; z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ i__4].i; z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; i__3 = *m + i__ * a_dim1; i__4 = *m + i__ * a_dim1; z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ i__4].i; z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L90: */ } } /* L100: */ } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *m - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = j + i__ * a_dim1; temp.r = a[i__2].r, temp.i = a[i__2].i; i__2 = j + i__ * a_dim1; i__3 = *m + i__ * a_dim1; z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ i__3].i; z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = *m + i__ * a_dim1; i__3 = *m + i__ * a_dim1; z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ i__3].i; z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L110: */ } } /* L120: */ } } } } else if (lsame_(side, "R", 1L, 1L)) { /* Form A * P' */ if (lsame_(pivot, "V", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + (j + 1) * a_dim1; temp.r = a[i__3].r, temp.i = a[i__3].i; i__3 = i__ + (j + 1) * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__4 = i__ + j * a_dim1; z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ i__4].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; i__3 = i__ + j * a_dim1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__4 = i__ + j * a_dim1; z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ i__4].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L130: */ } } /* L140: */ } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *n - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + (j + 1) * a_dim1; temp.r = a[i__2].r, temp.i = a[i__2].i; i__2 = i__ + (j + 1) * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__3 = i__ + j * a_dim1; z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ i__3].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = i__ + j * a_dim1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__3 = i__ + j * a_dim1; z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L150: */ } } /* L160: */ } } } else if (lsame_(pivot, "T", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *n; for (j = 2; j <= i__1; ++j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; temp.r = a[i__3].r, temp.i = a[i__3].i; i__3 = i__ + j * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__4 = i__ + a_dim1; z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ i__4].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; i__3 = i__ + a_dim1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__4 = i__ + a_dim1; z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ i__4].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L170: */ } } /* L180: */ } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *n; j >= 2; --j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + j * a_dim1; temp.r = a[i__2].r, temp.i = a[i__2].i; i__2 = i__ + j * a_dim1; z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; i__3 = i__ + a_dim1; z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ i__3].i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = i__ + a_dim1; z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; i__3 = i__ + a_dim1; z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ i__3].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L190: */ } } /* L200: */ } } } else if (lsame_(pivot, "B", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; temp.r = a[i__3].r, temp.i = a[i__3].i; i__3 = i__ + j * a_dim1; i__4 = i__ + *n * a_dim1; z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ i__4].i; z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; i__3 = i__ + *n * a_dim1; i__4 = i__ + *n * a_dim1; z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ i__4].i; z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L210: */ } } /* L220: */ } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *n - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + j * a_dim1; temp.r = a[i__2].r, temp.i = a[i__2].i; i__2 = i__ + j * a_dim1; i__3 = i__ + *n * a_dim1; z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ i__3].i; z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = i__ + *n * a_dim1; i__3 = i__ + *n * a_dim1; z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ i__3].i; z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L230: */ } } /* L240: */ } } } } return 0; /* End of ZLASR */ } /* zlasr_ */ /* zgelss.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1 #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 #ifdef c_b78 #undef c_b78 #endif #define c_b78 c_b78 /* Subroutine */ int zgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, rwork, info) integer *m, *n, *nrhs; doublecomplex *a; integer *lda; doublecomplex *b; integer *ldb; doublereal *s, *rcond; integer *rank; doublecomplex *work; integer *lwork; doublereal *rwork; integer *info; { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; doublereal d__1; /* Local variables */ static doublereal anrm, bnrm; static integer itau; static doublecomplex vdum[1]; static integer i__, iascl, ibscl, chunk; static doublereal sfmin; static integer minmn; extern /* Subroutine */ int zgemm_(); static integer maxmn, itaup, itauq, mnthr; extern /* Subroutine */ int zgemv_(); static integer iwork; extern /* Subroutine */ int zcopy_(), dlabad_(); static integer bl, ie, il; extern doublereal dlamch_(); static integer mm; extern /* Subroutine */ int dlascl_(), dlaset_(), xerbla_(), zgebrd_(); extern integer ilaenv_(); extern doublereal zlange_(); static doublereal bignum; extern /* Subroutine */ int zgelqf_(), zlascl_(), zgeqrf_(), zdrscl_(); static integer ldwork; extern /* Subroutine */ int zlacpy_(), zlaset_(), zbdsqr_(); static integer minwrk, maxwrk; extern /* Subroutine */ int zungbr_(); static doublereal smlnum; static integer irwork; extern /* Subroutine */ int zunmbr_(), zunmlq_(), zunmqr_(); static doublereal eps, thr; /* -- LAPACK driver routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGELSS computes the minimum norm solution to a complex linear */ /* least squares problem: */ /* Minimize 2-norm(| b - A*x |). */ /* using the singular value decomposition (SVD) of A. A is an M-by-N */ /* matrix which may be rank-deficient. */ /* Several right hand side vectors b and solution vectors x can be */ /* handled in a single call; they are stored as the columns of the */ /* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */ /* X. */ /* The effective rank of A is determined by treating as zero those */ /* singular values which are less than RCOND times the largest singular */ /* value. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, the first min(m,n) rows of A are overwritten with */ /* its right singular vectors, stored rowwise. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */ /* On entry, the M-by-NRHS right hand side matrix B. */ /* On exit, B is overwritten by the N-by-NRHS solution matrix X. */ /* If m >= n and RANK = n, the residual sum-of-squares for */ /* the solution in the i-th column is given by the sum of */ /* squares of elements n+1:m in that column. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,M,N). */ /* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ /* The singular values of A in decreasing order. */ /* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */ /* RCOND (input) DOUBLE PRECISION */ /* RCOND is used to determine the effective rank of A. */ /* Singular values S(i) <= RCOND*S(1) are treated as zero. */ /* If RCOND < 0, machine precision is used instead. */ /* RANK (output) INTEGER */ /* The effective rank of A, i.e., the number of singular values */ /* which are greater than RCOND*S(1). */ /* 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 >= 1, and also: */ /* LWORK >= 2*min(M,N) + max(M,N,NRHS) */ /* For good performance, LWORK should generally be larger. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)-1) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: the algorithm for computing the SVD failed to converge; */ /* if INFO = i, i off-diagonal elements of an intermediate */ /* bidiagonal form did not converge to zero. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; --s; --work; --rwork; /* Function Body */ *info = 0; minmn = min(*m,*n); maxmn = max(*m,*n); mnthr = ilaenv_(&c__6, "ZGELSS", " ", m, n, nrhs, &c_n1, 6L, 1L); if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else if (*ldb < max(1,maxmn)) { *info = -7; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* CWorkspace refers to complex workspace, and RWorkspace refers */ /* to real workspace. NB refers to the optimal block size for the */ /* immediately following subroutine, as returned by ILAENV.) */ minwrk = 1; if (*info == 0 && *lwork >= 1) { maxwrk = 0; mm = *m; if (*m >= *n && *m >= mnthr) { /* Path 1a - overdetermined, with many more rows than co lumns */ /* Space needed for ZBDSQR is BDSPAC = 5*N-1 */ mm = *n; /* Computing MAX */ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "ZUNMQR", "LT", m, nrhs, n, &c_n1, 6L, 2L); maxwrk = max(i__1,i__2); } if (*m >= *n) { /* Path 1 - overdetermined or exactly determined */ /* Space needed for ZBDSQR is BDSPC = 7*N+12 */ /* Computing MAX */ i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1, "ZGEBRD", " ", &mm, n, &c_n1, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1, "ZUNMBR", "QLC", &mm, nrhs, n, &c_n1, 6L, 3L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUN\ GBR", "P", n, n, n, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *n * *nrhs; maxwrk = max(i__1,i__2); minwrk = (*n << 1) + max(*nrhs,*m); } if (*n > *m) { minwrk = (*m << 1) + max(*nrhs,*n); if (*n >= mnthr) { /* Path 2a - underdetermined, with many more colu mns */ /* than rows */ /* Space needed for ZBDSQR is BDSPAC = 5*M-1 */ maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + *nrhs * ilaenv_(& c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1, 6L, 3L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m - 1) * ilaenv_(& c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); if (*nrhs > 1) { /* Computing MAX */ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; maxwrk = max(i__1,i__2); } else { /* Computing MAX */ i__1 = maxwrk, i__2 = *m * *m + (*m << 1); maxwrk = max(i__1,i__2); } /* Computing MAX */ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "ZUNMLQ", "LT", n, nrhs, m, &c_n1, 6L, 2L); maxwrk = max(i__1,i__2); } else { /* Path 2 - underdetermined */ /* Space needed for ZBDSQR is BDSPAC = 5*M-1 */ maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1, "ZUNMBR", "QLT", m, nrhs, m, &c_n1, 6L, 3L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR" , "P", m, n, m, &c_n1, 6L, 1L); maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *n * *nrhs; maxwrk = max(i__1,i__2); } } minwrk = max(minwrk,1); maxwrk = max(minwrk,maxwrk); work[1].r = (doublereal) maxwrk, work[1].i = 0.; } if (*lwork < minwrk) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGELSS", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { *rank = 0; return 0; } /* Get machine parameters */ eps = dlamch_("P", 1L); sfmin = dlamch_("S", 1L); smlnum = sfmin / eps; bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1], 1L); iascl = 0; if (anrm > 0. && anrm < smlnum) { /* Scale matrix norm up to SMLNUM */ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info, 1L); iascl = 1; } else if (anrm > bignum) { /* Scale matrix norm down to BIGNUM */ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, 1L); iascl = 2; } else if (anrm == 0.) { /* Matrix all zero. Return zero solution. */ i__1 = max(*m,*n); zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb, 1L); dlaset_("F", &minmn, &c__1, &c_b78, &c_b78, &s[1], &minmn, 1L); *rank = 0; goto L70; } /* Scale B if max element outside range [SMLNUM,BIGNUM] */ bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1], 1L); ibscl = 0; if (bnrm > 0. && bnrm < smlnum) { /* Scale matrix norm up to SMLNUM */ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info, 1L); ibscl = 1; } else if (bnrm > bignum) { /* Scale matrix norm down to BIGNUM */ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info, 1L); ibscl = 2; } /* Overdetermined case */ if (*m >= *n) { /* Path 1 - overdetermined or exactly determined */ mm = *m; if (*m >= mnthr) { /* Path 1a - overdetermined, with many more rows than co lumns */ mm = *n; itau = 1; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, info); /* Multiply B by transpose(Q) */ /* (CWorkspace: need N+NRHS, prefer N+NRHS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L); /* Zero out below R */ if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda, 1L); } } ie = 1; itauq = 1; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in A */ /* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */ /* (RWorkspace: need N) */ i__1 = *lwork - iwork + 1; zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], & work[itaup], &work[iwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors of R */ /* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L, 1L); /* Generate right bidiagonalizing vectors of R in A */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & i__1, info, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration */ /* multiply B by transpose of left singular vectors */ /* compute right singular vectors in A */ /* (CWorkspace: none) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda, vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info, 1L); if (*info != 0) { goto L70; } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ d__1 = *rcond * s[1]; thr = max(d__1,sfmin); if (*rcond < 0.) { /* Computing MAX */ d__1 = eps * s[1]; thr = max(d__1,sfmin); } *rank = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (s[i__] > thr) { zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); ++(*rank); } else { zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb, 1L); } /* L10: */ } /* Multiply B by right singular vectors */ /* (CWorkspace: need N, prefer N*NRHS) */ /* (RWorkspace: none) */ if (*lwork >= *ldb * *nrhs && *nrhs > 1) { zgemm_("C", "N", n, nrhs, n, &c_b2, &a[a_offset], lda, &b[ b_offset], ldb, &c_b1, &work[1], ldb, 1L, 1L); zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, 1L); } else if (*nrhs > 1) { chunk = *lwork / *n; i__1 = *nrhs; i__2 = chunk; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = *nrhs - i__ + 1; bl = min(i__3,chunk); zgemm_("C", "N", n, &bl, n, &c_b2, &a[a_offset], lda, &b[ b_offset], ldb, &c_b1, &work[1], n, 1L, 1L); zlacpy_("G", n, &bl, &work[1], n, &b[b_offset], ldb, 1L); /* L20: */ } } else { zgemv_("C", n, n, &c_b2, &a[a_offset], lda, &b[b_offset], &c__1, & c_b1, &work[1], &c__1, 1L); zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); } } else /* if(complicated condition) */ { /* Computing MAX */ i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1); if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) { /* Underdetermined case, M much less than N */ /* Path 2a - underdetermined, with many more columns than r ows */ /* and sufficient workspace for an efficient algorithm */ ldwork = *m; /* Computing MAX */ i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1); if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) { ldwork = *lda; } itau = 1; iwork = *m + 1; /* Compute A=L*Q */ /* (CWorkspace: need 2*M, prefer M+M*NB) */ /* (RWorkspace: none) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, info); il = iwork; /* Copy L to WORK(IL), zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork, 1L); i__2 = *m - 1; i__1 = *m - 1; zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwork], & ldwork, 1L); ie = 1; itauq = il + ldwork * *m; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IL) */ /* (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], &i__2, info); /* Multiply B by transpose of left bidiagonalizing vectors of L */ /* (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB) */ /* (RWorkspace: none) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[ itauq], &b[b_offset], ldb, &work[iwork], &i__2, info, 1L, 1L, 1L); /* Generate right bidiagonalizing vectors of R in WORK(IL) */ /* (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ /* (RWorkspace: none) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ iwork], &i__2, info, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing right singula r */ /* vectors of L in WORK(IL) and multiplying B by transpose of */ /* left singular vectors */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, &c__0, nrhs, &s[1], &rwork[ie], &work[il], & ldwork, &a[a_offset], lda, &b[b_offset], ldb, &rwork[ irwork], info, 1L); if (*info != 0) { goto L70; } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ d__1 = *rcond * s[1]; thr = max(d__1,sfmin); if (*rcond < 0.) { /* Computing MAX */ d__1 = eps * s[1]; thr = max(d__1,sfmin); } *rank = 0; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { if (s[i__] > thr) { zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); ++(*rank); } else { zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb, 1L); } /* L30: */ } iwork = il + *m * ldwork; /* Multiply B by right singular vectors of L in WORK(IL) */ /* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ /* (RWorkspace: none) */ if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { zgemm_("C", "N", m, nrhs, m, &c_b2, &work[il], &ldwork, &b[ b_offset], ldb, &c_b1, &work[iwork], ldb, 1L, 1L); zlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb, 1L); } else if (*nrhs > 1) { chunk = (*lwork - iwork + 1) / *m; i__2 = *nrhs; i__1 = chunk; for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { /* Computing MIN */ i__3 = *nrhs - i__ + 1; bl = min(i__3,chunk); zgemm_("C", "N", m, &bl, m, &c_b2, &work[il], &ldwork, &b[ i__ * b_dim1 + 1], ldb, &c_b1, &work[iwork], n, 1L, 1L); zlacpy_("G", m, &bl, &work[iwork], n, &b[b_offset], ldb, 1L); /* L40: */ } } else { zgemv_("C", m, m, &c_b2, &work[il], &ldwork, &b[b_dim1 + 1], & c__1, &c_b1, &work[iwork], &c__1, 1L); zcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); } /* Zero out below first M rows of B */ i__1 = *n - *m; zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb, 1L); iwork = itau + *m; /* Multiply transpose(Q) by B */ /* (CWorkspace: need M+NRHS, prefer M+NHRS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L); } else { /* Path 2 - remaining underdetermined cases */ ie = 1; itauq = 1; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize A */ /* (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB) */ /* (RWorkspace: need N) */ i__1 = *lwork - iwork + 1; zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], &i__1, info); /* Multiply B by transpose of left bidiagonalizing vectors */ /* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq] , &b[b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L, 1L); /* Generate right bidiagonalizing vectors in A */ /* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ /* (RWorkspace: none) */ i__1 = *lwork - iwork + 1; zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ iwork], &i__1, info, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, */ /* computing right singular vectors of A in A and */ /* multiplying B by transpose of left singular vectors */ /* (CWorkspace: none) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("L", m, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda, vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info, 1L); if (*info != 0) { goto L70; } /* Multiply B by reciprocals of singular values */ /* Computing MAX */ d__1 = *rcond * s[1]; thr = max(d__1,sfmin); if (*rcond < 0.) { /* Computing MAX */ d__1 = eps * s[1]; thr = max(d__1,sfmin); } *rank = 0; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (s[i__] > thr) { zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); ++(*rank); } else { zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb, 1L); } /* L50: */ } /* Multiply B by right singular vectors of A */ /* (CWorkspace: need N, prefer N*NRHS) */ /* (RWorkspace: none) */ if (*lwork >= *ldb * *nrhs && *nrhs > 1) { zgemm_("C", "N", n, nrhs, m, &c_b2, &a[a_offset], lda, &b[ b_offset], ldb, &c_b1, &work[1], ldb, 1L, 1L); zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, 1L); } else if (*nrhs > 1) { chunk = *lwork / *n; i__1 = *nrhs; i__2 = chunk; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = *nrhs - i__ + 1; bl = min(i__3,chunk); zgemm_("C", "N", n, &bl, m, &c_b2, &a[a_offset], lda, &b[ i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n, 1L, 1L); zlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb, 1L); /* L60: */ } } else { zgemv_("C", m, n, &c_b2, &a[a_offset], lda, &b[b_offset], & c__1, &c_b1, &work[1], &c__1, 1L); zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); } } } /* Undo scaling */ if (iascl == 1) { zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info, 1L); dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & minmn, info, 1L); } else if (iascl == 2) { zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info, 1L); dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & minmn, info, 1L); } if (ibscl == 1) { zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info, 1L); } else if (ibscl == 2) { zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info, 1L); } L70: work[1].r = (doublereal) maxwrk, work[1].i = 0.; return 0; /* End of ZGELSS */ } /* zgelss_ */ /* zbdsqr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b15 #undef c_b15 #endif #define c_b15 c_b15 #ifdef c_b48 #undef c_b48 #endif #define c_b48 c_b48 #ifdef c_b71 #undef c_b71 #endif #define c_b71 c_b71 /* Subroutine */ int zbdsqr_(uplo, n, ncvt, nru, ncc, d__, e, vt, ldvt, u, ldu, c__, ldc, rwork, info, uplo_len) char *uplo; integer *n, *ncvt, *nru, *ncc; doublereal *d__, *e; doublecomplex *vt; integer *ldvt; doublecomplex *u; integer *ldu; doublecomplex *c__; integer *ldc; doublereal *rwork; integer *info; ftnlen uplo_len; { /* 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(), sqrt(), d_sign(); /* 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; static integer irot; extern /* Subroutine */ int dlas2_(); static doublereal f, g, h__; static integer i__, j, m; static doublereal r__; extern logical lsame_(); static doublereal oldcs; static integer oldll; static doublereal shift, sigmn, oldsn; static integer maxit; static doublereal sminl, sigmx; static integer iuplo; extern /* Subroutine */ int zlasr_(), zdrot_(), zswap_(), dlasq1_(), dlasv2_(); static doublereal cs; static integer ll; extern doublereal dlamch_(); static doublereal sn, mu; extern /* Subroutine */ int dlartg_(), xerbla_(), zdscal_(); 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; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* 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 */ /* 2*N if only singular values wanted (NCVT = NRU = NCC = 0) */ /* max( 1, 4*N-4 ) otherwise */ /* 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. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --d__; --e; vt_dim1 = *ldvt; vt_offset = vt_dim1 + 1; vt -= vt_offset; u_dim1 = *ldu; u_offset = u_dim1 + 1; u -= u_offset; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --rwork; /* Function Body */ *info = 0; iuplo = 0; if (lsame_(uplo, "U", 1L, 1L)) { iuplo = 1; } if (lsame_(uplo, "L", 1L, 1L)) { iuplo = 2; } if (iuplo == 0) { *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, 6L); return 0; } if (*n == 0) { return 0; } if (*n == 1) { goto L150; } /* 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; /* Get machine constants */ eps = dlamch_("Epsilon", 7L); unfl = dlamch_("Safe minimum", 12L); /* 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]; 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, 1L, 1L, 1L); } if (*ncc > 0) { zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[ c_offset], ldc, 1L, 1L, 1L); } } /* 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 = (d__1 = d__[*n], abs(d__1)); i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__3 = smax, d__4 = (d__1 = d__[i__], abs(d__1)), d__3 = max(d__3, d__4), d__4 = (d__2 = e[i__], abs(d__2)); smax = max(d__3,d__4); /* L20: */ } sminl = 0.; if (tol >= 0.) { /* Relative accuracy desired */ sminoa = abs(d__[1]); if (sminoa == 0.) { goto L40; } mu = sminoa; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { mu = (d__1 = d__[i__], abs(d__1)) * (mu / (mu + (d__2 = e[i__ - 1] , abs(d__2)))); sminoa = min(sminoa,mu); if (sminoa == 0.) { goto L40; } /* L30: */ } L40: 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 */ L50: /* Check for convergence or exceeding iteration count */ if (m <= 1) { goto L150; } if (iter > maxit) { goto L190; } /* 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; for (lll = 1; lll <= i__1; ++lll) { ll = m - lll; if (ll == 0) { goto L80; } 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 L70; } smin = min(smin,abss); /* Computing MAX */ d__1 = max(smax,abss); smax = max(d__1,abse); /* L60: */ } L70: 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 L50; } L80: ++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[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & cosr, &sinr); } if (*nru > 0) { zdrot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & c__1, &cosl, &sinl); } if (*ncc > 0) { zdrot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & cosl, &sinl); } m += -2; goto L50; } /* 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__1 = e[m - 1], abs(d__1)) <= abs(tol) * (d__2 = d__[m], abs( d__2)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) { e[m - 1] = 0.; goto L50; } 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 L50; } sminlo = sminl; mu = (d__1 = d__[lll + 1], abs(d__1)) * (mu / (mu + (d__2 = e[ lll], abs(d__2)))); sminl = min(sminl,mu); /* L90: */ } } } else { /* Run convergence test in backward direction */ /* First apply standard test to top of matrix */ if ((d__1 = e[ll], abs(d__1)) <= abs(tol) * (d__2 = d__[ll], abs(d__2) ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { e[ll] = 0.; goto L50; } 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 L50; } sminlo = sminl; mu = (d__1 = d__[lll], abs(d__1)) * (mu / (mu + (d__2 = e[lll] , abs(d__2)))); sminl = min(sminl,mu); /* L100: */ } } } 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 upda tes */ cs = 1.; oldcs = 1.; d__1 = d__[ll] * cs; dlartg_(&d__1, &e[ll], &cs, &sn, &r__); d__1 = oldcs * r__; d__2 = d__[ll + 1] * sn; dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[ll]); rwork[1] = cs; rwork[nm1 + 1] = sn; rwork[nm12 + 1] = oldcs; rwork[nm13 + 1] = oldsn; irot = 1; i__1 = m - 1; for (i__ = ll + 1; i__ <= i__1; ++i__) { d__1 = d__[i__] * cs; dlartg_(&d__1, &e[i__], &cs, &sn, &r__); e[i__ - 1] = oldsn * r__; d__1 = oldcs * r__; d__2 = d__[i__ + 1] * sn; dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); ++irot; rwork[irot] = cs; rwork[irot + nm1] = sn; rwork[irot + nm12] = oldcs; rwork[irot + nm13] = oldsn; /* L110: */ } 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[ ll + vt_dim1], ldvt, 1L, 1L, 1L); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[ nm13 + 1], &u[ll * u_dim1 + 1], ldu, 1L, 1L, 1L); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[ nm13 + 1], &c__[ll + c_dim1], ldc, 1L, 1L, 1L); } /* 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 upda tes */ cs = 1.; oldcs = 1.; d__1 = d__[m] * cs; dlartg_(&d__1, &e[m - 1], &cs, &sn, &r__); d__1 = oldcs * r__; d__2 = d__[m - 1] * sn; dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[m]); rwork[m - ll] = cs; rwork[m - ll + nm1] = -sn; rwork[m - ll + nm12] = oldcs; rwork[m - ll + nm13] = -oldsn; irot = m - ll; i__1 = ll + 1; for (i__ = m - 1; i__ >= i__1; --i__) { d__1 = d__[i__] * cs; dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); e[i__] = oldsn * r__; d__1 = oldcs * r__; d__2 = d__[i__ - 1] * sn; dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); --irot; rwork[irot] = cs; rwork[irot + nm1] = -sn; rwork[irot + nm12] = oldcs; rwork[irot + nm13] = -oldsn; /* L120: */ } 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[ll + vt_dim1], ldvt, 1L, 1L, 1L); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[ ll * u_dim1 + 1], ldu, 1L, 1L, 1L); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[ ll + c_dim1], ldc, 1L, 1L, 1L); } /* 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 upda tes */ f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b48, &d__[ ll]) + shift / d__[ll]); g = e[ll]; dlartg_(&f, &g, &cosr, &sinr, &r__); f = cosr * d__[ll] + sinr * e[ll]; e[ll] = cosr * e[ll] - sinr * d__[ll]; g = sinr * d__[ll + 1]; d__[ll + 1] = cosr * d__[ll + 1]; dlartg_(&f, &g, &cosl, &sinl, &r__); d__[ll] = r__; f = cosl * e[ll] + sinl * d__[ll + 1]; d__[ll + 1] = cosl * d__[ll + 1] - sinl * e[ll]; g = sinl * e[ll + 1]; e[ll + 1] = cosl * e[ll + 1]; rwork[1] = cosr; rwork[nm1 + 1] = sinr; rwork[nm12 + 1] = cosl; rwork[nm13 + 1] = sinl; irot = 1; i__1 = m - 2; for (i__ = ll + 1; i__ <= i__1; ++i__) { dlartg_(&f, &g, &cosr, &sinr, &r__); 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__]; g = sinl * e[i__ + 1]; e[i__ + 1] = cosl * e[i__ + 1]; ++irot; rwork[irot] = cosr; rwork[irot + nm1] = sinr; rwork[irot + nm12] = cosl; rwork[irot + nm13] = sinl; /* L130: */ } dlartg_(&f, &g, &cosr, &sinr, &r__); e[m - 2] = r__; f = cosr * d__[m - 1] + sinr * e[m - 1]; e[m - 1] = cosr * e[m - 1] - sinr * d__[m - 1]; g = sinr * d__[m]; d__[m] = cosr * d__[m]; dlartg_(&f, &g, &cosl, &sinl, &r__); d__[m - 1] = r__; f = cosl * e[m - 1] + sinl * d__[m]; d__[m] = cosl * d__[m] - sinl * e[m - 1]; ++irot; rwork[irot] = cosr; rwork[irot + nm1] = sinr; rwork[irot + nm12] = cosl; rwork[irot + nm13] = sinl; 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[ ll + vt_dim1], ldvt, 1L, 1L, 1L); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[ nm13 + 1], &u[ll * u_dim1 + 1], ldu, 1L, 1L, 1L); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[ nm13 + 1], &c__[ll + c_dim1], ldc, 1L, 1L, 1L); } /* 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 upda tes */ f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b48, &d__[m] ) + shift / d__[m]); g = e[m - 1]; dlartg_(&f, &g, &cosr, &sinr, &r__); f = cosr * d__[m] + sinr * e[m - 1]; e[m - 1] = cosr * e[m - 1] - sinr * d__[m]; g = sinr * d__[m - 1]; d__[m - 1] = cosr * d__[m - 1]; dlartg_(&f, &g, &cosl, &sinl, &r__); d__[m] = r__; f = cosl * e[m - 1] + sinl * d__[m - 1]; d__[m - 1] = cosl * d__[m - 1] - sinl * e[m - 1]; g = sinl * e[m - 2]; e[m - 2] = cosl * e[m - 2]; rwork[m - ll] = cosr; rwork[m - ll + nm1] = -sinr; rwork[m - ll + nm12] = cosl; rwork[m - ll + nm13] = -sinl; irot = m - ll; i__1 = ll + 2; for (i__ = m - 1; i__ >= i__1; --i__) { dlartg_(&f, &g, &cosr, &sinr, &r__); 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]; g = sinl * e[i__ - 2]; e[i__ - 2] = cosl * e[i__ - 2]; --irot; rwork[irot] = cosr; rwork[irot + nm1] = -sinr; rwork[irot + nm12] = cosl; rwork[irot + nm13] = -sinl; /* L140: */ } dlartg_(&f, &g, &cosr, &sinr, &r__); e[ll + 1] = r__; f = cosr * d__[ll + 1] + sinr * e[ll]; e[ll] = cosr * e[ll] - sinr * d__[ll + 1]; g = sinr * d__[ll]; d__[ll] = cosr * d__[ll]; dlartg_(&f, &g, &cosl, &sinl, &r__); d__[ll + 1] = r__; f = cosl * e[ll] + sinl * d__[ll]; d__[ll] = cosl * d__[ll] - sinl * e[ll]; --irot; rwork[irot] = cosr; rwork[irot + nm1] = -sinr; rwork[irot + nm12] = cosl; rwork[irot + nm13] = -sinl; 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[ll + vt_dim1], ldvt, 1L, 1L, 1L); } if (*nru > 0) { i__1 = m - ll + 1; zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[ ll * u_dim1 + 1], ldu, 1L, 1L, 1L); } if (*ncc > 0) { i__1 = m - ll + 1; zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[ ll + c_dim1], ldc, 1L, 1L, 1L); } } } /* QR iteration finished, go back and check convergence */ goto L50; /* All singular values converged, so make them positive */ L150: 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_b71, &vt[i__ + vt_dim1], ldvt); } } /* L160: */ } /* 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]; } /* L170: */ } 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[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + vt_dim1], ldvt); } if (*nru > 0) { zswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * u_dim1 + 1], &c__1); } if (*ncc > 0) { zswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + c_dim1], ldc); } } /* L180: */ } goto L210; /* Maximum number of iterations exceeded, failure to converge */ L190: *info = 0; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { if (e[i__] != 0.) { ++(*info); } /* L200: */ } L210: return 0; /* End of ZBDSQR */ } /* zbdsqr_ */ /* zlarfg.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b5 #undef c_b5 #endif #define c_b5 c_b5 /* Subroutine */ int zlarfg_(n, alpha, x, incx, tau) integer *n; doublecomplex *alpha, *x; integer *incx; doublecomplex *tau; { /* System generated locals */ integer i__1; doublereal d__1, d__2; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(), d_sign(); /* Local variables */ static doublereal beta; static integer j; static doublereal alphi, alphr; extern /* Subroutine */ int zscal_(); static doublereal xnorm; extern doublereal dlapy3_(), dznrm2_(), dlamch_(); static doublereal safmin; extern /* Subroutine */ int zdscal_(); static doublereal rsafmn; extern /* Double Complex */ VOID zladiv_(); static integer knt; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLARFG generates a complex elementary reflector H of order n, such */ /* that */ /* H' * ( alpha ) = ( beta ), H' * H = I. */ /* ( x ) ( 0 ) */ /* where alpha and beta are scalars, with beta real, and x is an */ /* (n-1)-element complex vector. H is represented in the form */ /* H = I - tau * ( 1 ) * ( 1 v' ) , */ /* ( v ) */ /* where tau is a complex scalar and v is a complex (n-1)-element */ /* vector. Note that H is not hermitian. */ /* If the elements of x are all zero and alpha is real, then tau = 0 */ /* and H is taken to be the unit matrix. */ /* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the elementary reflector. */ /* ALPHA (input/output) COMPLEX*16 */ /* On entry, the value alpha. */ /* On exit, it is overwritten with the value beta. */ /* X (input/output) COMPLEX*16 array, dimension */ /* (1+(N-2)*abs(INCX)) */ /* On entry, the vector x. */ /* On exit, it is overwritten with the vector v. */ /* INCX (input) INTEGER */ /* The increment between elements of X. INCX > 0. */ /* TAU (output) COMPLEX*16 */ /* The value tau. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --x; /* Function Body */ if (*n <= 0) { tau->r = 0., tau->i = 0.; return 0; } i__1 = *n - 1; xnorm = dznrm2_(&i__1, &x[1], incx); alphr = alpha->r; alphi = d_imag(alpha); if (xnorm == 0. && alphi == 0.) { /* H = I */ tau->r = 0., tau->i = 0.; } else { /* general case */ d__1 = dlapy3_(&alphr, &alphi, &xnorm); beta = -d_sign(&d__1, &alphr); safmin = dlamch_("S", 1L) / dlamch_("E", 1L); rsafmn = 1. / safmin; if (abs(beta) < safmin) { /* XNORM, BETA may be inaccurate; scale X and recompute them */ knt = 0; L10: ++knt; i__1 = *n - 1; zdscal_(&i__1, &rsafmn, &x[1], incx); beta *= rsafmn; alphi *= rsafmn; alphr *= rsafmn; if (abs(beta) < safmin) { goto L10; } /* New BETA is at most 1, at least SAFMIN */ i__1 = *n - 1; xnorm = dznrm2_(&i__1, &x[1], incx); z__1.r = alphr, z__1.i = alphi; alpha->r = z__1.r, alpha->i = z__1.i; d__1 = dlapy3_(&alphr, &alphi, &xnorm); beta = -d_sign(&d__1, &alphr); d__1 = (beta - alphr) / beta; d__2 = -alphi / beta; z__1.r = d__1, z__1.i = d__2; tau->r = z__1.r, tau->i = z__1.i; z__2.r = alpha->r - beta, z__2.i = alpha->i; zladiv_(&z__1, &c_b5, &z__2); alpha->r = z__1.r, alpha->i = z__1.i; i__1 = *n - 1; zscal_(&i__1, alpha, &x[1], incx); /* If ALPHA is subnormal, it may lose relative accuracy */ alpha->r = beta, alpha->i = 0.; i__1 = knt; for (j = 1; j <= i__1; ++j) { z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i; alpha->r = z__1.r, alpha->i = z__1.i; /* L20: */ } } else { d__1 = (beta - alphr) / beta; d__2 = -alphi / beta; z__1.r = d__1, z__1.i = d__2; tau->r = z__1.r, tau->i = z__1.i; z__2.r = alpha->r - beta, z__2.i = alpha->i; zladiv_(&z__1, &c_b5, &z__2); alpha->r = z__1.r, alpha->i = z__1.i; i__1 = *n - 1; zscal_(&i__1, alpha, &x[1], incx); alpha->r = beta, alpha->i = 0.; } } return 0; /* End of ZLARFG */ } /* zlarfg_ */ /* zlarf.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1a #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2a /* Subroutine */ int zlarf_(side, m, n, v, incv, tau, c__, ldc, work, side_len) char *side; integer *m, *n; doublecomplex *v; integer *incv; doublecomplex *tau, *c__; integer *ldc; doublecomplex *work; ftnlen side_len; { /* System generated locals */ integer c_dim1, c_offset; doublecomplex z__1; /* Local variables */ extern logical lsame_(); extern /* Subroutine */ int zgerc_(), zgemv_(); /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLARF applies a complex elementary reflector H to a complex 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 complex scalar and v is a complex vector. */ /* If tau = 0, then H is taken to be the unit matrix. */ /* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */ /* tau. */ /* 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. */ /* V (input) COMPLEX*16 array, dimension */ /* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */ /* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ /* The vector v in the representation of H. V is not used if */ /* TAU = 0. */ /* INCV (input) INTEGER */ /* The increment between elements of v. INCV <> 0. */ /* TAU (input) COMPLEX*16 */ /* The value tau in the representation of H. */ /* C (input/output) COMPLEX*16 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) COMPLEX*16 array, dimension */ /* (N) if SIDE = 'L' */ /* or (M) if SIDE = 'R' */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --v; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ if (lsame_(side, "L", 1L, 1L)) { /* Form H * C */ if (tau->r != 0. || tau->i != 0.) { /* w := C' * v */ zgemv_("Conjugate transpose", m, n, &c_b1, &c__[c_offset], ldc, & v[1], incv, &c_b2, &work[1], &c__1, 19L); /* C := C - v * w' */ z__1.r = -tau->r, z__1.i = -tau->i; zgerc_(m, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc); } } else { /* Form C * H */ if (tau->r != 0. || tau->i != 0.) { /* w := C * v */ zgemv_("No transpose", m, n, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1, 12L); /* C := C - w * v' */ z__1.r = -tau->r, z__1.i = -tau->i; zgerc_(m, n, &z__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc); } } return 0; /* End of ZLARF */ } /* zlarf_ */ /* zgelqf.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgelqf_(m, n, a, lda, tau, work, lwork, info) integer *m, *n; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i__, k, nbmin, iinfo; extern /* Subroutine */ int zgelq2_(); static integer ib, nb, nx; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(); static integer ldwork; extern /* Subroutine */ int zlarft_(); static integer iws; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGELQF computes an LQ factorization of a complex M-by-N matrix A: */ /* A = L * Q. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, the elements on and below the diagonal of the array */ /* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */ /* lower triangular if m <= n); the elements above the diagonal, */ /* with the array TAU, represent the unitary matrix Q as a */ /* product of elementary reflectors (see Further Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* 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,M). */ /* For optimum performance LWORK >= M*NB, where NB is the */ /* optimal blocksize. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */ /* A(i,i+1:n), and tau in TAU(i). */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } else if (*lwork < max(1,*m)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGELQF", &i__1, 6L); return 0; } /* Quick return if possible */ k = min(*m,*n); if (k == 0) { work[1].r = 1., work[1].i = 0.; return 0; } /* Determine the block size. */ nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L); nbmin = 2; nx = 0; iws = *m; 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, "ZGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L); nx = max(i__1,i__2); if (nx < k) { /* Determine if workspace is large enough for blocked co de. */ ldwork = *m; 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, "ZGELQF", " ", m, n, &c_n1, & c_n1, 6L, 1L); nbmin = max(i__1,i__2); } } } if (nb >= nbmin && nb < k && nx < k) { /* Use blocked code initially */ i__1 = k - nx; i__2 = nb; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = k - i__ + 1; ib = min(i__3,nb); /* Compute the LQ factorization of the current block */ /* A(i:i+ib-1,i:n) */ i__3 = *n - i__ + 1; zgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ 1], &iinfo); if (i__ + ib <= *m) { /* Form the triangular factor of the block reflec tor */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ i__3 = *n - i__ + 1; zlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L); /* Apply H to A(i+ib:m,i:n) from the right */ i__3 = *m - i__ - ib + 1; i__4 = *n - i__ + 1; zlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + 1], &ldwork, 5L, 12L, 7L, 7L); } /* L10: */ } } else { i__ = 1; } /* Use unblocked code to factor the last or only block. */ if (i__ <= k) { i__2 = *m - i__ + 1; i__1 = *n - i__ + 1; zgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] , &iinfo); } work[1].r = (doublereal) iws, work[1].i = 0.; return 0; /* End of ZGELQF */ } /* zgelqf_ */ /* zgebal.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgebal_(job, n, a, lda, ilo, ihi, scale, info, job_len) char *job; integer *n; doublecomplex *a; integer *lda, *ilo, *ihi; doublereal *scale; integer *info; ftnlen job_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublereal d__1, d__2; /* Builtin functions */ double d_imag(), z_abs(); /* Local variables */ static integer iexc; static doublereal c__, f, g; static integer i__, j, k, l, m; static doublereal r__, s; extern logical lsame_(); extern /* Subroutine */ int zswap_(); static doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca, ra; extern doublereal dlamch_(); extern /* Subroutine */ int xerbla_(), zdscal_(); extern integer izamax_(); static logical noconv; static integer ica, ira; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEBAL balances a general complex matrix A. This involves, first, */ /* permuting A by a similarity transformation to isolate eigenvalues */ /* in the first 1 to ILO-1 and last IHI+1 to N elements on the */ /* diagonal; and second, applying a diagonal similarity transformation */ /* to rows and columns ILO to IHI to make the rows and columns as */ /* close in norm as possible. Both steps are optional. */ /* Balancing may reduce the 1-norm of the matrix, and improve the */ /* accuracy of the computed eigenvalues and/or eigenvectors. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* Specifies the operations to be performed on A: */ /* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */ /* for i = 1,...,N; */ /* = 'P': permute only; */ /* = 'S': scale only; */ /* = 'B': both permute and scale. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the input matrix A. */ /* On exit, A is overwritten by the balanced matrix. */ /* If JOB = 'N', A is not referenced. */ /* See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* ILO (output) INTEGER */ /* IHI (output) INTEGER */ /* ILO and IHI are set to integers such that on exit */ /* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */ /* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ /* SCALE (output) DOUBLE PRECISION array, dimension (N) */ /* Details of the permutations and scaling factors applied to */ /* A. If P(j) is the index of the row and column interchanged */ /* with row and column j and D(j) is the scaling factor */ /* applied to row and column j, then */ /* SCALE(j) = P(j) for j = 1,...,ILO-1 */ /* = D(j) for j = ILO,...,IHI */ /* = P(j) for j = IHI+1,...,N. */ /* The order in which the interchanges are made is N to IHI+1, */ /* then 1 to ILO-1. */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* Further Details */ /* =============== */ /* The permutations consist of row and column interchanges which put */ /* the matrix in the form */ /* ( T1 X Y ) */ /* P A P = ( 0 B Z ) */ /* ( 0 0 T2 ) */ /* where T1 and T2 are upper triangular matrices whose eigenvalues lie */ /* along the diagonal. The column indices ILO and IHI mark the starting */ /* and ending columns of the submatrix B. Balancing consists of applying */ /* a diagonal similarity transformation inv(D) * B * D to make the */ /* 1-norms of each row of B and its corresponding column nearly equal. */ /* The output matrix is */ /* ( T1 X*D Y ) */ /* ( 0 inv(D)*B*D inv(D)*Z ). */ /* ( 0 0 T2 ) */ /* Information about the permutations P and the diagonal matrix D is */ /* returned in the vector SCALE. */ /* This subroutine is based on the EISPACK routine CBAL. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --scale; /* Function Body */ *info = 0; if (! lsame_(job, "N", 1L, 1L) && ! lsame_(job, "P", 1L, 1L) && ! lsame_( job, "S", 1L, 1L) && ! lsame_(job, "B", 1L, 1L)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEBAL", &i__1, 6L); return 0; } k = 1; l = *n; if (*n == 0) { goto L210; } if (lsame_(job, "N", 1L, 1L)) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { scale[i__] = 1.; /* L10: */ } goto L210; } if (lsame_(job, "S", 1L, 1L)) { goto L120; } /* Permutation to isolate eigenvalues if possible */ goto L50; /* Row and column exchange. */ L20: scale[m] = (doublereal) j; if (j == m) { goto L30; } zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); i__1 = *n - k + 1; zswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda); L30: switch ((int)iexc) { case 1: goto L40; case 2: goto L80; } /* Search for rows isolating an eigenvalue and push them down. */ L40: if (l == 1) { goto L210; } --l; L50: for (j = l; j >= 1; --j) { i__1 = l; for (i__ = 1; i__ <= i__1; ++i__) { if (i__ == j) { goto L60; } i__2 = j + i__ * a_dim1; if (a[i__2].r != 0. || d_imag(&a[j + i__ * a_dim1]) != 0.) { goto L70; } L60: ; } m = l; iexc = 1; goto L20; L70: ; } goto L90; /* Search for columns isolating an eigenvalue and push them left. */ L80: ++k; L90: i__1 = l; for (j = k; j <= i__1; ++j) { i__2 = l; for (i__ = k; i__ <= i__2; ++i__) { if (i__ == j) { goto L100; } i__3 = i__ + j * a_dim1; if (a[i__3].r != 0. || d_imag(&a[i__ + j * a_dim1]) != 0.) { goto L110; } L100: ; } m = k; iexc = 2; goto L20; L110: ; } L120: i__1 = l; for (i__ = k; i__ <= i__1; ++i__) { scale[i__] = 1.; /* L130: */ } if (lsame_(job, "P", 1L, 1L)) { goto L210; } /* Balance the submatrix in rows K to L. */ /* Iterative loop for norm reduction */ sfmin1 = dlamch_("S", 1L) / dlamch_("P", 1L); sfmax1 = 1. / sfmin1; sfmin2 = sfmin1 * 10.; sfmax2 = 1. / sfmin2; L140: noconv = FALSE_; i__1 = l; for (i__ = k; i__ <= i__1; ++i__) { c__ = 0.; r__ = 0.; i__2 = l; for (j = k; j <= i__2; ++j) { if (j == i__) { goto L150; } i__3 = j + i__ * a_dim1; c__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + i__ * a_dim1]), abs(d__2)); i__3 = i__ + j * a_dim1; r__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); L150: ; } ica = izamax_(&l, &a[i__ * a_dim1 + 1], &c__1); ca = z_abs(&a[ica + i__ * a_dim1]); i__2 = *n - k + 1; ira = izamax_(&i__2, &a[i__ + k * a_dim1], lda); ra = z_abs(&a[i__ + (ira + k - 1) * a_dim1]); /* Guard against zero C or R due to underflow. */ if (c__ == 0. || r__ == 0.) { goto L200; } g = r__ / 10.; f = 1.; s = c__ + r__; L160: /* Computing MAX */ d__1 = max(f,c__); /* Computing MIN */ d__2 = min(r__,g); if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) { goto L170; } f *= 10.; c__ *= 10.; ca *= 10.; r__ /= 10.; g /= 10.; ra /= 10.; goto L160; L170: g = c__ / 10.; L180: /* Computing MIN */ d__1 = min(f,c__), d__1 = min(d__1,g); if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) { goto L190; } f /= 10.; c__ /= 10.; g /= 10.; ca /= 10.; r__ *= 10.; ra *= 10.; goto L180; /* Now balance. */ L190: if (c__ + r__ >= s * .95) { goto L200; } if (f < 1. && scale[i__] < 1.) { if (f * scale[i__] <= sfmin1) { goto L200; } } if (f > 1. && scale[i__] > 1.) { if (scale[i__] >= sfmax1 / f) { goto L200; } } g = 1. / f; scale[i__] *= f; noconv = TRUE_; i__2 = *n - k + 1; zdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda); zdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1); L200: ; } if (noconv) { goto L140; } L210: *ilo = k; *ihi = l; return 0; /* End of ZGEBAL */ } /* zgebal_ */ /* zunmlq.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zunmlq_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *c__; integer *ldc; doublecomplex *work; integer *lwork, *info; ftnlen side_len; ftnlen trans_len; { /* 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(); /* Local variables */ static logical left; static integer i__; static doublecomplex t[4160] /* was [65][64] */; extern logical lsame_(); static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc, nb, mi, ni; extern /* Subroutine */ int zunml2_(); static integer nq, nw; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(); static logical notran; static integer ldwork; extern /* Subroutine */ int zlarft_(); static char transt[1]; static integer iws; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNMLQ 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(k)' . . . H(2)' H(1)' */ /* as returned by ZGELQF. 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. */ /* 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 */ /* ZGELQF in the first 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 ZGELQF. */ /* 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**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*16 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. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); /* 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", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "C", 1L, 1L)) { *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,*k)) { *info = -7; } else if (*ldc < max(1,*m)) { *info = -10; } else if (*lwork < max(1,nw)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNMLQ", &i__1, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0 || *k == 0) { work[1].r = 1., work[1].i = 0.; 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, 2L); i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMLQ", ch__1, m, n, k, &c_n1, 6L, 2L); 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, 2L); i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMLQ", ch__1, m, n, k, &c_n1, 6L, 2L); nbmin = max(i__1,i__2); } } else { iws = nw; } if (nb < nbmin || nb >= *k) { /* Use unblocked code */ zunml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo, 1L, 1L); } 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; } 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) H(i+1) . . . H(i+ib-1) */ i__4 = nq - i__ + 1; zlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65, 7L, 7L); 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' */ zlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 7L); /* L10: */ } } work[1].r = (doublereal) iws, work[1].i = 0.; return 0; /* End of ZUNMLQ */ } /* zunmlq_ */ /* zgebak.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zgebak_(job, side, n, ilo, ihi, scale, m, v, ldv, info, job_len, side_len) char *job, *side; integer *n, *ilo, *ihi; doublereal *scale; integer *m; doublecomplex *v; integer *ldv, *info; ftnlen job_len; ftnlen side_len; { /* System generated locals */ integer v_dim1, v_offset, i__1; /* Local variables */ static integer i__, k; static doublereal s; extern logical lsame_(); static logical leftv; extern /* Subroutine */ int zswap_(); static integer ii; extern /* Subroutine */ int xerbla_(), zdscal_(); static logical rightv; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEBAK forms the right or left eigenvectors of a complex general */ /* matrix by backward transformation on the computed eigenvectors of the */ /* balanced matrix output by ZGEBAL. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* Specifies the type of backward transformation required: */ /* = 'N', do nothing, return immediately; */ /* = 'P', do backward transformation for permutation only; */ /* = 'S', do backward transformation for scaling only; */ /* = 'B', do backward transformations for both permutation and */ /* scaling. */ /* JOB must be the same as the argument JOB supplied to ZGEBAL. */ /* SIDE (input) CHARACTER*1 */ /* = 'R': V contains right eigenvectors; */ /* = 'L': V contains left eigenvectors. */ /* N (input) INTEGER */ /* The number of rows of the matrix V. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* The integers ILO and IHI determined by ZGEBAL. */ /* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ /* SCALE (input) DOUBLE PRECISION array, dimension (N) */ /* Details of the permutation and scaling factors, as returned */ /* by ZGEBAL. */ /* M (input) INTEGER */ /* The number of columns of the matrix V. M >= 0. */ /* V (input/output) COMPLEX*16 array, dimension (LDV,M) */ /* On entry, the matrix of right or left eigenvectors to be */ /* transformed, as returned by ZHSEIN or ZTREVC. */ /* On exit, V is overwritten by the transformed eigenvectors. */ /* LDV (input) INTEGER */ /* The leading dimension of the array V. LDV >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and Test the input parameters */ /* Parameter adjustments */ --scale; v_dim1 = *ldv; v_offset = v_dim1 + 1; v -= v_offset; /* Function Body */ rightv = lsame_(side, "R", 1L, 1L); leftv = lsame_(side, "L", 1L, 1L); *info = 0; if (! lsame_(job, "N", 1L, 1L) && ! lsame_(job, "P", 1L, 1L) && ! lsame_( job, "S", 1L, 1L) && ! lsame_(job, "B", 1L, 1L)) { *info = -1; } else if (! rightv && ! leftv) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -4; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -5; } else if (*m < 0) { *info = -7; } else if (*ldv < max(1,*n)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEBAK", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*m == 0) { return 0; } if (lsame_(job, "N", 1L, 1L)) { return 0; } if (*ilo == *ihi) { goto L30; } /* Backward balance */ if (lsame_(job, "S", 1L, 1L) || lsame_(job, "B", 1L, 1L)) { if (rightv) { i__1 = *ihi; for (i__ = *ilo; i__ <= i__1; ++i__) { s = scale[i__]; zdscal_(m, &s, &v[i__ + v_dim1], ldv); /* L10: */ } } if (leftv) { i__1 = *ihi; for (i__ = *ilo; i__ <= i__1; ++i__) { s = 1. / scale[i__]; zdscal_(m, &s, &v[i__ + v_dim1], ldv); /* L20: */ } } } /* Backward permutation */ /* For I = ILO-1 step -1 until 1, */ /* IHI+1 step 1 until N do -- */ L30: if (lsame_(job, "P", 1L, 1L) || lsame_(job, "B", 1L, 1L)) { if (rightv) { i__1 = *n; for (ii = 1; ii <= i__1; ++ii) { i__ = ii; if (i__ >= *ilo && i__ <= *ihi) { goto L40; } if (i__ < *ilo) { i__ = *ilo - ii; } k = (integer) scale[i__]; if (k == i__) { goto L40; } zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); L40: ; } } if (leftv) { i__1 = *n; for (ii = 1; ii <= i__1; ++ii) { i__ = ii; if (i__ >= *ilo && i__ <= *ihi) { goto L50; } if (i__ < *ilo) { i__ = *ilo - ii; } k = (integer) scale[i__]; if (k == i__) { goto L50; } zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); L50: ; } } } return 0; /* End of ZGEBAK */ } /* zgebak_ */ /* zlabrd.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1 #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int zlabrd_(m, n, nb, a, lda, d__, e, tauq, taup, x, ldx, y, ldy) integer *m, *n, *nb; doublecomplex *a; integer *lda; doublereal *d__, *e; doublecomplex *tauq, *taup, *x; integer *ldx; doublecomplex *y; integer *ldy; { /* System generated locals */ integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, i__3; doublecomplex z__1; /* Local variables */ static integer i__; static doublecomplex alpha; extern /* Subroutine */ int zscal_(), zgemv_(), zlarfg_(), zlacgv_(); /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLABRD reduces the first NB rows and columns of a complex general */ /* m by n matrix A to upper or lower real bidiagonal form by a unitary */ /* transformation Q' * A * P, and returns the matrices X and Y which */ /* are needed to apply the transformation to the unreduced part of A. */ /* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */ /* bidiagonal form. */ /* This is an auxiliary routine called by ZGEBRD */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows in the matrix A. */ /* N (input) INTEGER */ /* The number of columns in the matrix A. */ /* NB (input) INTEGER */ /* The number of leading rows and columns of A to be reduced. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the m by n general matrix to be reduced. */ /* On exit, the first NB rows and columns of the matrix are */ /* overwritten; the rest of the array is unchanged. */ /* If m >= n, elements on and below the diagonal in the first NB */ /* columns, with the array TAUQ, represent the unitary */ /* matrix Q as a product of elementary reflectors; and */ /* elements above the diagonal in the first NB rows, with the */ /* array TAUP, represent the unitary matrix P as a product */ /* of elementary reflectors. */ /* If m < n, elements below the diagonal in the first NB */ /* columns, with the array TAUQ, represent the unitary */ /* matrix Q as a product of elementary reflectors, and */ /* elements on and above the diagonal in the first NB rows, */ /* with the array TAUP, represent the unitary matrix P as */ /* a product of elementary reflectors. */ /* See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* D (output) DOUBLE PRECISION array, dimension (NB) */ /* The diagonal elements of the first NB rows and columns of */ /* the reduced matrix. D(i) = A(i,i). */ /* E (output) DOUBLE PRECISION array, dimension (NB) */ /* The off-diagonal elements of the first NB rows and columns of */ /* the reduced matrix. */ /* TAUQ (output) COMPLEX*16 array dimension (NB) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix Q. See Further Details. */ /* TAUP (output) COMPLEX*16 array, dimension (NB) */ /* The scalar factors of the elementary reflectors which */ /* represent the unitary matrix P. See Further Details. */ /* X (output) COMPLEX*16 array, dimension (LDX,NB) */ /* The m-by-nb matrix X required to update the unreduced part */ /* of A. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,M). */ /* Y (output) COMPLEX*16 array, dimension (LDY,NB) */ /* The n-by-nb matrix Y required to update the unreduced part */ /* of A. */ /* LDY (output) INTEGER */ /* The leading dimension of the array Y. LDY >= max(1,N). */ /* Further Details */ /* =============== */ /* The matrices Q and P are represented as products of elementary */ /* reflectors: */ /* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */ /* Each H(i) and G(i) has the form: */ /* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ /* where tauq and taup are complex scalars, and v and u are complex */ /* vectors. */ /* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */ /* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */ /* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */ /* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */ /* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ /* The elements of the vectors v and u together form the m-by-nb matrix */ /* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */ /* the transformation to the unreduced part of the matrix, using a block */ /* update of the form: A := A - V*Y' - X*U'. */ /* The contents of A on exit are illustrated by the following examples */ /* with nb = 2: */ /* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ /* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */ /* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */ /* ( v1 v2 a a a ) ( v1 1 a a a a ) */ /* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ /* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ /* ( v1 v2 a a a ) */ /* where a denotes an element of the original matrix which is unchanged, */ /* vi denotes an element of the vector defining H(i), and ui an element */ /* of the vector defining G(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --d__; --e; --tauq; --taup; x_dim1 = *ldx; x_offset = x_dim1 + 1; x -= x_offset; y_dim1 = *ldy; y_offset = y_dim1 + 1; y -= y_offset; /* Function Body */ if (*m <= 0 || *n <= 0) { return 0; } if (*m >= *n) { /* Reduce to upper bidiagonal form */ i__1 = *nb; for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i:m,i) */ i__2 = i__ - 1; zlacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__ + 1; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], & c__1, 12L); i__2 = i__ - 1; zlacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__ + 1; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ * a_dim1], &c__1, 12L); /* Generate reflection Q(i) to annihilate A(i+1:m,i) */ i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *m - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, & tauq[i__]); i__2 = i__; d__[i__2] = alpha.r; if (i__ < *n) { i__2 = i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Compute Y(i+1:n,i) */ i__2 = *m - i__ + 1; i__3 = *n - i__; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + ( i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], & c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L); i__2 = *m - i__ + 1; i__3 = i__ - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, & y[i__ * y_dim1 + 1], &c__1, 19L); i__2 = *n - i__; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[ i__ + 1 + i__ * y_dim1], &c__1, 12L); i__2 = *m - i__ + 1; i__3 = i__ - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ + x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, & y[i__ * y_dim1 + 1], &c__1, 19L); i__2 = i__ - 1; i__3 = *n - i__; z__1.r = -1., z__1.i = 0.; zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, & c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L); i__2 = *n - i__; zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); /* Update A(i,i+1:n) */ i__2 = *n - i__; zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); zlacgv_(&i__, &a[i__ + a_dim1], lda); i__2 = *n - i__; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__, &z__1, &y[i__ + 1 + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + ( i__ + 1) * a_dim1], lda, 12L); zlacgv_(&i__, &a[i__ + a_dim1], lda); i__2 = i__ - 1; zlacgv_(&i__2, &x[i__ + x_dim1], ldx); i__2 = i__ - 1; i__3 = *n - i__; z__1.r = -1., z__1.i = 0.; zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, & a[i__ + (i__ + 1) * a_dim1], lda, 19L); i__2 = i__ - 1; zlacgv_(&i__2, &x[i__ + x_dim1], ldx); /* Generate reflection P(i) to annihilate A(i,i+2 :n) */ i__2 = i__ + (i__ + 1) * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__; /* Computing MIN */ i__3 = i__ + 2; zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, & taup[i__]); i__2 = i__; e[i__2] = alpha.r; i__2 = i__ + (i__ + 1) * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Compute X(i+1:m,i) */ i__2 = *m - i__; i__3 = *n - i__; zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1, 12L); i__2 = *n - i__; zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1 + y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b1, &x[i__ * x_dim1 + 1], &c__1, 19L); i__2 = *m - i__; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__, &z__1, &a[i__ + 1 + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1, 12L); i__2 = i__ - 1; i__3 = *n - i__; zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) * a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b1, &x[i__ * x_dim1 + 1], &c__1, 12L); i__2 = *m - i__; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1, 12L); i__2 = *m - i__; zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); i__2 = *n - i__; zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); } /* L10: */ } } else { /* Reduce to lower bidiagonal form */ i__1 = *nb; for (i__ = 1; i__ <= i__1; ++i__) { /* Update A(i,i:n) */ i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); i__2 = i__ - 1; zlacgv_(&i__2, &a[i__ + a_dim1], lda); i__2 = *n - i__ + 1; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], lda, 12L); i__2 = i__ - 1; zlacgv_(&i__2, &a[i__ + a_dim1], lda); i__2 = i__ - 1; zlacgv_(&i__2, &x[i__ + x_dim1], ldx); i__2 = i__ - 1; i__3 = *n - i__ + 1; z__1.r = -1., z__1.i = 0.; zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[i__ * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ + i__ * a_dim1], lda, 19L); i__2 = i__ - 1; zlacgv_(&i__2, &x[i__ + x_dim1], ldx); /* Generate reflection P(i) to annihilate A(i,i+1:n) */ i__2 = i__ + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *n - i__ + 1; /* Computing MIN */ i__3 = i__ + 1; zlarfg_(&i__2, &alpha, &a[i__ + min(i__3,*n) * a_dim1], lda, & taup[i__]); i__2 = i__; d__[i__2] = alpha.r; if (i__ < *m) { i__2 = i__ + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Compute X(i+1:m,i) */ i__2 = *m - i__; i__3 = *n - i__ + 1; zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[ i__ + 1 + i__ * x_dim1], &c__1, 12L); i__2 = *n - i__ + 1; i__3 = i__ - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ + y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[ i__ * x_dim1 + 1], &c__1, 19L); i__2 = *m - i__; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1, 12L); i__2 = i__ - 1; i__3 = *n - i__ + 1; zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 + 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ * x_dim1 + 1], &c__1, 12L); i__2 = *m - i__; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ i__ + 1 + i__ * x_dim1], &c__1, 12L); i__2 = *m - i__; zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); /* Update A(i+1:m,i) */ i__2 = i__ - 1; zlacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + 1 + i__ * a_dim1], &c__1, 12L); i__2 = i__ - 1; zlacgv_(&i__2, &y[i__ + y_dim1], ldy); i__2 = *m - i__; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__, &z__1, &x[i__ + 1 + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[ i__ + 1 + i__ * a_dim1], &c__1, 12L); /* Generate reflection Q(i) to annihilate A(i+2:m ,i) */ i__2 = i__ + 1 + i__ * a_dim1; alpha.r = a[i__2].r, alpha.i = a[i__2].i; i__2 = *m - i__; /* Computing MIN */ i__3 = i__ + 2; zlarfg_(&i__2, &alpha, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &tauq[i__]); i__2 = i__; e[i__2] = alpha.r; i__2 = i__ + 1 + i__ * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* Compute Y(i+1:n,i) */ i__2 = *m - i__; i__3 = *n - i__; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1] , &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L); i__2 = *m - i__; i__3 = i__ - 1; zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &y[i__ * y_dim1 + 1], &c__1, 19L); i__2 = *n - i__; i__3 = i__ - 1; z__1.r = -1., z__1.i = 0.; zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[ i__ + 1 + i__ * y_dim1], &c__1, 12L); i__2 = *m - i__; zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1 + x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &y[i__ * y_dim1 + 1], &c__1, 19L); i__2 = *n - i__; z__1.r = -1., z__1.i = 0.; zgemv_("Conjugate transpose", &i__, &i__2, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, & c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1, 19L); i__2 = *n - i__; zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); } else { i__2 = *n - i__ + 1; zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); } /* L20: */ } } return 0; /* End of ZLABRD */ } /* zlabrd_ */ /* zgesvd.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b1 #undef c_b1 #endif #define c_b1 c_b1 #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int zgesvd_(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info, jobu_len, jobvt_len) char *jobu, *jobvt; integer *m, *n; doublecomplex *a; integer *lda; doublereal *s; doublecomplex *u; integer *ldu; doublecomplex *vt; integer *ldvt; doublecomplex *work; integer *lwork; doublereal *rwork; integer *info; ftnlen jobu_len; ftnlen jobvt_len; { /* System generated locals */ address a__1[2]; integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2], i__2, i__3, i__4; char ch__1[2]; /* Builtin functions */ /* Subroutine */ int s_cat(); double sqrt(); /* Local variables */ static doublecomplex cdum[1]; static integer iscl; static doublereal anrm; static integer ierr, itau, ncvt, nrvt, i__; extern logical lsame_(); static integer chunk, minmn; extern /* Subroutine */ int zgemm_(); static integer wrkbl, itaup, itauq, mnthr, iwork; static logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs; static integer ie; extern doublereal dlamch_(); static integer ir, iu; extern /* Subroutine */ int dlascl_(), xerbla_(), zgebrd_(); extern integer ilaenv_(); extern doublereal zlange_(); static doublereal bignum; extern /* Subroutine */ int zgelqf_(), zlascl_(), zgeqrf_(), zlacpy_(), zlaset_(); static integer ldwrkr; extern /* Subroutine */ int zbdsqr_(); static integer minwrk, ldwrku, maxwrk; extern /* Subroutine */ int zungbr_(); static doublereal smlnum; static integer irwork; extern /* Subroutine */ int zunmbr_(), zunglq_(); static logical wntuas, wntvas; extern /* Subroutine */ int zungqr_(); static integer blk, ncu; static doublereal dum[1], eps; static integer nru; /* -- LAPACK driver routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGESVD computes the singular value decomposition (SVD) of a complex */ /* M-by-N matrix A, optionally computing the left and/or right singular */ /* vectors. The SVD is written */ /* A = U * SIGMA * conjugate-transpose(V) */ /* where SIGMA is an M-by-N matrix which is zero except for its */ /* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and */ /* V is an N-by-N unitary matrix. The diagonal elements of SIGMA */ /* are the singular values of A; they are real and non-negative, and */ /* are returned in descending order. The first min(m,n) columns of */ /* U and V are the left and right singular vectors of A. */ /* Note that the routine returns V**H, not V. */ /* Arguments */ /* ========= */ /* JOBU (input) CHARACTER*1 */ /* Specifies options for computing all or part of the matrix U: */ /* = 'A': all M columns of U are returned in array U: */ /* = 'S': the first min(m,n) columns of U (the left singular */ /* vectors) are returned in the array U; */ /* = 'O': the first min(m,n) columns of U (the left singular */ /* vectors) are overwritten on the array A; */ /* = 'N': no columns of U (no left singular vectors) are */ /* computed. */ /* JOBVT (input) CHARACTER*1 */ /* Specifies options for computing all or part of the matrix */ /* V**H: */ /* = 'A': all N rows of V**H are returned in the array VT; */ /* = 'S': the first min(m,n) rows of V**H (the right singular */ /* vectors) are returned in the array VT; */ /* = 'O': the first min(m,n) rows of V**H (the right singular */ /* vectors) are overwritten on the array A; */ /* = 'N': no rows of V**H (no right singular vectors) are */ /* computed. */ /* JOBVT and JOBU cannot both be 'O'. */ /* M (input) INTEGER */ /* The number of rows of the input matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the input matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, */ /* if JOBU = 'O', A is overwritten with the first min(m,n) */ /* columns of U (the left singular vectors, */ /* stored columnwise); */ /* if JOBVT = 'O', A is overwritten with the first min(m,n) */ /* rows of V**H (the right singular vectors, */ /* stored rowwise); */ /* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */ /* are destroyed. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ /* The singular values of A, sorted so that S(i) >= S(i+1). */ /* U (output) COMPLEX*16 array, dimension (LDU,UCOL) */ /* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */ /* If JOBU = 'A', U contains the M-by-M unitary matrix U; */ /* if JOBU = 'S', U contains the first min(m,n) columns of U */ /* (the left singular vectors, stored columnwise); */ /* if JOBU = 'N' or 'O', U is not referenced. */ /* LDU (input) INTEGER */ /* The leading dimension of the array U. LDU >= 1; if */ /* JOBU = 'S' or 'A', LDU >= M. */ /* VT (output) COMPLEX*16 array, dimension (LDVT,N) */ /* If JOBVT = 'A', VT contains the N-by-N unitary matrix */ /* V**H; */ /* if JOBVT = 'S', VT contains the first min(m,n) rows of */ /* V**H (the right singular vectors, stored rowwise); */ /* if JOBVT = 'N' or 'O', VT is not referenced. */ /* LDVT (input) INTEGER */ /* The leading dimension of the array VT. LDVT >= 1; if */ /* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */ /* 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 >= 1. */ /* LWORK >= 2*MIN(M,N)+MAX(M,N). */ /* For good performance, LWORK should generally be larger. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension */ /* (max(3*min(M,N),5*min(M,N)-4)) */ /* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the */ /* unconverged superdiagonal elements of an upper bidiagonal */ /* matrix B whose diagonal is in S (not necessarily sorted). */ /* B satisfies A = U * B * VT, so it has the same singular */ /* values as A, and singular vectors related by U and VT. */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if ZBDSQR did not converge, INFO specifies how many */ /* superdiagonals of an intermediate bidiagonal form B */ /* did not converge to zero. See the description of RWORK */ /* above for details. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --s; u_dim1 = *ldu; u_offset = u_dim1 + 1; u -= u_offset; vt_dim1 = *ldvt; vt_offset = vt_dim1 + 1; vt -= vt_offset; --work; --rwork; /* Function Body */ *info = 0; minmn = min(*m,*n); /* Writing concatenation */ i__1[0] = 1, a__1[0] = jobu; i__1[1] = 1, a__1[1] = jobvt; s_cat(ch__1, a__1, i__1, &c__2, 2L); mnthr = ilaenv_(&c__6, "ZGESVD", ch__1, m, n, &c__0, &c__0, 6L, 2L); wntua = lsame_(jobu, "A", 1L, 1L); wntus = lsame_(jobu, "S", 1L, 1L); wntuas = wntua || wntus; wntuo = lsame_(jobu, "O", 1L, 1L); wntun = lsame_(jobu, "N", 1L, 1L); wntva = lsame_(jobvt, "A", 1L, 1L); wntvs = lsame_(jobvt, "S", 1L, 1L); wntvas = wntva || wntvs; wntvo = lsame_(jobvt, "O", 1L, 1L); wntvn = lsame_(jobvt, "N", 1L, 1L); minwrk = 1; if (! (wntua || wntus || wntuo || wntun)) { *info = -1; } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*lda < max(1,*m)) { *info = -6; } else if (*ldu < 1 || wntuas && *ldu < *m) { *info = -9; } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) { *info = -11; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* CWorkspace refers to complex workspace, and RWorkspace to */ /* real workspace. NB refers to the optimal block size for the */ /* immediately following subroutine, as returned by ILAENV.) */ if (*info == 0 && *lwork >= 1 && *m > 0 && *n > 0) { if (*m >= *n) { /* Space needed for ZBDSQR is BDSPAC = MAX( 3*N, 5*N-4 ) */ if (*m >= mnthr) { if (wntun) { /* Path 1 (M much larger than N, JOBU='N') */ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = maxwrk, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); if (wntvo || wntvas) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(& c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } minwrk = *n * 3; maxwrk = max(minwrk,maxwrk); } else if (wntuo && wntvn) { /* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", m, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n; maxwrk = max(i__2,i__3); minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntuo && wntvas) { /* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */ /* 'A') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", m, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n; maxwrk = max(i__2,i__3); minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntus && wntvn) { /* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", m, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *n * *n + wrkbl; minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntus && wntvo) { /* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", m, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = (*n << 1) * *n + wrkbl; minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntus && wntvas) { /* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */ /* 'A') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", m, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *n * *n + wrkbl; minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntua && wntvn) { /* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR", " ", m, m, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *n * *n + wrkbl; minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntua && wntvo) { /* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR", " ", m, m, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = (*n << 1) * *n + wrkbl; minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } else if (wntua && wntvas) { /* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */ /* 'A') */ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR", " ", m, m, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(& c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *n * *n + wrkbl; minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } } else { /* Path 10 (M at least N, but not much larger) */ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L); if (wntus || wntuo) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*n << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "Q", m, n, n, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } if (wntua) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*n << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, n, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } if (! wntvn) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(& c__1, "ZUNGBR", "P", n, n, n, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } minwrk = (*n << 1) + *m; maxwrk = max(minwrk,maxwrk); } } else { /* Space needed for ZBDSQR is BDSPAC = MAX( 3*M, 5*M-4 ) */ if (*n >= mnthr) { if (wntvn) { /* Path 1t(N much larger than M, JOBVT='N' ) */ maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = maxwrk, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); if (wntuo || wntuas) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } minwrk = *m * 3; maxwrk = max(minwrk,maxwrk); } else if (wntvo && wntun) { /* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ", " ", m, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n; maxwrk = max(i__2,i__3); minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntvo && wntuas) { /* Path 3t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='O') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ", " ", m, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n; maxwrk = max(i__2,i__3); minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntvs && wntun) { /* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ", " ", m, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *m * *m + wrkbl; minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntvs && wntuo) { /* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ", " ", m, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = (*m << 1) * *m + wrkbl; minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntvs && wntuas) { /* Path 6t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='S') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ", " ", m, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *m * *m + wrkbl; minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntva && wntun) { /* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ", " ", n, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *m * *m + wrkbl; minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntva && wntuo) { /* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ", " ", n, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = (*m << 1) * *m + wrkbl; minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } else if (wntva && wntuas) { /* Path 9t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='A') */ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & c_n1, &c_n1, 6L, 1L); /* Computing MAX */ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ", " ", n, n, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(& c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); /* Computing MAX */ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); wrkbl = max(i__2,i__3); maxwrk = *m * *m + wrkbl; minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } } else { /* Path 10t(N greater than M, but not much larger ) */ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L); if (wntvs || wntvo) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR", "P", m, n, m, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } if (wntva) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*m << 1) + *n * ilaenv_(&c__1, "ZUNGBR", "P", n, n, m, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } if (! wntun) { /* Computing MAX */ i__2 = maxwrk, i__3 = (*m << 1) + (*m - 1) * ilaenv_(& c__1, "ZUNGBR", "Q", m, m, m, &c_n1, 6L, 1L); maxwrk = max(i__2,i__3); } minwrk = (*m << 1) + *n; maxwrk = max(minwrk,maxwrk); } } work[1].r = (doublereal) maxwrk, work[1].i = 0.; } if (*lwork < minwrk) { *info = -13; } if (*info != 0) { i__2 = -(*info); xerbla_("ZGESVD", &i__2, 6L); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { if (*lwork >= 1) { work[1].r = 1., work[1].i = 0.; } return 0; } /* Get machine constants */ eps = dlamch_("P", 1L); smlnum = sqrt(dlamch_("S", 1L)) / eps; bignum = 1. / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = zlange_("M", m, n, &a[a_offset], lda, dum, 1L); iscl = 0; if (anrm > 0. && anrm < smlnum) { iscl = 1; zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & ierr, 1L); } else if (anrm > bignum) { iscl = 1; zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & ierr, 1L); } if (*m >= *n) { /* A has at least as many rows as columns. If A has sufficientl y */ /* more rows than columns, first reduce using the QR */ /* decomposition (if sufficient workspace available) */ if (*m >= mnthr) { if (wntun) { /* Path 1 (M much larger than N, JOBU='N') */ /* No left singular vectors to be computed */ itau = 1; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: need 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & i__2, &ierr); /* Zero out below R */ i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda, 1L); ie = 1; itauq = 1; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in A */ /* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[ itauq], &work[itaup], &work[iwork], &i__2, &ierr); ncvt = 0; if (wntvo || wntvas) { /* If right singular vectors desired, gene rate P'. */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N- 1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], & work[iwork], &i__2, &ierr, 1L); ncvt = *n; } irwork = ie + *n; /* Perform bidiagonal QR iteration, computing rig ht */ /* singular vectors of A in A if desired */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[ irwork], info, 1L); /* If right singular vectors desired in VT, copy them there */ if (wntvas) { zlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); } } else if (wntuo && wntvn) { /* Path 2 (M much larger than N, JOBU='O', JOBVT= 'N') */ /* N left singular vectors to be overwritten on A and */ /* no right singular vectors to be computed */ if (*lwork >= *n * *n + *n * 3) { /* Sufficient workspace for a fast algorit hm */ ir = 1; /* Computing MAX */ i__2 = wrkbl, i__3 = *lda * *n; if (*lwork >= max(i__2,i__3) + *lda * *n) { /* WORK(IU) is LDA by N, WORK(IR) i s LDA by N */ ldwrku = *lda; ldwrkr = *lda; } else /* if(complicated condition) */ { /* Computing MAX */ i__2 = wrkbl, i__3 = *lda * *n; if (*lwork >= max(i__2,i__3) + *n * *n) { /* WORK(IU) is LDA by N, WORK(I R) is N by N */ ldwrku = *lda; ldwrkr = *n; } else { /* WORK(IU) is LDWRKU by N, WOR K(IR) is N by N */ ldwrku = (*lwork - *n * *n) / *n; ldwrkr = *n; } } itau = ir + ldwrkr * *n; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need N*N+2*N, prefer N*N+N +N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] , &i__2, &ierr); /* Copy R to WORK(IR) and zero out below i t */ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1], & ldwrkr, 1L); /* Generate Q in A */ /* (CWorkspace: need N*N+2*N, prefer N*N+N +N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefer N*N+2 *N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], &i__2, & ierr); /* Generate left vectors bidiagonalizing R */ /* (CWorkspace: need N*N+3*N, prefer N*N+2 *N+N*NB) */ /* (RWorkspace: need 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, comput ing left */ /* singular vectors of R in WORK(IR) */ /* (CWorkspace: need N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie], cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1, &rwork[ irwork], info, 1L); iu = itauq; /* Multiply Q in A by left singular vector s of R in */ /* WORK(IR), storing result in WORK(IU) an d copying to A */ /* (CWorkspace: need N*N+N, prefer N*N+M*N ) */ /* (RWorkspace: 0) */ i__2 = *m; i__3 = ldwrku; for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { /* Computing MIN */ i__4 = *m - i__ + 1; chunk = min(i__4,ldwrku); zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1] , lda, &work[ir], &ldwrkr, &c_b1, &work[iu], & ldwrku, 1L, 1L); zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ + a_dim1], lda, 1L); /* L10: */ } } else { /* Insufficient workspace for a fast algor ithm */ ie = 1; itauq = 1; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize A */ /* (CWorkspace: need 2*N+M, prefer 2*N+(M+ N)*NB) */ /* (RWorkspace: N) */ i__3 = *lwork - iwork + 1; zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[ itauq], &work[itaup], &work[iwork], &i__3, &ierr); /* Generate left vectors bidiagonalizing A */ /* (CWorkspace: need 3*N, prefer 2*N+N*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & work[iwork], &i__3, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, comput ing left */ /* singular vectors of A in A */ /* (CWorkspace: need 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie], cdum, &c__1, &a[a_offset], lda, cdum, &c__1, &rwork[ irwork], info, 1L); } } else if (wntuo && wntvas) { /* Path 3 (M much larger than N, JOBU='O', JOBVT= 'S' or 'A') */ /* N left singular vectors to be overwritten on A and */ /* N right singular vectors to be computed in VT */ if (*lwork >= *n * *n + *n * 3) { /* Sufficient workspace for a fast algorit hm */ ir = 1; /* Computing MAX */ i__3 = wrkbl, i__2 = *lda * *n; if (*lwork >= max(i__3,i__2) + *lda * *n) { /* WORK(IU) is LDA by N and WORK(IR ) is LDA by N */ ldwrku = *lda; ldwrkr = *lda; } else /* if(complicated condition) */ { /* Computing MAX */ i__3 = wrkbl, i__2 = *lda * *n; if (*lwork >= max(i__3,i__2) + *n * *n) { /* WORK(IU) is LDA by N and WOR K(IR) is N by N */ ldwrku = *lda; ldwrkr = *n; } else { /* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */ ldwrku = (*lwork - *n * *n) / *n; ldwrkr = *n; } } itau = ir + ldwrkr * *n; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need N*N+2*N, prefer N*N+N +N*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] , &i__3, &ierr); /* Copy R to VT, zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); i__3 = *n - 1; i__2 = *n - 1; zlaset_("L", &i__3, &i__2, &c_b1, &c_b1, &vt[vt_dim1 + 2], ldvt, 1L); /* Generate Q in A */ /* (CWorkspace: need N*N+2*N, prefer N*N+N +N*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__3, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in VT, copying result t o WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefer N*N+2 *N+2*N*NB) */ /* (RWorkspace: need N) */ i__3 = *lwork - iwork + 1; zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], &i__3, & ierr); zlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], & ldwrkr, 1L); /* Generate left vectors bidiagonalizing R in WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefer N*N+2 *N+N*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & work[iwork], &i__3, &ierr, 1L); /* Generate right vectors bidiagonalizing R in VT */ /* (CWorkspace: need N*N+3*N-1, prefer N*N +2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__3, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, comput ing left */ /* singular vectors of R in WORK(IR) and c omputing right */ /* singular vectors of R in VT */ /* (CWorkspace: need N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &work[ir], &ldwrkr, cdum, &c__1, &rwork[irwork], info, 1L); iu = itauq; /* Multiply Q in A by left singular vector s of R in */ /* WORK(IR), storing result in WORK(IU) an d copying to A */ /* (CWorkspace: need N*N+N, prefer N*N+M*N ) */ /* (RWorkspace: 0) */ i__3 = *m; i__2 = ldwrku; for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += i__2) { /* Computing MIN */ i__4 = *m - i__ + 1; chunk = min(i__4,ldwrku); zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1] , lda, &work[ir], &ldwrkr, &c_b1, &work[iu], & ldwrku, 1L, 1L); zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ + a_dim1], lda, 1L); /* L20: */ } } else { /* Insufficient workspace for a fast algor ithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] , &i__2, &ierr); /* Copy R to VT, zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1 + 2], ldvt, 1L); /* Generate Q in A */ /* (CWorkspace: need 2*N, prefer N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in VT */ /* (CWorkspace: need 3*N, prefer 2*N+2*N*N B) */ /* (RWorkspace: N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], &i__2, & ierr); /* Multiply Q in A by left vectors bidiago nalizing R */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*N B) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, & work[itauq], &a[a_offset], lda, &work[iwork], & i__2, &ierr, 1L, 1L, 1L); /* Generate right vectors bidiagonalizing R in VT */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N- 1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, comput ing left */ /* singular vectors of A in A and computin g right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &rwork[irwork], info, 1L); } } else if (wntus) { if (wntvn) { /* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ /* N left singular vectors to be computed in U and */ /* no right singular vectors to be compute d */ if (*lwork >= *n * *n + *n * 3) { /* Sufficient workspace for a fast algorithm */ ir = 1; if (*lwork >= wrkbl + *lda * *n) { /* WORK(IR) is LDA by N */ ldwrkr = *lda; } else { /* WORK(IR) is N by N */ ldwrkr = *n; } itau = ir + ldwrkr * *n; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need N*N+2*N, prefe r N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy R to WORK(IR), zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], & ldwrkr, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1] , &ldwrkr, 1L); /* Generate Q in A */ /* (CWorkspace: need N*N+2*N, prefe r N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &a[a_offset], lda, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Generate left vectors bidiagonal izing R in WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IR ) */ /* (CWorkspace: need N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie], cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply Q in A by left singular vectors of R in */ /* WORK(IR), storing result in U */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, & work[ir], &ldwrkr, &c_b1, &u[u_offset], ldu, 1L, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Zero out below R in A */ i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda, 1L); /* Bidiagonalize R in A */ /* (CWorkspace: need 3*N, prefer 2* N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply Q in U by left vectors bidiagonalizing R */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & work[itauq], &u[u_offset], ldu, &work[iwork], &i__2, &ierr, 1L, 1L, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie], cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } } else if (wntvo) { /* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ /* N left singular vectors to be computed in U and */ /* N right singular vectors to be overwrit ten on A */ if (*lwork >= (*n << 1) * *n + *n * 3) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + (*lda << 1) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ ldwrku = *lda; ir = iu + ldwrku * *n; ldwrkr = *lda; } else if (*lwork >= wrkbl + (*lda + *n) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is N by N */ ldwrku = *lda; ir = iu + ldwrku * *n; ldwrkr = *n; } else { /* WORK(IU) is N by N and WO RK(IR) is N by N */ ldwrku = *n; ir = iu + ldwrku * *n; ldwrkr = *n; } itau = ir + ldwrkr * *n; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need 2*N*N+2*N, pre fer 2*N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1] , &ldwrku, 1L); /* Generate Q in A */ /* (CWorkspace: need 2*N*N+2*N, pre fer 2*N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &a[a_offset], lda, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), cop ying result to */ /* WORK(IR) */ /* (CWorkspace: need 2*N*N+3*N, */ /* prefer 2*N*N+2*N+2* N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], & ldwrkr, 1L); /* Generate left bidiagonalizing ve ctors in WORK(IU) */ /* (CWorkspace: need 2*N*N+3*N, pre fer 2*N*N+2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); /* Generate right bidiagonalizing v ectors in WORK(IR) */ /* (CWorkspace: need 2*N*N+3*N-1, */ /* prefer 2*N*N+2*N+(N -1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU ) and computing */ /* right singular vectors of R in W ORK(IR) */ /* (CWorkspace: need 2*N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[ ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply Q in A by left singular vectors of R in */ /* WORK(IU), storing result in U */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, & work[iu], &ldwrku, &c_b1, &u[u_offset], ldu, 1L, 1L); /* Copy right singular vectors of R to A */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset], lda, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Zero out below R in A */ i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda, 1L); /* Bidiagonalize R in A */ /* (CWorkspace: need 3*N, prefer 2* N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply Q in U by left vectors bidiagonalizing R */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & work[itauq], &u[u_offset], ldu, &work[iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate right vectors bidiagona lizing R in A */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and c omputing right */ /* singular vectors of A in A */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, &u[u_offset], ldu, cdum, & c__1, &rwork[irwork], info, 1L); } } else if (wntvas) { /* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */ /* or 'A') */ /* N left singular vectors to be computed in U and */ /* N right singular vectors to be computed in VT */ if (*lwork >= *n * *n + *n * 3) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + *lda * *n) { /* WORK(IU) is LDA by N */ ldwrku = *lda; } else { /* WORK(IU) is N by N */ ldwrku = *n; } itau = iu + ldwrku * *n; iwork = itau + *n; /* Compute A=Q*R */ /* (CWorkspace: need N*N+2*N, prefe r N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1] , &ldwrku, 1L); /* Generate Q in A */ /* (CWorkspace: need N*N+2*N, prefe r N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &a[a_offset], lda, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), cop ying result to VT */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset], ldvt, 1L); /* Generate left bidiagonalizing ve ctors in WORK(IU) */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); /* Generate right bidiagonalizing v ectors in VT */ /* (CWorkspace: need N*N+3*N-1, */ /* prefer N*N+2*N+(N-1 )*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU ) and computing */ /* right singular vectors of R in V T */ /* (CWorkspace: need N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &work[iu], &ldwrku, cdum, & c__1, &rwork[irwork], info, 1L); /* Multiply Q in A by left singular vectors of R in */ /* WORK(IU), storing result in U */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, & work[iu], &ldwrku, &c_b1, &u[u_offset], ldu, 1L, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); /* Copy R to VT, zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1 + 2], ldvt, 1L); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in VT */ /* (CWorkspace: need 3*N, prefer 2* N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply Q in U by left bidiagon alizing vectors */ /* in VT */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &work[itauq], &u[u_offset], ldu, &work[iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate right bidiagonalizing v ectors in VT */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and c omputing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &u[u_offset], ldu, cdum, & c__1, &rwork[irwork], info, 1L); } } } else if (wntua) { if (wntvn) { /* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ /* M left singular vectors to be computed in U and */ /* no right singular vectors to be compute d */ /* Computing MAX */ i__2 = *n + *m, i__3 = *n * 3; if (*lwork >= *n * *n + max(i__2,i__3)) { /* Sufficient workspace for a fast algorithm */ ir = 1; if (*lwork >= wrkbl + *lda * *n) { /* WORK(IR) is LDA by N */ ldwrkr = *lda; } else { /* WORK(IR) is N by N */ ldwrkr = *n; } itau = ir + ldwrkr * *n; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need N*N+2*N, prefe r N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Copy R to WORK(IR), zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], & ldwrkr, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1] , &ldwrkr, 1L); /* Generate Q in U */ /* (CWorkspace: need N*N+N+M, prefe r N*N+N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Generate left bidiagonalizing ve ctors in WORK(IR) */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IR ) */ /* (CWorkspace: need N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie], cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply Q in U by left singular vectors of R in */ /* WORK(IR), storing result in A */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, & work[ir], &ldwrkr, &c_b1, &a[a_offset], lda, 1L, 1L); /* Copy left singular vectors of A from A to U */ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need N+M, prefer N+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Zero out below R in A */ i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda, 1L); /* Bidiagonalize R in A */ /* (CWorkspace: need 3*N, prefer 2* N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply Q in U by left bidiagon alizing vectors */ /* in A */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & work[itauq], &u[u_offset], ldu, &work[iwork], &i__2, &ierr, 1L, 1L, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie], cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } } else if (wntvo) { /* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ /* M left singular vectors to be computed in U and */ /* N right singular vectors to be overwrit ten on A */ /* Computing MAX */ i__2 = *n + *m, i__3 = *n * 3; if (*lwork >= (*n << 1) * *n + max(i__2,i__3)) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + (*lda << 1) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ ldwrku = *lda; ir = iu + ldwrku * *n; ldwrkr = *lda; } else if (*lwork >= wrkbl + (*lda + *n) * *n) { /* WORK(IU) is LDA by N and WORK(IR) is N by N */ ldwrku = *lda; ir = iu + ldwrku * *n; ldwrkr = *n; } else { /* WORK(IU) is N by N and WO RK(IR) is N by N */ ldwrku = *n; ir = iu + ldwrku * *n; ldwrkr = *n; } itau = ir + ldwrkr * *n; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N*N+2*N, pre fer 2*N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need 2*N*N+N+M, pre fer 2*N*N+N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1] , &ldwrku, 1L); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), cop ying result to */ /* WORK(IR) */ /* (CWorkspace: need 2*N*N+3*N, */ /* prefer 2*N*N+2*N+2* N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], & ldwrkr, 1L); /* Generate left bidiagonalizing ve ctors in WORK(IU) */ /* (CWorkspace: need 2*N*N+3*N, pre fer 2*N*N+2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); /* Generate right bidiagonalizing v ectors in WORK(IR) */ /* (CWorkspace: need 2*N*N+3*N-1, */ /* prefer 2*N*N+2*N+(N -1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU ) and computing */ /* right singular vectors of R in W ORK(IR) */ /* (CWorkspace: need 2*N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[ ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply Q in U by left singular vectors of R in */ /* WORK(IU), storing result in A */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, & work[iu], &ldwrku, &c_b1, &a[a_offset], lda, 1L, 1L); /* Copy left singular vectors of A from A to U */ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Copy right singular vectors of R from WORK(IR) to A */ zlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset], lda, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need N+M, prefer N+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Zero out below R in A */ i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda, 1L); /* Bidiagonalize R in A */ /* (CWorkspace: need 3*N, prefer 2* N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply Q in U by left bidiagon alizing vectors */ /* in A */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & work[itauq], &u[u_offset], ldu, &work[iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate right bidiagonalizing v ectors in A */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and c omputing right */ /* singular vectors of A in A */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, &u[u_offset], ldu, cdum, & c__1, &rwork[irwork], info, 1L); } } else if (wntvas) { /* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */ /* or 'A') */ /* M left singular vectors to be computed in U and */ /* N right singular vectors to be computed in VT */ /* Computing MAX */ i__2 = *n + *m, i__3 = *n * 3; if (*lwork >= *n * *n + max(i__2,i__3)) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + *lda * *n) { /* WORK(IU) is LDA by N */ ldwrku = *lda; } else { /* WORK(IU) is N by N */ ldwrku = *n; } itau = iu + ldwrku * *n; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need N*N+2*N, prefe r N*N+N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need N*N+N+M, prefe r N*N+N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); /* Copy R to WORK(IU), zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1] , &ldwrku, 1L); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in WORK(IU), cop ying result to VT */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset], ldvt, 1L); /* Generate left bidiagonalizing ve ctors in WORK(IU) */ /* (CWorkspace: need N*N+3*N, prefe r N*N+2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); /* Generate right bidiagonalizing v ectors in VT */ /* (CWorkspace: need N*N+3*N-1, */ /* prefer N*N+2*N+(N-1 )*NB) */ /* (RWorkspace: need 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of R in WORK(IU ) and computing */ /* right singular vectors of R in V T */ /* (CWorkspace: need N*N) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &work[iu], &ldwrku, cdum, & c__1, &rwork[irwork], info, 1L); /* Multiply Q in U by left singular vectors of R in */ /* WORK(IU), storing result in A */ /* (CWorkspace: need N*N) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, & work[iu], &ldwrku, &c_b1, &a[a_offset], lda, 1L, 1L); /* Copy left singular vectors of A from A to U */ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *n; /* Compute A=Q*R, copying result to U */ /* (CWorkspace: need 2*N, prefer N+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); /* Generate Q in U */ /* (CWorkspace: need N+M, prefer N+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], & work[iwork], &i__2, &ierr); /* Copy R from A to VT, zeroing out below it */ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); i__2 = *n - 1; i__3 = *n - 1; zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1 + 2], ldvt, 1L); ie = 1; itauq = itau; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize R in VT */ /* (CWorkspace: need 3*N, prefer 2* N+2*N*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply Q in U by left bidiagon alizing vectors */ /* in VT */ /* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &work[itauq], &u[u_offset], ldu, &work[iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate right bidiagonalizing v ectors in VT */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ itaup], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *n; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and c omputing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &u[u_offset], ldu, cdum, & c__1, &rwork[irwork], info, 1L); } } } } else { /* M .LT. MNTHR */ /* Path 10 (M at least N, but not much larger) */ /* Reduce to bidiagonal form without QR decomposition */ ie = 1; itauq = 1; itaup = itauq + *n; iwork = itaup + *n; /* Bidiagonalize A */ /* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */ /* (RWorkspace: need N) */ i__2 = *lwork - iwork + 1; zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], &i__2, &ierr); if (wntuas) { /* If left singular vectors desired in U, copy re sult to U */ /* and generate left bidiagonalizing vectors in U */ /* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB) */ /* (RWorkspace: 0) */ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L); if (wntus) { ncu = *n; } if (wntua) { ncu = *m; } i__2 = *lwork - iwork + 1; zungbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], & work[iwork], &i__2, &ierr, 1L); } if (wntvas) { /* If right singular vectors desired in VT, copy result to */ /* VT and generate right bidiagonalizing vectors in VT */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], & work[iwork], &i__2, &ierr, 1L); } if (wntuo) { /* If left singular vectors desired in A, generat e left */ /* bidiagonalizing vectors in A */ /* (CWorkspace: need 3*N, prefer 2*N+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[ iwork], &i__2, &ierr, 1L); } if (wntvo) { /* If right singular vectors desired in A, genera te right */ /* bidiagonalizing vectors in A */ /* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[ iwork], &i__2, &ierr, 1L); } irwork = ie + *n; if (wntuas || wntuo) { nru = *m; } if (wntun) { nru = 0; } if (wntvas || wntvo) { ncvt = *n; } if (wntvn) { ncvt = 0; } if (! wntuo && ! wntvo) { /* Perform bidiagonal QR iteration, if desired, c omputing */ /* left singular vectors in U and computing right singular */ /* vectors in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } else if (! wntuo && wntvo) { /* Perform bidiagonal QR iteration, if desired, c omputing */ /* left singular vectors in U and computing right singular */ /* vectors in A */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } else { /* Perform bidiagonal QR iteration, if desired, c omputing */ /* left singular vectors in A and computing right singular */ /* vectors in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, & rwork[irwork], info, 1L); } } } else { /* A has more columns than rows. If A has sufficiently more */ /* columns than rows, first reduce using the LQ decomposition ( if */ /* sufficient workspace available) */ if (*n >= mnthr) { if (wntvn) { /* Path 1t(N much larger than M, JOBVT='N') */ /* No right singular vectors to be computed */ itau = 1; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need 2*M, prefer M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & i__2, &ierr); /* Zero out above L */ i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1] , lda, 1L); ie = 1; itauq = 1; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in A */ /* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[ itauq], &work[itaup], &work[iwork], &i__2, &ierr); if (wntuo || wntuas) { /* If left singular vectors desired, gener ate Q */ /* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], & work[iwork], &i__2, &ierr, 1L); } irwork = ie + *m; nru = 0; if (wntuo || wntuas) { nru = *m; } /* Perform bidiagonal QR iteration, computing lef t singular */ /* vectors of A in A if desired */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &rwork[ie], cdum, & c__1, &a[a_offset], lda, cdum, &c__1, &rwork[irwork], info, 1L); /* If left singular vectors desired in U, copy th em there */ if (wntuas) { zlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L); } } else if (wntvo && wntun) { /* Path 2t(N much larger than M, JOBU='N', JOBVT= 'O') */ /* M right singular vectors to be overwritten on A and */ /* no left singular vectors to be computed */ if (*lwork >= *m * *m + *m * 3) { /* Sufficient workspace for a fast algorit hm */ ir = 1; /* Computing MAX */ i__2 = wrkbl, i__3 = *lda * *n; if (*lwork >= max(i__2,i__3) + *lda * *m) { /* WORK(IU) is LDA by N and WORK(IR ) is LDA by M */ ldwrku = *lda; chunk = *n; ldwrkr = *lda; } else /* if(complicated condition) */ { /* Computing MAX */ i__2 = wrkbl, i__3 = *lda * *n; if (*lwork >= max(i__2,i__3) + *m * *m) { /* WORK(IU) is LDA by N and WOR K(IR) is M by M */ ldwrku = *lda; chunk = *n; ldwrkr = *m; } else { /* WORK(IU) is M by CHUNK and W ORK(IR) is M by M */ ldwrku = *m; chunk = (*lwork - *m * *m) / *m; ldwrkr = *m; } } itau = ir + ldwrkr * *m; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need M*M+2*M, prefer M*M+M +M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] , &i__2, &ierr); /* Copy L to WORK(IR) and zero out above i t */ zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir + ldwrkr], &ldwrkr, 1L); /* Generate Q in A */ /* (CWorkspace: need M*M+2*M, prefer M*M+M +M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IR) */ /* (CWorkspace: need M*M+3*M, prefer M*M+2 *M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], &i__2, & ierr); /* Generate right vectors bidiagonalizing L */ /* (CWorkspace: need M*M+3*M-1, prefer M*M +2*M+(M-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, comput ing right */ /* singular vectors of L in WORK(IR) */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &work[ ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &rwork[ irwork], info, 1L); iu = itauq; /* Multiply right singular vectors of L in WORK(IR) by Q */ /* in A, storing result in WORK(IU) and co pying to A */ /* (CWorkspace: need M*M+M, prefer M*M+M*N ) */ /* (RWorkspace: 0) */ i__2 = *n; i__3 = chunk; for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { /* Computing MIN */ i__4 = *n - i__ + 1; blk = min(i__4,chunk); zgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], & ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, & work[iu], &ldwrku, 1L, 1L); zlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ * a_dim1 + 1], lda, 1L); /* L30: */ } } else { /* Insufficient workspace for a fast algor ithm */ ie = 1; itauq = 1; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize A */ /* (CWorkspace: need 2*M+N, prefer 2*M+(M+ N)*NB) */ /* (RWorkspace: need M) */ i__3 = *lwork - iwork + 1; zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[ itauq], &work[itaup], &work[iwork], &i__3, &ierr); /* Generate right vectors bidiagonalizing A */ /* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & work[iwork], &i__3, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, comput ing right */ /* singular vectors of A in A */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("L", m, n, &c__0, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[ irwork], info, 1L); } } else if (wntvo && wntuas) { /* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */ /* M right singular vectors to be overwritten on A and */ /* M left singular vectors to be computed in U */ if (*lwork >= *m * *m + *m * 3) { /* Sufficient workspace for a fast algorit hm */ ir = 1; /* Computing MAX */ i__3 = wrkbl, i__2 = *lda * *n; if (*lwork >= max(i__3,i__2) + *lda * *m) { /* WORK(IU) is LDA by N and WORK(IR ) is LDA by M */ ldwrku = *lda; chunk = *n; ldwrkr = *lda; } else /* if(complicated condition) */ { /* Computing MAX */ i__3 = wrkbl, i__2 = *lda * *n; if (*lwork >= max(i__3,i__2) + *m * *m) { /* WORK(IU) is LDA by N and WOR K(IR) is M by M */ ldwrku = *lda; chunk = *n; ldwrkr = *m; } else { /* WORK(IU) is M by CHUNK and W ORK(IR) is M by M */ ldwrku = *m; chunk = (*lwork - *m * *m) / *m; ldwrkr = *m; } } itau = ir + ldwrkr * *m; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need M*M+2*M, prefer M*M+M +M*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] , &i__3, &ierr); /* Copy L to U, zeroing about above it */ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L); i__3 = *m - 1; i__2 = *m - 1; zlaset_("U", &i__3, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1], ldu, 1L); /* Generate Q in A */ /* (CWorkspace: need M*M+2*M, prefer M*M+M +M*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ iwork], &i__3, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in U, copying result to WORK(IR) */ /* (CWorkspace: need M*M+3*M, prefer M*M+2 *M+2*M*NB) */ /* (RWorkspace: need M) */ i__3 = *lwork - iwork + 1; zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[ itauq], &work[itaup], &work[iwork], &i__3, &ierr); zlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr, 1L); /* Generate right vectors bidiagonalizing L in WORK(IR) */ /* (CWorkspace: need M*M+3*M-1, prefer M*M +2*M+(M-1)*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & work[iwork], &i__3, &ierr, 1L); /* Generate left vectors bidiagonalizing L in U */ /* (CWorkspace: need M*M+3*M, prefer M*M+2 *M+M*NB) */ /* (RWorkspace: 0) */ i__3 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], & work[iwork], &i__3, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, comput ing left */ /* singular vectors of L in U, and computi ng right */ /* singular vectors of L in WORK(IR) */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ir], &ldwrkr, &u[u_offset], ldu, cdum, &c__1, &rwork[ irwork], info, 1L); iu = itauq; /* Multiply right singular vectors of L in WORK(IR) by Q */ /* in A, storing result in WORK(IU) and co pying to A */ /* (CWorkspace: need M*M+M, prefer M*M+M*N )) */ /* (RWorkspace: 0) */ i__3 = *n; i__2 = chunk; for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += i__2) { /* Computing MIN */ i__4 = *n - i__ + 1; blk = min(i__4,chunk); zgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], & ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, & work[iu], &ldwrku, 1L, 1L); zlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ * a_dim1 + 1], lda, 1L); /* L40: */ } } else { /* Insufficient workspace for a fast algor ithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need 2*M, prefer M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] , &i__2, &ierr); /* Copy L to U, zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1], ldu, 1L); /* Generate Q in A */ /* (CWorkspace: need 2*M, prefer M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in U */ /* (CWorkspace: need 3*M, prefer 2*M+2*M*N B) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[ itauq], &work[itaup], &work[iwork], &i__2, &ierr); /* Multiply right vectors bidiagonalizing L by Q in A */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*N B) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &work[ itaup], &a[a_offset], lda, &work[iwork], &i__2, & ierr, 1L, 1L, 1L); /* Generate left vectors bidiagonalizing L in U */ /* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], & work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, comput ing left */ /* singular vectors of A in U and computin g right */ /* singular vectors of A in A */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } } else if (wntvs) { if (wntun) { /* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ /* M right singular vectors to be computed in VT and */ /* no left singular vectors to be computed */ if (*lwork >= *m * *m + *m * 3) { /* Sufficient workspace for a fast algorithm */ ir = 1; if (*lwork >= wrkbl + *lda * *m) { /* WORK(IR) is LDA by M */ ldwrkr = *lda; } else { /* WORK(IR) is M by M */ ldwrkr = *m; } itau = ir + ldwrkr * *m; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need M*M+2*M, prefe r M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy L to WORK(IR), zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], & ldwrkr, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir + ldwrkr], &ldwrkr, 1L); /* Generate Q in A */ /* (CWorkspace: need M*M+2*M, prefe r M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &a[a_offset], lda, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IR) */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Generate right vectors bidiagona lizing L in */ /* WORK(IR) */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+(M-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of L in WORK(IR ) */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], & work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, & rwork[irwork], info, 1L); /* Multiply right singular vectors of L in WORK(IR) by */ /* Q in A, storing result in VT */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, & a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt, 1L, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy result to VT */ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Zero out above L in A */ i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1], lda, 1L); /* Bidiagonalize L in A */ /* (CWorkspace: need 3*M, prefer 2* M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply right vectors bidiagona lizing L by Q in VT */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, & work[itaup], &vt[vt_offset], ldvt, &work[ iwork], &i__2, &ierr, 1L, 1L, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], & vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1, &rwork[irwork], info, 1L); } } else if (wntuo) { /* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ /* M right singular vectors to be computed in VT and */ /* M left singular vectors to be overwritt en on A */ if (*lwork >= (*m << 1) * *m + *m * 3) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + (*lda << 1) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ ldwrku = *lda; ir = iu + ldwrku * *m; ldwrkr = *lda; } else if (*lwork >= wrkbl + (*lda + *m) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is M by M */ ldwrku = *lda; ir = iu + ldwrku * *m; ldwrkr = *m; } else { /* WORK(IU) is M by M and WO RK(IR) is M by M */ ldwrku = *m; ir = iu + ldwrku * *m; ldwrkr = *m; } itau = ir + ldwrkr * *m; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need 2*M*M+2*M, pre fer 2*M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out below it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu + ldwrku], &ldwrku, 1L); /* Generate Q in A */ /* (CWorkspace: need 2*M*M+2*M, pre fer 2*M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &a[a_offset], lda, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), cop ying result to */ /* WORK(IR) */ /* (CWorkspace: need 2*M*M+3*M, */ /* prefer 2*M*M+2*M+2* M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], & ldwrkr, 1L); /* Generate right bidiagonalizing v ectors in WORK(IU) */ /* (CWorkspace: need 2*M*M+3*M-1, */ /* prefer 2*M*M+2*M+(M -1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); /* Generate left bidiagonalizing ve ctors in WORK(IR) */ /* (CWorkspace: need 2*M*M+3*M, pre fer 2*M*M+2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in WORK(IR ) and computing */ /* right singular vectors of L in W ORK(IU) */ /* (CWorkspace: need 2*M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in A, storing result in VT */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, & a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt, 1L, 1L); /* Copy left singular vectors of L to A */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset], lda, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Zero out above L in A */ i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1], lda, 1L); /* Bidiagonalize L in A */ /* (CWorkspace: need 3*M, prefer 2* M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply right vectors bidiagona lizing L by Q in VT */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, & work[itaup], &vt[vt_offset], ldvt, &work[ iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate left bidiagonalizing ve ctors of L in A */ /* (CWorkspace: need 3*M, prefer 2* M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in A and c omputing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &a[a_offset], lda, cdum, & c__1, &rwork[irwork], info, 1L); } } else if (wntuas) { /* Path 6t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='S') */ /* M right singular vectors to be computed in VT and */ /* M left singular vectors to be computed in U */ if (*lwork >= *m * *m + *m * 3) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + *lda * *m) { /* WORK(IU) is LDA by N */ ldwrku = *lda; } else { /* WORK(IU) is LDA by M */ ldwrku = *m; } itau = iu + ldwrku * *m; iwork = itau + *m; /* Compute A=L*Q */ /* (CWorkspace: need M*M+2*M, prefe r M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu + ldwrku], &ldwrku, 1L); /* Generate Q in A */ /* (CWorkspace: need M*M+2*M, prefe r M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &a[a_offset], lda, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), cop ying result to U */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset], ldu, 1L); /* Generate right bidiagonalizing v ectors in WORK(IU) */ /* (CWorkspace: need M*M+3*M-1, */ /* prefer M*M+2*M+(M-1 )*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); /* Generate left bidiagonalizing ve ctors in U */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in U and c omputing right */ /* singular vectors of L in WORK(IU ) */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in A, storing result in VT */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, & a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt, 1L, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); /* Copy L to U, zeroing out above i t */ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1], ldu, 1L); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in U */ /* (CWorkspace: need 3*M, prefer 2* M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply right bidiagonalizing v ectors in U by Q */ /* in VT */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, & work[itaup], &vt[vt_offset], ldvt, &work[ iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate left bidiagonalizing ve ctors in U */ /* (CWorkspace: need 3*M, prefer 2* M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and c omputing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &u[u_offset], ldu, cdum, & c__1, &rwork[irwork], info, 1L); } } } else if (wntva) { if (wntun) { /* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ /* N right singular vectors to be computed in VT and */ /* no left singular vectors to be computed */ /* Computing MAX */ i__2 = *n + *m, i__3 = *m * 3; if (*lwork >= *m * *m + max(i__2,i__3)) { /* Sufficient workspace for a fast algorithm */ ir = 1; if (*lwork >= wrkbl + *lda * *m) { /* WORK(IR) is LDA by M */ ldwrkr = *lda; } else { /* WORK(IR) is M by M */ ldwrkr = *m; } itau = ir + ldwrkr * *m; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need M*M+2*M, prefe r M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Copy L to WORK(IR), zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], & ldwrkr, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir + ldwrkr], &ldwrkr, 1L); /* Generate Q in VT */ /* (CWorkspace: need M*M+M+N, prefe r M*M+M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IR) */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Generate right bidiagonalizing v ectors in WORK(IR) */ /* (CWorkspace: need M*M+3*M-1, */ /* prefer M*M+2*M+(M-1 )*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of L in WORK(IR ) */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], & work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, & rwork[irwork], info, 1L); /* Multiply right singular vectors of L in WORK(IR) by */ /* Q in VT, storing result in A */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, & vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda, 1L, 1L); /* Copy right singular vectors of A from A to VT */ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need M+N, prefer M+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Zero out above L in A */ i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1], lda, 1L); /* Bidiagonalize L in A */ /* (CWorkspace: need 3*M, prefer 2* M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply right bidiagonalizing v ectors in A by Q */ /* in VT */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, & work[itaup], &vt[vt_offset], ldvt, &work[ iwork], &i__2, &ierr, 1L, 1L, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], & vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1, &rwork[irwork], info, 1L); } } else if (wntuo) { /* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ /* N right singular vectors to be computed in VT and */ /* M left singular vectors to be overwritt en on A */ /* Computing MAX */ i__2 = *n + *m, i__3 = *m * 3; if (*lwork >= (*m << 1) * *m + max(i__2,i__3)) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + (*lda << 1) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ ldwrku = *lda; ir = iu + ldwrku * *m; ldwrkr = *lda; } else if (*lwork >= wrkbl + (*lda + *m) * *m) { /* WORK(IU) is LDA by M and WORK(IR) is M by M */ ldwrku = *lda; ir = iu + ldwrku * *m; ldwrkr = *m; } else { /* WORK(IU) is M by M and WO RK(IR) is M by M */ ldwrku = *m; ir = iu + ldwrku * *m; ldwrkr = *m; } itau = ir + ldwrkr * *m; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need 2*M*M+2*M, pre fer 2*M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need 2*M*M+M+N, pre fer 2*M*M+M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu + ldwrku], &ldwrku, 1L); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), cop ying result to */ /* WORK(IR) */ /* (CWorkspace: need 2*M*M+3*M, */ /* prefer 2*M*M+2*M+2* M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], & ldwrkr, 1L); /* Generate right bidiagonalizing v ectors in WORK(IU) */ /* (CWorkspace: need 2*M*M+3*M-1, */ /* prefer 2*M*M+2*M+(M -1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); /* Generate left bidiagonalizing ve ctors in WORK(IR) */ /* (CWorkspace: need 2*M*M+3*M, pre fer 2*M*M+2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] , &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in WORK(IR ) and computing */ /* right singular vectors of L in W ORK(IU) */ /* (CWorkspace: need 2*M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in VT, storing result in A */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, & vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda, 1L, 1L); /* Copy right singular vectors of A from A to VT */ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Copy left singular vectors of A from WORK(IR) to A */ zlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset], lda, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need M+N, prefer M+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Zero out above L in A */ i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1], lda, 1L); /* Bidiagonalize L in A */ /* (CWorkspace: need 3*M, prefer 2* M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply right bidiagonalizing v ectors in A by Q */ /* in VT */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, & work[itaup], &vt[vt_offset], ldvt, &work[ iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate left bidiagonalizing ve ctors in A */ /* (CWorkspace: need 3*M, prefer 2* M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in A and c omputing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &a[a_offset], lda, cdum, & c__1, &rwork[irwork], info, 1L); } } else if (wntuas) { /* Path 9t(N much larger than M, JOBU='S' or 'A', */ /* JOBVT='A') */ /* N right singular vectors to be computed in VT and */ /* M left singular vectors to be computed in U */ /* Computing MAX */ i__2 = *n + *m, i__3 = *m * 3; if (*lwork >= *m * *m + max(i__2,i__3)) { /* Sufficient workspace for a fast algorithm */ iu = 1; if (*lwork >= wrkbl + *lda * *m) { /* WORK(IU) is LDA by M */ ldwrku = *lda; } else { /* WORK(IU) is M by M */ ldwrku = *m; } itau = iu + ldwrku * *m; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need M*M+2*M, prefe r M*M+M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need M*M+M+N, prefe r M*M+M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); /* Copy L to WORK(IU), zeroing out above it */ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & ldwrku, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu + ldwrku], &ldwrku, 1L); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in WORK(IU), cop ying result to U */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); zlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset], ldu, 1L); /* Generate right bidiagonalizing v ectors in WORK(IU) */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+(M-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] , &work[iwork], &i__2, &ierr, 1L); /* Generate left bidiagonalizing ve ctors in U */ /* (CWorkspace: need M*M+3*M, prefe r M*M+2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of L in U and c omputing right */ /* singular vectors of L in WORK(IU ) */ /* (CWorkspace: need M*M) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1, &rwork[irwork], info, 1L); /* Multiply right singular vectors of L in WORK(IU) by */ /* Q in VT, storing result in A */ /* (CWorkspace: need M*M) */ /* (RWorkspace: 0) */ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, & vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda, 1L, 1L); /* Copy right singular vectors of A from A to VT */ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); } else { /* Insufficient workspace for a fas t algorithm */ itau = 1; iwork = itau + *m; /* Compute A=L*Q, copying result to VT */ /* (CWorkspace: need 2*M, prefer M+ M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ iwork], &i__2, &ierr); zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); /* Generate Q in VT */ /* (CWorkspace: need M+N, prefer M+ N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & work[iwork], &i__2, &ierr); /* Copy L to U, zeroing out above i t */ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L); i__2 = *m - 1; i__3 = *m - 1; zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1], ldu, 1L); ie = 1; itauq = itau; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize L in U */ /* (CWorkspace: need 3*M, prefer 2* M+2*M*NB) */ /* (RWorkspace: need M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], & work[itauq], &work[itaup], &work[iwork], & i__2, &ierr); /* Multiply right bidiagonalizing v ectors in U by Q */ /* in VT */ /* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, & work[itaup], &vt[vt_offset], ldvt, &work[ iwork], &i__2, &ierr, 1L, 1L, 1L); /* Generate left bidiagonalizing ve ctors in U */ /* (CWorkspace: need 3*M, prefer 2* M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, &ierr, 1L); irwork = ie + *m; /* Perform bidiagonal QR iteration, computing left */ /* singular vectors of A in U and c omputing right */ /* singular vectors of A in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &u[u_offset], ldu, cdum, & c__1, &rwork[irwork], info, 1L); } } } } else { /* N .LT. MNTHR */ /* Path 10t(N greater than M, but not much larger) */ /* Reduce to bidiagonal form without LQ decomposition */ ie = 1; itauq = 1; itaup = itauq + *m; iwork = itaup + *m; /* Bidiagonalize A */ /* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */ /* (RWorkspace: M) */ i__2 = *lwork - iwork + 1; zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[iwork], &i__2, &ierr); if (wntuas) { /* If left singular vectors desired in U, copy re sult to U */ /* and generate left bidiagonalizing vectors in U */ /* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) */ /* (RWorkspace: 0) */ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L); i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[ iwork], &i__2, &ierr, 1L); } if (wntvas) { /* If right singular vectors desired in VT, copy result to */ /* VT and generate right bidiagonalizing vectors in VT */ /* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB ) */ /* (RWorkspace: 0) */ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, 1L); if (wntva) { nrvt = *n; } if (wntvs) { nrvt = *m; } i__2 = *lwork - iwork + 1; zungbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__2, &ierr, 1L); } if (wntuo) { /* If left singular vectors desired in A, generat e left */ /* bidiagonalizing vectors in A */ /* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[ iwork], &i__2, &ierr, 1L); } if (wntvo) { /* If right singular vectors desired in A, genera te right */ /* bidiagonalizing vectors in A */ /* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ /* (RWorkspace: 0) */ i__2 = *lwork - iwork + 1; zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ iwork], &i__2, &ierr, 1L); } irwork = ie + *m; if (wntuas || wntuo) { nru = *m; } if (wntun) { nru = 0; } if (wntvas || wntvo) { ncvt = *n; } if (wntvn) { ncvt = 0; } if (! wntuo && ! wntvo) { /* Perform bidiagonal QR iteration, if desired, c omputing */ /* left singular vectors in U and computing right singular */ /* vectors in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } else if (! wntuo && wntvo) { /* Perform bidiagonal QR iteration, if desired, c omputing */ /* left singular vectors in U and computing right singular */ /* vectors in A */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, & rwork[irwork], info, 1L); } else { /* Perform bidiagonal QR iteration, if desired, c omputing */ /* left singular vectors in A and computing right singular */ /* vectors in VT */ /* (CWorkspace: 0) */ /* (RWorkspace: need BDSPAC) */ zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, & rwork[irwork], info, 1L); } } } /* Undo scaling if necessary */ if (iscl == 1) { if (anrm > bignum) { dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & minmn, &ierr, 1L); } if (*info != 0 && anrm > bignum) { i__2 = minmn - 1; dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &rwork[ ie], &minmn, &ierr, 1L); } if (anrm < smlnum) { dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & minmn, &ierr, 1L); } if (*info != 0 && anrm < smlnum) { i__2 = minmn - 1; dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &rwork[ ie], &minmn, &ierr, 1L); } } /* Return optimal workspace in WORK(1) */ work[1].r = (doublereal) maxwrk, work[1].i = 0.; return 0; /* End of ZGESVD */ } /* zgesvd_ */ /* zlaswp.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlaswp_(n, a, lda, k1, k2, ipiv, incx) integer *n; doublecomplex *a; integer *lda, *k1, *k2, *ipiv, *incx; { /* System generated locals */ integer a_dim1, a_offset, i__1; /* Local variables */ static integer i__; extern /* Subroutine */ int zswap_(); static integer ip, ix; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLASWP performs a series of row interchanges on the matrix A. */ /* One row interchange is initiated for each of rows K1 through K2 of A. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of columns of the matrix A. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the matrix of column dimension N to which the row */ /* interchanges will be applied. */ /* On exit, the permuted matrix. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. */ /* K1 (input) INTEGER */ /* The first element of IPIV for which a row interchange will */ /* be done. */ /* K2 (input) INTEGER */ /* The last element of IPIV for which a row interchange will */ /* be done. */ /* IPIV (input) INTEGER array, dimension (M*abs(INCX)) */ /* The vector of pivot indices. Only the elements in positions */ /* K1 through K2 of IPIV are accessed. */ /* IPIV(K) = L implies rows K and L are to be interchanged. */ /* INCX (input) INTEGER */ /* The increment between successive values of IPIV. If IPIV */ /* is negative, the pivots are applied in reverse order. */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Interchange row I with row IPIV(I) for each of rows K1 through K2. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --ipiv; /* Function Body */ if (*incx == 0) { return 0; } if (*incx > 0) { ix = *k1; } else { ix = (1 - *k2) * *incx + 1; } if (*incx == 1) { i__1 = *k2; for (i__ = *k1; i__ <= i__1; ++i__) { ip = ipiv[i__]; if (ip != i__) { zswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda); } /* L10: */ } } else if (*incx > 1) { i__1 = *k2; for (i__ = *k1; i__ <= i__1; ++i__) { ip = ipiv[ix]; if (ip != i__) { zswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda); } ix += *incx; /* L20: */ } } else if (*incx < 0) { i__1 = *k1; for (i__ = *k2; i__ >= i__1; --i__) { ip = ipiv[ix]; if (ip != i__) { zswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda); } ix += *incx; /* L30: */ } } return 0; /* End of ZLASWP */ } /* zlaswp_ */ /* zlanhs.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ doublereal zlanhs_(norm, n, a, lda, work, norm_len) char *norm; integer *n; doublecomplex *a; integer *lda; doublereal *work; ftnlen norm_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; doublereal ret_val, d__1, d__2; /* Builtin functions */ double z_abs(), sqrt(); /* Local variables */ static integer i__, j; static doublereal scale; extern logical lsame_(); static doublereal value; extern /* Subroutine */ int zlassq_(); static doublereal sum; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLANHS returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* Hessenberg matrix A. */ /* Description */ /* =========== */ /* ZLANHS returns the value */ /* ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in ZLANHS as described */ /* above. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, ZLANHS is */ /* set to zero. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The n by n upper Hessenberg matrix A; the part of A below the */ /* first sub-diagonal is not referenced. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(N,1). */ /* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */ /* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --work; /* Function Body */ if (*n == 0) { value = 0.; } else if (lsame_(norm, "M", 1L, 1L)) { /* Find max(abs(A(i,j))). */ value = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *n, i__4 = j + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]); value = max(d__1,d__2); /* L10: */ } /* L20: */ } } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') { /* Find norm1(A). */ value = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.; /* Computing MIN */ i__3 = *n, i__4 = j + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { sum += z_abs(&a[i__ + j * a_dim1]); /* L30: */ } value = max(value,sum); /* L40: */ } } else if (lsame_(norm, "I", 1L, 1L)) { /* Find normI(A). */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; /* L50: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *n, i__4 = j + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += z_abs(&a[i__ + j * a_dim1]); /* L60: */ } /* L70: */ } value = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__1 = value, d__2 = work[i__]; value = max(d__1,d__2); /* L80: */ } } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) { /* Find normF(A). */ scale = 0.; sum = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *n, i__4 = j + 1; i__2 = min(i__3,i__4); zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L90: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of ZLANHS */ } /* zlanhs_ */ /* zunmbr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zunmbr_(vect, side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, vect_len, side_len, trans_len) char *vect, *side, *trans; integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *c__; integer *ldc; doublecomplex *work; integer *lwork, *info; ftnlen vect_len; ftnlen side_len; ftnlen trans_len; { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; /* Local variables */ static logical left; extern logical lsame_(); static integer iinfo, i1, i2, mi, ni, nq, nw; extern /* Subroutine */ int xerbla_(); static logical notran, applyq; static char transt[1]; extern /* Subroutine */ int zunmlq_(), zunmqr_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* If VECT = 'Q', ZUNMBR 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', ZUNMBR 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 ZGEBRD 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 ZGEBRD. */ /* If VECT = 'P', the number of rows in the original */ /* matrix reduced by ZGEBRD. */ /* K >= 0. */ /* A (input) COMPLEX*16 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 ZGEBRD. */ /* 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*16 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 ZGEBRD in the array argument TAUQ or TAUP. */ /* 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**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*16 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. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; applyq = lsame_(vect, "Q", 1L, 1L); left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); /* 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", 1L, 1L)) { *info = -1; } else if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -2; } else if (! notran && ! lsame_(trans, "C", 1L, 1L)) { *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)) { *info = -13; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNMBR", &i__1, 6L); return 0; } /* Quick return if possible */ work[1].r = 1., work[1].i = 0.; if (*m == 0 || *n == 0) { return 0; } if (applyq) { /* Apply Q */ if (nq >= *k) { /* Q was determined by a call to ZGEBRD with nq >= k */ zunmqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], lwork, &iinfo, 1L, 1L); } else if (nq > 1) { /* Q was determined by a call to ZGEBRD 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; zunmqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] , &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, 1L, 1L); } } else { /* Apply P */ if (notran) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'N'; } if (nq > *k) { /* P was determined by a call to ZGEBRD with nq > k */ zunmlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], lwork, &iinfo, 1L, 1L); } else if (nq > 1) { /* P was determined by a call to ZGEBRD 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; zunmlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & iinfo, 1L, 1L); } } return 0; /* End of ZUNMBR */ } /* zunmbr_ */ /* zlange.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ doublereal zlange_(norm, m, n, a, lda, work, norm_len) char *norm; integer *m, *n; doublecomplex *a; integer *lda; doublereal *work; ftnlen norm_len; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; doublereal ret_val, d__1, d__2; /* Builtin functions */ double z_abs(), sqrt(); /* Local variables */ static integer i__, j; static doublereal scale; extern logical lsame_(); static doublereal value; extern /* Subroutine */ int zlassq_(); static doublereal sum; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLANGE returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* complex matrix A. */ /* Description */ /* =========== */ /* ZLANGE returns the value */ /* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in ZLANGE as described */ /* above. */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. When M = 0, */ /* ZLANGE is set to zero. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. When N = 0, */ /* ZLANGE is set to zero. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The m by n matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(M,1). */ /* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */ /* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --work; /* Function Body */ if (min(*m,*n) == 0) { value = 0.; } else if (lsame_(norm, "M", 1L, 1L)) { /* Find max(abs(A(i,j))). */ value = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]); value = max(d__1,d__2); /* L10: */ } /* L20: */ } } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') { /* Find norm1(A). */ value = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { sum += z_abs(&a[i__ + j * a_dim1]); /* L30: */ } value = max(value,sum); /* L40: */ } } else if (lsame_(norm, "I", 1L, 1L)) { /* Find normI(A). */ i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; /* L50: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += z_abs(&a[i__ + j * a_dim1]); /* L60: */ } /* L70: */ } value = 0.; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__1 = value, d__2 = work[i__]; value = max(d__1,d__2); /* L80: */ } } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) { /* Find normF(A). */ scale = 0.; sum = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { zlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L90: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of ZLANGE */ } /* zlange_ */ /* zung2r.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zung2r_(m, n, k, a, lda, tau, work, info) integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1; /* Local variables */ static integer i__, j, l; extern /* Subroutine */ int zscal_(), zlarf_(), xerbla_(); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNG2R 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) COMPLEX*16 array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument has an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *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; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNG2R", &i__1, 6L); return 0; } /* Quick return if possible */ if (*n <= 0) { return 0; } /* Initialise columns k+1:n to columns of the unit matrix */ i__1 = *n; for (j = *k + 1; j <= i__1; ++j) { i__2 = *m; for (l = 1; l <= i__2; ++l) { i__3 = l + j * a_dim1; a[i__3].r = 0., a[i__3].i = 0.; /* L10: */ } i__2 = j + j * a_dim1; a[i__2].r = 1., a[i__2].i = 0.; /* L20: */ } for (i__ = *k; i__ >= 1; --i__) { /* Apply H(i) to A(i:m,i:n) from the left */ if (i__ < *n) { i__1 = i__ + i__ * a_dim1; a[i__1].r = 1., a[i__1].i = 0.; i__1 = *m - i__ + 1; i__2 = *n - i__; zlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L); } if (i__ < *m) { i__1 = *m - i__; i__2 = i__; z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; zscal_(&i__1, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1); } i__1 = i__ + i__ * a_dim1; i__2 = i__; z__1.r = 1. - tau[i__2].r, z__1.i = 0. - tau[i__2].i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* Set A(1:i-1,i) to zero */ i__1 = i__ - 1; for (l = 1; l <= i__1; ++l) { i__2 = l + i__ * a_dim1; a[i__2].r = 0., a[i__2].i = 0.; /* L30: */ } /* L40: */ } return 0; /* End of ZUNG2R */ } /* zung2r_ */ /* zlacpy.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zlacpy_(uplo, m, n, a, lda, b, ldb, uplo_len) char *uplo; integer *m, *n; doublecomplex *a; integer *lda; doublecomplex *b; integer *ldb; ftnlen uplo_len; { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i__, j; extern logical lsame_(); /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* February 29, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLACPY copies all or part of a two-dimensional matrix A to another */ /* matrix B. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies the part of the matrix A to be copied to B. */ /* = 'U': Upper triangular part */ /* = 'L': Lower triangular part */ /* Otherwise: All of the matrix A */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The m by n matrix A. If UPLO = 'U', only the upper trapezium */ /* is accessed; if UPLO = 'L', only the lower trapezium is */ /* accessed. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* B (output) COMPLEX*16 array, dimension (LDB,N) */ /* On exit, B = A in the locations specified by UPLO. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,M). */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; /* Function Body */ if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(j,*m); for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; i__4 = i__ + j * a_dim1; b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L10: */ } /* L20: */ } } else if (lsame_(uplo, "L", 1L, 1L)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; i__4 = i__ + j * a_dim1; b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L30: */ } /* L40: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; i__4 = i__ + j * a_dim1; b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L50: */ } /* L60: */ } } return 0; /* End of ZLACPY */ } /* zlacpy_ */ /* zdrscl.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zdrscl_(n, sa, sx, incx) integer *n; doublereal *sa; doublecomplex *sx; integer *incx; { static doublereal cden; static logical done; static doublereal cnum, cden1, cnum1; extern /* Subroutine */ int dlabad_(); extern doublereal dlamch_(); extern /* Subroutine */ int zdscal_(); static doublereal bignum, smlnum, mul; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZDRSCL multiplies an n-element complex vector x by the real scalar */ /* 1/a. This is done without overflow or underflow as long as */ /* the final result x/a does not overflow or underflow. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of components of the vector x. */ /* SA (input) DOUBLE PRECISION */ /* The scalar a which is used to divide each component of x. */ /* SA must be >= 0, or the subroutine will divide by zero. */ /* SX (input/output) COMPLEX*16 array, dimension */ /* (1+(N-1)*abs(INCX)) */ /* The n-element vector x. */ /* INCX (input) INTEGER */ /* The increment between successive values of the vector SX. */ /* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick return if possible */ /* Parameter adjustments */ --sx; /* Function Body */ if (*n <= 0) { return 0; } /* Get machine parameters */ smlnum = dlamch_("S", 1L); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); /* Initialize the denominator to SA and the numerator to 1. */ cden = *sa; cnum = 1.; L10: cden1 = cden * smlnum; cnum1 = cnum / bignum; if (abs(cden1) > abs(cnum) && cnum != 0.) { /* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ mul = smlnum; done = FALSE_; cden = cden1; } else if (abs(cnum1) > abs(cden)) { /* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ mul = bignum; done = FALSE_; cnum = cnum1; } else { /* Multiply X by CNUM / CDEN and return. */ mul = cnum / cden; done = TRUE_; } /* Scale the vector X by MUL */ zdscal_(n, &mul, &sx[1], incx); if (! done) { goto L10; } return 0; /* End of ZDRSCL */ } /* zdrscl_ */ /* zunml2.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Subroutine */ int zunml2_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublecomplex *a; integer *lda; doublecomplex *tau, *c__; integer *ldc; doublecomplex *work; integer *info; ftnlen side_len; ftnlen trans_len; { /* 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(); /* Local variables */ static logical left; static doublecomplex taui; static integer i__; extern logical lsame_(); extern /* Subroutine */ int zlarf_(); static integer i1, i2, i3, ic, jc, mi, ni, nq; extern /* Subroutine */ int xerbla_(), zlacgv_(); static logical notran; static doublecomplex aii; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZUNML2 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(k)' . . . H(2)' H(1)' */ /* as returned by ZGELQF. 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. */ /* 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 */ /* ZGELQF in the first 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 ZGELQF. */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; /* Function Body */ *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); /* NQ is the order of Q */ if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "C", 1L, 1L)) { *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,*k)) { *info = -7; } else if (*ldc < max(1,*m)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("ZUNML2", &i__1, 6L); 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) 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) { d_cnjg(&z__1, &tau[i__]); taui.r = z__1.r, taui.i = z__1.i; } else { i__3 = i__; taui.r = tau[i__3].r, taui.i = tau[i__3].i; } if (i__ < nq) { i__3 = nq - i__; zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda); } i__3 = i__ + i__ * a_dim1; aii.r = a[i__3].r, aii.i = a[i__3].i; i__3 = i__ + i__ * a_dim1; a[i__3].r = 1., a[i__3].i = 0.; zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic + jc * c_dim1], ldc, &work[1], 1L); i__3 = i__ + i__ * a_dim1; a[i__3].r = aii.r, a[i__3].i = aii.i; if (i__ < nq) { i__3 = nq - i__; zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda); } /* L10: */ } return 0; /* End of ZUNML2 */ } /* zunml2_ */ /* zgeqrf.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zgeqrf_(m, n, a, lda, tau, work, lwork, info) integer *m, *n; doublecomplex *a; integer *lda; doublecomplex *tau, *work; integer *lwork, *info; { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i__, k, nbmin, iinfo; extern /* Subroutine */ int zgeqr2_(); static integer ib, nb, nx; extern /* Subroutine */ int xerbla_(); extern integer ilaenv_(); extern /* Subroutine */ int zlarfb_(); static integer ldwork; extern /* Subroutine */ int zlarft_(); static integer iws; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZGEQRF computes a QR factorization of a complex M-by-N matrix A: */ /* A = Q * R. */ /* Arguments */ /* ========= */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, the elements on and above the diagonal of the array */ /* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */ /* upper triangular if m >= n); the elements below the diagonal, */ /* with the array TAU, represent the unitary matrix Q as a */ /* product of min(m,n) elementary reflectors (see Further */ /* Details). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* 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 had an illegal value */ /* Further Details */ /* =============== */ /* The matrix Q is represented as a product of elementary reflectors */ /* Q = H(1) H(2) . . . H(k), where k = min(m,n). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */ /* and tau in TAU(i). */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; /* Function Body */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*m)) { *info = -4; } else if (*lwork < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGEQRF", &i__1, 6L); return 0; } /* Quick return if possible */ k = min(*m,*n); if (k == 0) { work[1].r = 1., work[1].i = 0.; return 0; } /* Determine the block size. */ nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &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, "ZGEQRF", " ", m, n, &c_n1, &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, "ZGEQRF", " ", m, n, &c_n1, & c_n1, 6L, 1L); nbmin = max(i__1,i__2); } } } if (nb >= nbmin && nb < k && nx < k) { /* Use blocked code initially */ i__1 = k - nx; i__2 = nb; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Computing MIN */ i__3 = k - i__ + 1; ib = min(i__3,nb); /* Compute the QR factorization of the current block */ /* A(i:m,i:i+ib-1) */ i__3 = *m - i__ + 1; zgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ 1], &iinfo); if (i__ + ib <= *n) { /* Form the triangular factor of the block reflec tor */ /* H = H(i) H(i+1) . . . H(i+ib-1) */ i__3 = *m - i__ + 1; zlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L); /* Apply H' to A(i:m,i+ib:n) from the left */ i__3 = *m - i__ + 1; i__4 = *n - i__ - ib + 1; zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise" , &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, & work[1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, 4L, 19L, 7L, 10L); } /* L10: */ } } else { i__ = 1; } /* Use unblocked code to factor the last or only block. */ if (i__ <= k) { i__2 = *m - i__ + 1; i__1 = *n - i__ + 1; zgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] , &iinfo); } work[1].r = (doublereal) iws, work[1].i = 0.; return 0; /* End of ZGEQRF */ } /* zgeqrf_ */ /* zlahqr.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ /* Subroutine */ int zlahqr_(wantt, wantz, n, ilo, ihi, h__, ldh, w, iloz, ihiz, z__, ldz, info) logical *wantt, *wantz; integer *n, *ilo, *ihi; doublecomplex *h__; integer *ldh; doublecomplex *w; integer *iloz, *ihiz; doublecomplex *z__; integer *ldz, *info; { /* System generated locals */ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4, d__5, d__6; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ double d_imag(); void z_sqrt(), d_cnjg(); /* Local variables */ static doublereal unfl, ovfl; static doublecomplex temp; static integer i__, j, k, l, m; static doublereal s; static doublecomplex t, u, v[2], x, y; extern /* Subroutine */ int zscal_(); static doublereal rtemp; static integer i1, i2; static doublereal rwork[1]; static doublecomplex t1; static doublereal t2; extern /* Subroutine */ int zcopy_(); static doublecomplex v2; extern doublereal dlapy2_(); extern /* Subroutine */ int dlabad_(); static doublereal h10; static doublecomplex h11; static doublereal h21; static doublecomplex h22; static integer nh; extern doublereal dlamch_(); static integer nz; extern /* Subroutine */ int zlarfg_(); extern /* Double Complex */ VOID zladiv_(); extern doublereal zlanhs_(); static doublereal smlnum; static doublecomplex h11s; static integer itn, its; static doublereal ulp; static doublecomplex sum; static doublereal tst1; /* -- LAPACK auxiliary routine (version 2.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZLAHQR is an auxiliary routine called by ZHSEQR to update the */ /* eigenvalues and Schur decomposition already computed by ZHSEQR, by */ /* dealing with the Hessenberg submatrix in rows and columns ILO to IHI. */ /* Arguments */ /* ========= */ /* WANTT (input) LOGICAL */ /* = .TRUE. : the full Schur form T is required; */ /* = .FALSE.: only eigenvalues are required. */ /* WANTZ (input) LOGICAL */ /* = .TRUE. : the matrix of Schur vectors Z is required; */ /* = .FALSE.: Schur vectors are not required. */ /* N (input) INTEGER */ /* The order of the matrix H. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that H is already upper triangular in rows and */ /* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */ /* ZLAHQR works primarily with the Hessenberg submatrix in rows */ /* and columns ILO to IHI, but applies transformations to all of */ /* H if WANTT is .TRUE.. */ /* 1 <= ILO <= max(1,IHI); IHI <= N. */ /* H (input/output) COMPLEX*16 array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if WANTT is .TRUE., H is upper triangular in rows */ /* and columns ILO:IHI, with any 2-by-2 diagonal blocks in */ /* standard form. If WANTT is .FALSE., the contents of H are */ /* unspecified on exit. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH >= max(1,N). */ /* W (output) COMPLEX*16 array, dimension (N) */ /* The computed eigenvalues ILO to IHI are stored in the */ /* corresponding elements of W. If WANTT is .TRUE., the */ /* eigenvalues are stored in the same order as on the diagonal */ /* of the Schur form returned in H, with W(i) = H(i,i). */ /* ILOZ (input) INTEGER */ /* IHIZ (input) INTEGER */ /* Specify the rows of Z to which transformations must be */ /* applied if WANTZ is .TRUE.. */ /* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ /* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */ /* If WANTZ is .TRUE., on entry Z must contain the current */ /* matrix Z of transformations accumulated by ZHSEQR, and on */ /* exit Z has been updated; transformations are applied only to */ /* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */ /* If WANTZ is .FALSE., Z is not referenced. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* > 0: if INFO = i, ZLAHQR failed to compute all the */ /* eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) */ /* iterations; elements i+1:ihi of W contain those */ /* eigenvalues which have been successfully computed. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = h_dim1 + 1; h__ -= h_offset; --w; z_dim1 = *ldz; z_offset = z_dim1 + 1; z__ -= z_offset; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n == 0) { return 0; } if (*ilo == *ihi) { i__1 = *ilo; i__2 = *ilo + *ilo * h_dim1; w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; return 0; } nh = *ihi - *ilo + 1; nz = *ihiz - *iloz + 1; /* Set machine-dependent constants for the stopping criterion. */ /* If norm(H) <= sqrt(OVFL), overflow should not occur. */ unfl = dlamch_("Safe minimum", 12L); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("Precision", 9L); smlnum = unfl * (nh / ulp); /* I1 and I2 are the indices of the first row and last column of H */ /* to which transformations must be applied. If eigenvalues only are */ /* being computed, I1 and I2 are set inside the main loop. */ if (*wantt) { i1 = 1; i2 = *n; } /* ITN is the total number of QR iterations allowed. */ itn = nh * 30; /* The main loop begins here. I is the loop index and decreases from */ /* IHI to ILO in steps of 1. Each iteration of the loop works */ /* with the active submatrix in rows and columns L to I. */ /* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */ /* H(L,L-1) is negligible so that the matrix splits. */ i__ = *ihi; L10: if (i__ < *ilo) { goto L130; } /* Perform QR iterations on rows and columns ILO to I until a */ /* submatrix of order 1 splits off at the bottom because a */ /* subdiagonal element has become negligible. */ l = *ilo; i__1 = itn; for (its = 0; its <= i__1; ++its) { /* Look for a single small subdiagonal element. */ i__2 = l + 1; for (k = i__; k >= i__2; --k) { i__3 = k - 1 + (k - 1) * h_dim1; i__4 = k + k * h_dim1; tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[k - 1 + (k - 1) * h_dim1]), abs(d__2)) + ((d__3 = h__[i__4].r, abs(d__3)) + (d__4 = d_imag(&h__[k + k * h_dim1]), abs( d__4))); if (tst1 == 0.) { i__3 = i__ - l + 1; tst1 = zlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, rwork, 1L); } i__3 = k + (k - 1) * h_dim1; /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) { goto L30; } /* L20: */ } L30: l = k; if (l > *ilo) { /* H(L,L-1) is negligible */ i__2 = l + (l - 1) * h_dim1; h__[i__2].r = 0., h__[i__2].i = 0.; } /* Exit from loop if a submatrix of order 1 has split off. */ if (l >= i__) { goto L120; } /* Now the active submatrix is in rows and columns L to I. If */ /* eigenvalues only are being computed, only the active submatr ix */ /* need be transformed. */ if (! (*wantt)) { i1 = l; i2 = i__; } if (its == 10 || its == 20) { /* Exceptional shift. */ i__2 = i__ + (i__ - 1) * h_dim1; i__3 = i__ - 1 + (i__ - 2) * h_dim1; d__3 = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = h__[i__3].r, abs( d__2)); t.r = d__3, t.i = 0.; } else { /* Wilkinson's shift. */ i__2 = i__ + i__ * h_dim1; t.r = h__[i__2].r, t.i = h__[i__2].i; i__2 = i__ - 1 + i__ * h_dim1; i__3 = i__ + (i__ - 1) * h_dim1; d__1 = h__[i__3].r; z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i; u.r = z__1.r, u.i = z__1.i; if (u.r != 0. || u.i != 0.) { i__2 = i__ - 1 + (i__ - 1) * h_dim1; z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i; z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; x.r = z__1.r, x.i = z__1.i; z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i * x.r; z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i; z_sqrt(&z__1, &z__2); y.r = z__1.r, y.i = z__1.i; if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) { z__1.r = -y.r, z__1.i = -y.i; y.r = z__1.r, y.i = z__1.i; } z__3.r = x.r + y.r, z__3.i = x.i + y.i; zladiv_(&z__2, &u, &z__3); z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i; t.r = z__1.r, t.i = z__1.i; } } /* Look for two consecutive small subdiagonal elements. */ i__2 = l; for (m = i__ - 1; m >= i__2; --m) { /* Determine the effect of starting the single-shift QR */ /* iteration at row M, and see if this would make H(M,M- 1) */ /* negligible. */ i__3 = m + m * h_dim1; h11.r = h__[i__3].r, h11.i = h__[i__3].i; i__3 = m + 1 + (m + 1) * h_dim1; h22.r = h__[i__3].r, h22.i = h__[i__3].i; z__1.r = h11.r - t.r, z__1.i = h11.i - t.i; h11s.r = z__1.r, h11s.i = z__1.i; i__3 = m + 1 + m * h_dim1; h21 = h__[i__3].r; s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) + abs(h21); z__1.r = h11s.r / s, z__1.i = h11s.i / s; h11s.r = z__1.r, h11s.i = z__1.i; h21 /= s; v[0].r = h11s.r, v[0].i = h11s.i; v[1].r = h21, v[1].i = 0.; if (m == l) { goto L50; } i__3 = m + (m - 1) * h_dim1; h10 = h__[i__3].r; tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs( d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(& h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 = d_imag(&h22), abs(d__6)))); if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) { goto L50; } /* L40: */ } L50: /* Single-shift QR step */ i__2 = i__ - 1; for (k = m; k <= i__2; ++k) { /* The first iteration of this loop determines a reflect ion G */ /* from the vector V and applies it from left and right to H, */ /* thus creating a nonzero bulge below the subdiagonal. */ /* Each subsequent iteration determines a reflection G t o */ /* restore the Hessenberg form in the (K-1)th column, an d thus */ /* chases the bulge one step toward the bottom of the ac tive */ /* submatrix. */ /* V(2) is always real before the call to ZLARFG, and he nce */ /* after the call T2 ( = T1*V(2) ) is also real. */ if (k > m) { zcopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); } zlarfg_(&c__2, v, &v[1], &c__1, &t1); if (k > m) { i__3 = k + (k - 1) * h_dim1; h__[i__3].r = v[0].r, h__[i__3].i = v[0].i; i__3 = k + 1 + (k - 1) * h_dim1; h__[i__3].r = 0., h__[i__3].i = 0.; } v2.r = v[1].r, v2.i = v[1].i; z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i * v2.r; t2 = z__1.r; /* Apply G from the left to transform the rows of the ma trix */ /* in columns K to I2. */ i__3 = i2; for (j = k; j <= i__3; ++j) { d_cnjg(&z__3, &t1); i__4 = k + j * h_dim1; z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i = z__3.r * h__[i__4].i + z__3.i * h__[i__4].r; i__5 = k + 1 + j * h_dim1; z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i; z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; sum.r = z__1.r, sum.i = z__1.i; i__4 = k + j * h_dim1; i__5 = k + j * h_dim1; z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; i__4 = k + 1 + j * h_dim1; i__5 = k + 1 + j * h_dim1; z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i + sum.i * v2.r; z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; /* L60: */ } /* Apply G from the right to transform the columns of th e */ /* matrix in rows I1 to min(K+2,I). */ /* Computing MIN */ i__4 = k + 2; i__3 = min(i__4,i__); for (j = i1; j <= i__3; ++j) { i__4 = j + k * h_dim1; z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i = t1.r * h__[i__4].i + t1.i * h__[i__4].r; i__5 = j + (k + 1) * h_dim1; z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; sum.r = z__1.r, sum.i = z__1.i; i__4 = j + k * h_dim1; i__5 = j + k * h_dim1; z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; i__4 = j + (k + 1) * h_dim1; i__5 = j + (k + 1) * h_dim1; d_cnjg(&z__3, &v2); z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r * z__3.i + sum.i * z__3.r; z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; /* L70: */ } if (*wantz) { /* Accumulate transformations in the matrix Z */ i__3 = *ihiz; for (j = *iloz; j <= i__3; ++j) { i__4 = j + k * z_dim1; z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i = t1.r * z__[i__4].i + t1.i * z__[i__4].r; i__5 = j + (k + 1) * z_dim1; z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; sum.r = z__1.r, sum.i = z__1.i; i__4 = j + k * z_dim1; i__5 = j + k * z_dim1; z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i - sum.i; z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; i__4 = j + (k + 1) * z_dim1; i__5 = j + (k + 1) * z_dim1; d_cnjg(&z__3, &v2); z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r * z__3.i + sum.i * z__3.r; z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i - z__2.i; z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; /* L80: */ } } if (k == m && m > l) { /* If the QR step was started at row M > L becaus e two */ /* consecutive small subdiagonals were found, the n extra */ /* scaling must be performed to ensure that H(M,M -1) remains */ /* real. */ z__1.r = 1. - t1.r, z__1.i = 0. - t1.i; temp.r = z__1.r, temp.i = z__1.i; d__2 = temp.r; d__3 = d_imag(&temp); d__1 = dlapy2_(&d__2, &d__3); z__1.r = temp.r / d__1, z__1.i = temp.i / d__1; temp.r = z__1.r, temp.i = z__1.i; i__3 = m + 1 + m * h_dim1; i__4 = m + 1 + m * h_dim1; d_cnjg(&z__2, &temp); z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i = h__[i__4].r * z__2.i + h__[i__4].i * z__2.r; h__[i__3].r = z__1.r, h__[i__3].i = z__1.i; if (m + 2 <= i__) { i__3 = m + 2 + (m + 1) * h_dim1; i__4 = m + 2 + (m + 1) * h_dim1; z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i, z__1.i = h__[i__4].r * temp.i + h__[i__4].i * temp.r; h__[i__3].r = z__1.r, h__[i__3].i = z__1.i; } i__3 = i__; for (j = m; j <= i__3; ++j) { if (j != m + 1) { if (i2 > j) { i__4 = i2 - j; zscal_(&i__4, &temp, &h__[j + (j + 1) * h_dim1], ldh); } i__4 = j - i1; d_cnjg(&z__1, &temp); zscal_(&i__4, &z__1, &h__[i1 + j * h_dim1], &c__1); if (*wantz) { d_cnjg(&z__1, &temp); zscal_(&nz, &z__1, &z__[*iloz + j * z_dim1], & c__1); } } /* L90: */ } } /* L100: */ } /* Ensure that H(I,I-1) is real. */ i__2 = i__ + (i__ - 1) * h_dim1; temp.r = h__[i__2].r, temp.i = h__[i__2].i; if (d_imag(&temp) != 0.) { d__1 = temp.r; d__2 = d_imag(&temp); rtemp = dlapy2_(&d__1, &d__2); i__2 = i__ + (i__ - 1) * h_dim1; h__[i__2].r = rtemp, h__[i__2].i = 0.; z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp; temp.r = z__1.r, temp.i = z__1.i; if (i2 > i__) { i__2 = i2 - i__; d_cnjg(&z__1, &temp); zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh); } i__2 = i__ - i1; zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1); if (*wantz) { zscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1); } } /* L110: */ } /* Failure to converge in remaining number of iterations */ *info = i__; return 0; L120: /* H(I,I-1) is negligible: one eigenvalue has converged. */ i__1 = i__; i__2 = i__ + i__ * h_dim1; w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; /* Decrement number of remaining iterations, and return to start of */ /* the main loop with new value of I. */ itn -= its; i__ = l - 1; goto L10; L130: return 0; /* End of ZLAHQR */ } /* zlahqr_ */ /* ztrevc.f -- translated by f2c (version 19950808). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ #ifdef c_b2 #undef c_b2 #endif #define c_b2 c_b2 /* Subroutine */ int ztrevc_(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, rwork, info, side_len, howmny_len) char *side, *howmny; logical *select; integer *n; doublecomplex *t; integer *ldt; doublecomplex *vl; integer *ldvl; doublecomplex *vr; integer *ldvr, *mm, *m; doublecomplex *work; doublereal *rwork; integer *info; ftnlen side_len; ftnlen howmny_len; { /* System generated locals */ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(); void d_cnjg(); /* Local variables */ static logical allv; static doublereal unfl, ovfl, smin; static logical over; static integer i__, j, k; static doublereal scale; extern logical lsame_(); static doublereal remax; static logical leftv, bothv; extern /* Subroutine */ int zgemv_(); static logical somev; extern /* Subroutine */ int zcopy_(), dlabad_(); static integer ii, ki; extern doublereal dlamch_(); static integer is; extern /* Subroutine */ int xerbla_(), zdscal_(); extern integer izamax_(); static logical rightv; extern doublereal dzasum_(); static doublereal smlnum; extern /* Subroutine */ int zlatrs_(); static doublereal ulp; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZTREVC computes some or all of the right and/or left eigenvectors of */ /* a complex upper triangular matrix T. */ /* The right eigenvector x and the left eigenvector y of T corresponding */ /* to an eigenvalue w are defined by: */ /* T*x = w*x, y'*T = w*y' */ /* where y' denotes the conjugate transpose of the vector y. */ /* If all eigenvectors are requested, the routine may either return the */ /* matrices X and/or Y of right or left eigenvectors of T, or the */ /* products Q*X and/or Q*Y, where Q is an input unitary */ /* matrix. If T was obtained from the Schur factorization of an */ /* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of */ /* right or left eigenvectors of A. */ /* Arguments */ /* ========= */ /* SIDE (input) CHARACTER*1 */ /* = 'R': compute right eigenvectors only; */ /* = 'L': compute left eigenvectors only; */ /* = 'B': compute both right and left eigenvectors. */ /* HOWMNY (input) CHARACTER*1 */ /* = 'A': compute all right and/or left eigenvectors; */ /* = 'B': compute all right and/or left eigenvectors, */ /* and backtransform them using the input matrices */ /* supplied in VR and/or VL; */ /* = 'S': compute selected right and/or left eigenvectors, */ /* specified by the logical array SELECT. */ /* SELECT (input) LOGICAL array, dimension (N) */ /* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ /* computed. */ /* If HOWMNY = 'A' or 'B', SELECT is not referenced. */ /* To select the eigenvector corresponding to the j-th */ /* eigenvalue, SELECT(j) must be set to .TRUE.. */ /* N (input) INTEGER */ /* The order of the matrix T. N >= 0. */ /* T (input/output) COMPLEX*16 array, dimension (LDT,N) */ /* The upper triangular matrix T. T is modified, but restored */ /* on exit. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= max(1,N). */ /* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */ /* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ /* contain an N-by-N matrix Q (usually the unitary matrix Q of */ /* Schur vectors returned by ZHSEQR). */ /* On exit, if SIDE = 'L' or 'B', VL contains: */ /* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ /* if HOWMNY = 'B', the matrix Q*Y; */ /* if HOWMNY = 'S', the left eigenvectors of T specified by */ /* SELECT, stored consecutively in the columns */ /* of VL, in the same order as their */ /* eigenvalues. */ /* If SIDE = 'R', VL is not referenced. */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= max(1,N) if */ /* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */ /* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) */ /* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ /* contain an N-by-N matrix Q (usually the unitary matrix Q of */ /* Schur vectors returned by ZHSEQR). */ /* On exit, if SIDE = 'R' or 'B', VR contains: */ /* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ /* if HOWMNY = 'B', the matrix Q*X; */ /* if HOWMNY = 'S', the right eigenvectors of T specified by */ /* SELECT, stored consecutively in the columns */ /* of VR, in the same order as their */ /* eigenvalues. */ /* If SIDE = 'L', VR is not referenced. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= max(1,N) if */ /* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */ /* MM (input) INTEGER */ /* The number of columns in the arrays VL and/or VR. MM >= M. */ /* M (output) INTEGER */ /* The number of columns in the arrays VL and/or VR actually */ /* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ /* is set to N. Each selected eigenvector occupies one */ /* column. */ /* WORK (workspace) COMPLEX*16 array, dimension (2*N) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The algorithm used in this program is basically backward (forward) */ /* substitution, with scaling to make the the code robust against */ /* possible overflow. */ /* Each eigenvector is normalized so that the element of largest */ /* magnitude has magnitude 1; here the magnitude of a complex number */ /* (x,y) is taken to be |x| + |y|. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ --select; t_dim1 = *ldt; t_offset = t_dim1 + 1; t -= t_offset; vl_dim1 = *ldvl; vl_offset = vl_dim1 + 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = vr_dim1 + 1; vr -= vr_offset; --work; --rwork; /* Function Body */ bothv = lsame_(side, "B", 1L, 1L); rightv = lsame_(side, "R", 1L, 1L) || bothv; leftv = lsame_(side, "L", 1L, 1L) || bothv; allv = lsame_(howmny, "A", 1L, 1L); over = lsame_(howmny, "B", 1L, 1L) || lsame_(howmny, "O", 1L, 1L); somev = lsame_(howmny, "S", 1L, 1L); /* Set M to the number of columns required to store the selected */ /* eigenvectors. */ if (somev) { *m = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (select[j]) { ++(*m); } /* L10: */ } } else { *m = *n; } *info = 0; if (! rightv && ! leftv) { *info = -1; } else if (! allv && ! over && ! somev) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldvl < 1 || leftv && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || rightv && *ldvr < *n) { *info = -10; } else if (*mm < *m) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTREVC", &i__1, 6L); return 0; } /* Quick return if possible. */ if (*n == 0) { return 0; } /* Set the constants to control overflow. */ unfl = dlamch_("Safe minimum", 12L); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("Precision", 9L); smlnum = unfl * (*n / ulp); /* Store the diagonal elements of T in working array WORK. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + *n; i__3 = i__ + i__ * t_dim1; work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i; /* L20: */ } /* Compute 1-norm of each column of strictly upper triangular */ /* part of T to control overflow in triangular solver. */ rwork[1] = 0.; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; rwork[j] = dzasum_(&i__2, &t[j * t_dim1 + 1], &c__1); /* L30: */ } if (rightv) { /* Compute right eigenvectors. */ is = *m; for (ki = *n; ki >= 1; --ki) { if (somev) { if (! select[ki]) { goto L80; } } /* Computing MAX */ i__1 = ki + ki * t_dim1; d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&t[ ki + ki * t_dim1]), abs(d__2))); smin = max(d__3,smlnum); work[1].r = 1., work[1].i = 0.; /* Form right-hand side. */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { i__2 = k; i__3 = k + ki * t_dim1; z__1.r = -t[i__3].r, z__1.i = -t[i__3].i; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L40: */ } /* Solve the triangular system: */ /* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { i__2 = k + k * t_dim1; i__3 = k + k * t_dim1; i__4 = ki + ki * t_dim1; z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4] .i; t[i__2].r = z__1.r, t[i__2].i = z__1.i; i__2 = k + k * t_dim1; if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[k + k * t_dim1]), abs(d__2)) < smin) { i__3 = k + k * t_dim1; t[i__3].r = smin, t[i__3].i = 0.; } /* L50: */ } if (ki > 1) { i__1 = ki - 1; zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[ t_offset], ldt, &work[1], &scale, &rwork[1], info, 5L, 12L, 8L, 1L); i__1 = ki; work[i__1].r = scale, work[i__1].i = 0.; } /* Copy the vector x or Q*x to VR and normalize. */ if (! over) { zcopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1); ii = izamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); i__1 = ii + is * vr_dim1; remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag( &vr[ii + is * vr_dim1]), abs(d__2))); zdscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); i__1 = *n; for (k = ki + 1; k <= i__1; ++k) { i__2 = k + is * vr_dim1; vr[i__2].r = 0., vr[i__2].i = 0.; /* L60: */ } } else { if (ki > 1) { i__1 = ki - 1; z__1.r = scale, z__1.i = 0.; zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[ 1], &c__1, &z__1, &vr[ki * vr_dim1 + 1], &c__1, 1L); } ii = izamax_(n, &vr[ki * vr_dim1 + 1], &c__1); i__1 = ii + ki * vr_dim1; remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag( &vr[ii + ki * vr_dim1]), abs(d__2))); zdscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); } /* Set back the original diagonal elements of T. */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { i__2 = k + k * t_dim1; i__3 = k + *n; t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i; /* L70: */ } --is; L80: ; } } if (leftv) { /* Compute left eigenvectors. */ is = 1; i__1 = *n; for (ki = 1; ki <= i__1; ++ki) { if (somev) { if (! select[ki]) { goto L130; } } /* Computing MAX */ i__2 = ki + ki * t_dim1; d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[ ki + ki * t_dim1]), abs(d__2))); smin = max(d__3,smlnum); i__2 = *n; work[i__2].r = 1., work[i__2].i = 0.; /* Form right-hand side. */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { i__3 = k; d_cnjg(&z__2, &t[ki + k * t_dim1]); z__1.r = -z__2.r, z__1.i = -z__2.i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L90: */ } /* Solve the triangular system: */ /* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { i__3 = k + k * t_dim1; i__4 = k + k * t_dim1; i__5 = ki + ki * t_dim1; z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5] .i; t[i__3].r = z__1.r, t[i__3].i = z__1.i; i__3 = k + k * t_dim1; if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[k + k * t_dim1]), abs(d__2)) < smin) { i__4 = k + k * t_dim1; t[i__4].r = smin, t[i__4].i = 0.; } /* L100: */ } if (ki < *n) { i__2 = *n - ki; zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", & i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki + 1], &scale, &rwork[1], info, 5L, 19L, 8L, 1L); i__2 = ki; work[i__2].r = scale, work[i__2].i = 0.; } /* Copy the vector x or Q*x to VL and normalize. */ if (! over) { i__2 = *n - ki + 1; zcopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1) ; i__2 = *n - ki + 1; ii = izamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1; i__2 = ii + is * vl_dim1; remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag( &vl[ii + is * vl_dim1]), abs(d__2))); i__2 = *n - ki + 1; zdscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); i__2 = ki - 1; for (k = 1; k <= i__2; ++k) { i__3 = k + is * vl_dim1; vl[i__3].r = 0., vl[i__3].i = 0.; /* L110: */ } } else { if (ki < *n) { i__2 = *n - ki; z__1.r = scale, z__1.i = 0.; zgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1], ldvl, &work[ki + 1], &c__1, &z__1, &vl[ki * vl_dim1 + 1], &c__1, 1L); } ii = izamax_(n, &vl[ki * vl_dim1 + 1], &c__1); i__2 = ii + ki * vl_dim1; remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag( &vl[ii + ki * vl_dim1]), abs(d__2))); zdscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); } /* Set back the original diagonal elements of T. */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { i__3 = k + k * t_dim1; i__4 = k + *n; t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i; /* L120: */ } ++is; L130: ; } } return 0; /* End of ZTREVC */ } /* ztrevc_ */