Esempio n. 1
0
vector hermdl(cmatrix& a)
{
	char UPLO='U';
	char JOBZ='V';
	int INFO=0;
	int N=a.Rows;
	int LDA=N;
	int LWORK=2*N;
	cvector WORK(LWORK);
	vector W(N);
	vector RWORK(3*N);
	FORTRAN(cheev)(&JOBZ,&UPLO,&N,a.TheMatrix,&LDA,W.TheVector,WORK.TheVector,
		&LWORK,RWORK.TheVector,&INFO);
	if (INFO != 0) cerr<<"diagonalization failed"<<endl;
	return W;
}
void GeneralizedEigenSystemSolverRealGeneralMatrices(Array2 < doublevar > & Ain, 
         Array1 <dcomplex> & W, Array2 <doublevar> & VL, Array2 <doublevar> & VR) { 
#ifdef USE_LAPACK //if LAPACK
  int N=Ain.dim[0];
  
  Array2 <doublevar> A_temp=Ain; //,VL(N,N),VR(N,N);
  Array1 <doublevar> WORK,RWORK(2*N),WI(N),WR(N);
  WI.Resize(N);
  VL.Resize(N,N);
  VR.Resize(N,N);

  int info;
  int NB=64;
  int NMAX=N;
  int lda=NMAX;
  int ldb=NMAX;
  int LWORK=5*NMAX;
  WORK.Resize(LWORK);


  info=  dgeev('V','V',N,A_temp.v, lda,WR.v,WI.v,VL.v,lda,VR.v,lda,WORK.v,LWORK);

  if(info>0)
    error("Internal error in the LAPACK routine dgeev",info);
  if(info<0)
    error("Problem with the input parameter of LAPACK routine dgeev in position ",-info);
  W.Resize(N);
  for(int i=0; i< N; i++) { 
    W(i)=dcomplex(WR(i),WI(i));
  }

//  for (int i=0; i<N; i++)
//    evals(i)=W[N-1-i];

 // for (int i=0; i<N; i++) {
 //   for (int j=0; j<N; j++) {
 //     evecs(j,i)=A_temp(N-1-i,j);
 //   }
 // }
 //END OF LAPACK 
#else //IF NO LAPACK
  error("need LAPACK for eigensystem solver for general matrices");
#endif //END OF NO LAPACK
}
Esempio n. 3
0
cvector diag(cmatrix& a,cmatrix &VL,cmatrix &VR)
  // returns eigenvalues in a vector and transforms the matrix argument
{
  int N=a.Rows;
  char JOBVL='V';
  char JOBVR='V';
  int INFO=0;
  int LDA=N;
  int LDVL=N;
  int LDVR=N;
  int LWORK=2*N;
  cvector WORK(LWORK);
  cvector W(N);
  vector RWORK(2*N);

  FORTRAN(zgeev)(&JOBVL,&JOBVR,&N,a.TheMatrix,&LDA,W.TheVector,VL.TheMatrix,&LDVL,
        VR.TheMatrix,&LDVR,WORK.TheVector,&LWORK,
         RWORK.TheVector,&INFO);
  if (INFO != 0) cerr<<"diagonalization failed"<<endl;
  return W;
}
Esempio n. 4
0
/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char *
                             sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w,
                             doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
                             integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm,
                             doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *
                             lwork, doublereal *rwork, integer *info)
{
    /*  -- 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


        Purpose
        =======

        ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
        eigenvalues and, optionally, the left and/or right eigenvectors.

        Optionally also, it computes a balancing transformation to improve
        the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
        SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
        (RCONDE), and reciprocal condition numbers for the right
        eigenvectors (RCONDV).

        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.

        Balancing a matrix means permuting the rows and columns to make it
        more nearly upper triangular, and applying a diagonal similarity
        transformation D * A * D**(-1), where D is a diagonal matrix, to
        make its rows and columns closer in norm and the condition numbers
        of its eigenvalues and eigenvectors smaller.  The computed
        reciprocal condition numbers correspond to the balanced matrix.
        Permuting rows and columns will not change the condition numbers
        (in exact arithmetic) but diagonal scaling will.  For further
        explanation of balancing, see section 4.10.2 of the LAPACK
        Users' Guide.

        Arguments
        =========

        BALANC  (input) CHARACTER*1
                Indicates how the input matrix should be diagonally scaled
                and/or permuted to improve the conditioning of its
                eigenvalues.
                = 'N': Do not diagonally scale or permute;
                = 'P': Perform permutations to make the matrix more nearly
                       upper triangular. Do not diagonally scale;
                = 'S': Diagonally scale the matrix, ie. replace A by
                       D*A*D**(-1), where D is a diagonal matrix chosen
                       to make the rows and columns of A more equal in
                       norm. Do not permute;
                = 'B': Both diagonally scale and permute A.

                Computed reciprocal condition numbers will be for the matrix

                after balancing and/or permuting. Permuting does not change
                condition numbers (in exact arithmetic), but balancing does.


        JOBVL   (input) CHARACTER*1
                = 'N': left eigenvectors of A are not computed;
                = 'V': left eigenvectors of A are computed.
                If SENSE = 'E' or 'B', JOBVL must = 'V'.

        JOBVR   (input) CHARACTER*1
                = 'N': right eigenvectors of A are not computed;
                = 'V': right eigenvectors of A are computed.
                If SENSE = 'E' or 'B', JOBVR must = 'V'.

        SENSE   (input) CHARACTER*1
                Determines which reciprocal condition numbers are computed.
                = 'N': None are computed;
                = 'E': Computed for eigenvalues only;
                = 'V': Computed for right eigenvectors only;
                = 'B': Computed for eigenvalues and right eigenvectors.

                If SENSE = 'E' or 'B', both left and right eigenvectors
                must also be computed (JOBVL = 'V' and JOBVR = 'V').

        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.  If JOBVL = 'V' or
                JOBVR = 'V', A contains the Schur form of the balanced
                version of the matrix A.

        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.

        ILO,IHI (output) INTEGER
                ILO and IHI are integer values determined when A was
                balanced.  The balanced A(i,j) = 0 if I > J and
                J = 1,...,ILO-1 or I = IHI+1,...,N.

        SCALE   (output) DOUBLE PRECISION array, dimension (N)
                Details of the permutations and scaling factors applied
                when balancing 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.

        ABNRM   (output) DOUBLE PRECISION
                The one-norm of the balanced matrix (the maximum
                of the sum of absolute values of elements of any column).

        RCONDE  (output) DOUBLE PRECISION array, dimension (N)
                RCONDE(j) is the reciprocal condition number of the j-th
                eigenvalue.

        RCONDV  (output) DOUBLE PRECISION array, dimension (N)
                RCONDV(j) is the reciprocal condition number of the j-th
                right eigenvector.

        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 SENSE = 'N' or 'E',
                LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
                LWORK >= N*N+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 or condition numbers
                      have been computed; elements 1:ILO-1 and i+1:N of W
                      contain eigenvalues which have converged.

        =====================================================================



           Test the input arguments


       Parameter adjustments
           Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c__0 = 0;
    static integer c__8 = 8;
    static integer c_n1 = -1;
    static integer c__4 = 4;

    /* 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(doublereal), d_imag(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *);
    /* Local variables */
    static char side[1];
    static integer maxb;
    static doublereal anrm;
    static integer ierr, itau, iwrk, nout, i, k, icond;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
                                       doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
    static logical scalea;
    extern doublereal dlamch_(char *);
    static doublereal cscale;
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
                                        doublereal *, doublereal *, integer *, integer *, doublereal *,
                                        integer *, integer *), zgebak_(char *, char *, integer *,
                                                integer *, integer *, doublereal *, integer *, doublecomplex *,
                                                integer *, integer *), zgebal_(char *, integer *,
                                                        doublecomplex *, integer *, integer *, integer *, doublereal *,
                                                        integer *);
    extern integer idamax_(integer *, doublereal *, integer *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
                           integer *, integer *, ftnlen, ftnlen);
    static logical select[1];
    extern /* Subroutine */ int zdscal_(integer *, doublereal *,
                                        doublecomplex *, integer *);
    static doublereal bignum;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
                              integer *, doublereal *);
    extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, doublecomplex *,
                                        integer *, integer *), zlascl_(char *, integer *, integer *,
                                                doublereal *, doublereal *, integer *, integer *, doublecomplex *,
                                                integer *, integer *), zlacpy_(char *, integer *,
                                                        integer *, doublecomplex *, integer *, doublecomplex *, integer *);
    static integer minwrk, maxwrk;
    static logical wantvl, wntsnb;
    static integer hswork;
    static logical wntsne;
    static doublereal smlnum;
    extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
                                        integer *, doublecomplex *, integer *, doublecomplex *,
                                        doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static logical wantvr;
    extern /* Subroutine */ int ztrevc_(char *, char *, logical *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, integer *,
                                        doublecomplex *, integer *, integer *, integer *, doublecomplex *,
                                        doublereal *, integer *), ztrsna_(char *, char *,
                                                logical *, integer *, doublecomplex *, integer *, doublecomplex *
                                                , integer *, doublecomplex *, integer *, doublereal *, doublereal
                                                *, integer *, integer *, doublecomplex *, integer *, doublereal *,
                                                integer *), zunghr_(integer *, integer *,
                                                        integer *, doublecomplex *, integer *, doublecomplex *,
                                                        doublecomplex *, integer *, integer *);
    static logical wntsnn, wntsnv;
    static char job[1];
    static doublereal scl, dum[1], eps;
    static doublecomplex tmp;



#define DUM(I) dum[(I)]
#define W(I) w[(I)-1]
#define SCALE(I) scale[(I)-1]
#define RCONDE(I) rconde[(I)-1]
#define RCONDV(I) rcondv[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]

    *info = 0;
    wantvl = lsame_(jobvl, "V");
    wantvr = lsame_(jobvr, "V");
    wntsnn = lsame_(sense, "N");
    wntsne = lsame_(sense, "E");
    wntsnv = lsame_(sense, "V");
    wntsnb = lsame_(sense, "B");
    if (! (lsame_(balanc, "N") || lsame_(balanc, "S") ||
            lsame_(balanc, "P") || lsame_(balanc, "B"))) {
        *info = -1;
    } else if (! wantvl && ! lsame_(jobvl, "N")) {
        *info = -2;
    } else if (! wantvr && ! lsame_(jobvr, "N")) {
        *info = -3;
    } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
               && ! (wantvl && wantvr)) {
        *info = -4;
    } else if (*n < 0) {
        *info = -5;
    } else if (*lda < max(1,*n)) {
        *info = -7;
    } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
        *info = -10;
    } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
        *info = -12;
    }

    /*     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);
            if (! (wntsnn || wntsne)) {
                /* Computing MAX */
                i__1 = minwrk, i__2 = *n * *n + (*n << 1);
                minwrk = max(i__1,i__2);
            }
            /* Computing MAX */
            i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", n, &c__1, n, &c_n1, 6L, 2L);
            maxb = max(i__1,2);
            if (wntsnn) {
                /* 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);
            } else {
                /* Computing MIN
                   Computing MAX */
                i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SN", 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,1);
            maxwrk = max(i__1,hswork);
            if (! (wntsnn || wntsne)) {
                /* Computing MAX */
                i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
                maxwrk = max(i__1,i__2);
            }
        } else {
            /* Computing MAX */
            i__1 = 1, i__2 = *n << 1;
            minwrk = max(i__1,i__2);
            if (! (wntsnn || wntsne)) {
                /* Computing MAX */
                i__1 = minwrk, i__2 = *n * *n + (*n << 1);
                minwrk = max(i__1,i__2);
            }
            /* Computing MAX */
            i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", 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);
            /* Computing MAX */
            i__1 = max(maxwrk,1);
            maxwrk = max(i__1,hswork);
            /* 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);
            if (! (wntsnn || wntsne)) {
                /* Computing MAX */
                i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
                maxwrk = max(i__1,i__2);
            }
            /* Computing MAX */
            i__1 = maxwrk, i__2 = *n << 1, i__1 = max(i__1,i__2);
            maxwrk = max(i__1,1);
        }
        WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
    }
    if (*lwork < minwrk) {
        *info = -20;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("ZGEEVX", &i__1);
        return 0;
    }

    /*     Quick return if possible */

    if (*n == 0) {
        return 0;
    }

    /*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S");
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);
    smlnum = sqrt(smlnum) / eps;
    bignum = 1. / smlnum;

    /*     Scale A if max element outside range [SMLNUM,BIGNUM] */

    icond = 0;
    anrm = zlange_("M", n, n, &A(1,1), lda, dum);
    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(1,1), lda, &
                ierr);
    }

    /*     Balance the matrix and compute ABNRM */

    zgebal_(balanc, n, &A(1,1), lda, ilo, ihi, &SCALE(1), &ierr);
    *abnrm = zlange_("1", n, n, &A(1,1), lda, dum);
    if (scalea) {
        DUM(0) = *abnrm;
        dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
                ierr);
        *abnrm = DUM(0);
    }

    /*     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(1,1), 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(1,1), lda, &VL(1,1), ldvl);

        /*        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(1,1), 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(1,1), lda, &W(1), &VL(1,1), ldvl, &WORK(iwrk), &i__1, info);

        if (wantvr) {

            /*           Want left and right eigenvectors
                         Copy Schur vectors to VR */

            *(unsigned char *)side = 'B';
            zlacpy_("F", n, n, &VL(1,1), ldvl, &VR(1,1), ldvr)
            ;
        }

    } else if (wantvr) {

        /*        Want right eigenvectors
                  Copy Householder vectors to VR */

        *(unsigned char *)side = 'R';
        zlacpy_("L", n, n, &A(1,1), lda, &VR(1,1), ldvr);

        /*        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(1,1), 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(1,1), lda, &W(1), &VR(1,1), ldvr, &WORK(iwrk), &i__1, info);

    } else {

        /*        Compute eigenvalues only
                  If condition numbers desired, compute Schur form */

        if (wntsnn) {
            *(unsigned char *)job = 'E';
        } else {
            *(unsigned char *)job = 'S';
        }

        /*        (CWorkspace: need 1, prefer HSWORK (see comments) )
                  (RWorkspace: none) */

        iwrk = itau;
        i__1 = *lwork - iwrk + 1;
        zhseqr_(job, "N", n, ilo, ihi, &A(1,1), lda, &W(1), &VR(1,1), ldvr, &WORK(iwrk), &i__1, info);
    }

    /*     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 N) */

        ztrevc_(side, "B", select, n, &A(1,1), lda, &VL(1,1), ldvl,
                &VR(1,1), ldvr, n, &nout, &WORK(iwrk), &RWORK(1), &
                ierr);
    }

    /*     Compute condition numbers if desired
           (CWorkspace: need N*N+2*N unless SENSE = 'E')
           (RWorkspace: need 2*N unless SENSE = 'E') */

    if (! wntsnn) {
        ztrsna_(sense, "A", select, n, &A(1,1), lda, &VL(1,1),
                ldvl, &VR(1,1), ldvr, &RCONDE(1), &RCONDV(1), n, &nout,
                &WORK(iwrk), n, &RWORK(1), &icond);
    }

    if (wantvl) {

        /*        Undo balancing of left eigenvectors */

        zgebak_(balanc, "L", n, ilo, ihi, &SCALE(1), n, &VL(1,1), ldvl,
                &ierr);

        /*        Normalize left eigenvectors and make largest component real
        */

        i__1 = *n;
        for (i = 1; i <= *n; ++i) {
            scl = 1. / dznrm2_(n, &VL(1,i), &c__1);
            zdscal_(n, &scl, &VL(1,i), &c__1);
            i__2 = *n;
            for (k = 1; k <= *n; ++k) {
                i__3 = k + i * vl_dim1;
                /* Computing 2nd power */
                d__1 = VL(k,i).r;
                /* Computing 2nd power */
                d__2 = d_imag(&VL(k,i));
                RWORK(k) = d__1 * d__1 + d__2 * d__2;
                /* L10: */
            }
            k = idamax_(n, &RWORK(1), &c__1);
            d_cnjg(&z__2, &VL(k,i));
            d__1 = sqrt(RWORK(k));
            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(1,i), &c__1);
            i__2 = k + i * vl_dim1;
            i__3 = k + i * vl_dim1;
            d__1 = VL(k,i).r;
            z__1.r = d__1, z__1.i = 0.;
            VL(k,i).r = z__1.r, VL(k,i).i = z__1.i;
            /* L20: */
        }
    }

    if (wantvr) {

        /*        Undo balancing of right eigenvectors */

        zgebak_(balanc, "R", n, ilo, ihi, &SCALE(1), n, &VR(1,1), ldvr,
                &ierr);

        /*        Normalize right eigenvectors and make largest component real
         */

        i__1 = *n;
        for (i = 1; i <= *n; ++i) {
            scl = 1. / dznrm2_(n, &VR(1,i), &c__1);
            zdscal_(n, &scl, &VR(1,i), &c__1);
            i__2 = *n;
            for (k = 1; k <= *n; ++k) {
                i__3 = k + i * vr_dim1;
                /* Computing 2nd power */
                d__1 = VR(k,i).r;
                /* Computing 2nd power */
                d__2 = d_imag(&VR(k,i));
                RWORK(k) = d__1 * d__1 + d__2 * d__2;
                /* L30: */
            }
            k = idamax_(n, &RWORK(1), &c__1);
            d_cnjg(&z__2, &VR(k,i));
            d__1 = sqrt(RWORK(k));
            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(1,i), &c__1);
            i__2 = k + i * vr_dim1;
            i__3 = k + i * vr_dim1;
            d__1 = VR(k,i).r;
            z__1.r = d__1, z__1.i = 0.;
            VR(k,i).r = z__1.r, VR(k,i).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);
        if (*info == 0) {
            if ((wntsnv || wntsnb) && icond == 0) {
                dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &RCONDV(
                            1), n, &ierr);
            }
        } else {
            i__1 = *ilo - 1;
            zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &W(1), n,
                    &ierr);
        }
    }

    WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
    return 0;

    /*     End of ZGEEVX */

} /* zgeevx_ */
Esempio n. 5
0
/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd, 
	complex *ab, integer *ldab, real *w, complex *z, integer *ldz, 
	complex *work, real *rwork, integer *info)
{
/*  -- 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   


    Purpose   
    =======   

    CHBEV computes all the eigenvalues and, optionally, eigenvectors of   
    a complex Hermitian band matrix A.   

    Arguments   
    =========   

    JOBZ    (input) CHARACTER*1   
            = 'N':  Compute eigenvalues only;   
            = 'V':  Compute eigenvalues and eigenvectors.   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    KD      (input) INTEGER   
            The number of superdiagonals of the matrix A if UPLO = 'U',   
            or the number of subdiagonals if UPLO = 'L'.  KD >= 0.   

    AB      (input/output) COMPLEX array, dimension (LDAB, N)   
            On entry, the upper or lower triangle of the Hermitian band   
            matrix A, stored in the first KD+1 rows of the array.  The   
            j-th column of A is stored in the j-th column of the array AB 
  
            as follows:   
            if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; 
  
            if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). 
  

            On exit, AB is overwritten by values generated during the   
            reduction to tridiagonal form.  If UPLO = 'U', the first   
            superdiagonal and the diagonal of the tridiagonal matrix T   
            are returned in rows KD and KD+1 of AB, and if UPLO = 'L',   
            the diagonal and first subdiagonal of T are returned in the   
            first two rows of AB.   

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KD + 1.   

    W       (output) REAL array, dimension (N)   
            If INFO = 0, the eigenvalues in ascending order.   

    Z       (output) COMPLEX array, dimension (LDZ, N)   
            If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal   
            eigenvectors of the matrix A, with the i-th column of Z   
            holding the eigenvector associated with W(i).   
            If JOBZ = 'N', then Z is not referenced.   

    LDZ     (input) INTEGER   
            The leading dimension of the array Z.  LDZ >= 1, and if   
            JOBZ = 'V', LDZ >= max(1,N).   

    WORK    (workspace) COMPLEX array, dimension (N)   

    RWORK   (workspace) REAL array, dimension (max(1,3*N-2))   

    INFO    (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   
            > 0:  if INFO = i, the algorithm failed to converge; i   
                  off-diagonal elements of an intermediate tridiagonal   
                  form did not converge to zero.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static real c_b11 = 1.f;
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
    real r__1;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static integer inde;
    static real anrm;
    static integer imax;
    static real rmin, rmax, sigma;
    extern logical lsame_(char *, char *);
    static integer iinfo;
    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
    static logical lower, wantz;
    extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
	     integer *, real *);
    static integer iscale;
    extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, 
	    real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *, 
	    integer *, real *, real *, complex *, integer *, complex *, 
	    integer *);
    extern doublereal slamch_(char *);
    static real safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static real bignum;
    static integer indrwk;
    extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *, 
	    complex *, integer *, real *, integer *), ssterf_(integer 
	    *, real *, real *, integer *);
    static real smlnum, eps;



#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]

    wantz = lsame_(jobz, "V");
    lower = lsame_(uplo, "L");

    *info = 0;
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (lower || lsame_(uplo, "U"))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*kd < 0) {
	*info = -4;
    } else if (*ldab < *kd + 1) {
	*info = -6;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -9;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CHBEV ", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	i__1 = ab_dim1 + 1;
	W(1) = AB(1,1).r;
	if (wantz) {
	    i__1 = z_dim1 + 1;
	    Z(1,1).r = 1.f, Z(1,1).i = 0.f;
	}
	return 0;
    }

/*     Get machine constants. */

    safmin = slamch_("Safe minimum");
    eps = slamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1.f / smlnum;
    rmin = sqrt(smlnum);
    rmax = sqrt(bignum);

/*     Scale matrix to allowable range, if necessary. */

    anrm = clanhb_("M", uplo, n, kd, &AB(1,1), ldab, &RWORK(1));
    iscale = 0;
    if (anrm > 0.f && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	if (lower) {
	    clascl_("B", kd, kd, &c_b11, &sigma, n, n, &AB(1,1), ldab, 
		    info);
	} else {
	    clascl_("Q", kd, kd, &c_b11, &sigma, n, n, &AB(1,1), ldab, 
		    info);
	}
    }

/*     Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */

    inde = 1;
    chbtrd_(jobz, uplo, n, kd, &AB(1,1), ldab, &W(1), &RWORK(inde), &Z(1,1), ldz, &WORK(1), &iinfo);

/*     For eigenvalues only, call SSTERF.  For eigenvectors, call CSTEQR. 
*/

    if (! wantz) {
	ssterf_(n, &W(1), &RWORK(inde), info);
    } else {
	indrwk = inde + *n;
	csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
		indrwk), info);
    }

/*     If matrix was scaled, then rescale eigenvalues appropriately. */

    if (iscale == 1) {
	if (*info == 0) {
	    imax = *n;
	} else {
	    imax = *info - 1;
	}
	r__1 = 1.f / sigma;
	sscal_(&imax, &r__1, &W(1), &c__1);
    }

    return 0;

/*     End of CHBEV */

} /* chbev_ */
Esempio n. 6
0
/* Subroutine */ int zpbrfs_(char *uplo, integer *n, integer *kd, integer *
	nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
	ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
	 doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
	rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    ZPBRFS improves the computed solution to a system of linear   
    equations when the coefficient matrix is Hermitian positive definite 
  
    and banded, and provides error bounds and backward error estimates   
    for the solution.   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    KD      (input) INTEGER   
            The number of superdiagonals of the matrix A if UPLO = 'U',   
            or the number of subdiagonals if UPLO = 'L'.  KD >= 0.   

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of columns   
            of the matrices B and X.  NRHS >= 0.   

    AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)   
            The upper or lower triangle of the Hermitian band matrix A,   
            stored in the first KD+1 rows of the array.  The j-th column 
  
            of A is stored in the j-th column of the array AB as follows: 
  
            if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; 
  
            if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). 
  

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KD+1.   

    AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)   
            The triangular factor U or L from the Cholesky factorization 
  
            A = U**H*U or A = L*L**H of the band matrix A as computed by 
  
            ZPBTRF, in the same storage format as A (see AB).   

    LDAFB   (input) INTEGER   
            The leading dimension of the array AFB.  LDAFB >= KD+1.   

    B       (input) COMPLEX*16 array, dimension (LDB,NRHS)   
            The right hand side matrix B.   

    LDB     (input) INTEGER   
            The leading dimension of the array B.  LDB >= max(1,N).   

    X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)   
            On entry, the solution matrix X, as computed by ZPBTRS.   
            On exit, the improved solution matrix X.   

    LDX     (input) INTEGER   
            The leading dimension of the array X.  LDX >= max(1,N).   

    FERR    (output) DOUBLE PRECISION array, dimension (NRHS)   
            The estimated forward error bound for each solution vector   
            X(j) (the j-th column of the solution matrix X).   
            If XTRUE is the true solution corresponding to X(j), FERR(j) 
  
            is an estimated upper bound for the magnitude of the largest 
  
            element in (X(j) - XTRUE) divided by the magnitude of the   
            largest element in X(j).  The estimate is as reliable as   
            the estimate for RCOND, and is almost always a slight   
            overestimate of the true error.   

    BERR    (output) DOUBLE PRECISION array, dimension (NRHS)   
            The componentwise relative backward error of each solution   
            vector X(j) (i.e., the smallest relative change in   
            any element of A or B that makes X(j) an exact solution).   

    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   

    Internal Parameters   
    ===================   

    ITMAX is the maximum number of steps of iterative refinement.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static doublecomplex c_b1 = {1.,0.};
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, 
	    x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    /* Local variables */
    static integer kase;
    static doublereal safe1, safe2;
    static integer i, j, k, l;
    static doublereal s;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int zhbmv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *);
    static integer count;
    static logical upper;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    extern doublereal dlamch_(char *);
    static doublereal xk;
    static integer nz;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    integer *);
    static doublereal lstres;
    extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer 
	    *, doublecomplex *, integer *, doublecomplex *, integer *, 
	    integer *);
    static doublereal eps;



#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define AFB(I,J) afb[(I)-1 + ((J)-1)* ( *ldafb)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]

    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kd < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*ldab < *kd + 1) {
	*info = -6;
    } else if (*ldafb < *kd + 1) {
	*info = -8;
    } else if (*ldb < max(1,*n)) {
	*info = -10;
    } else if (*ldx < max(1,*n)) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZPBRFS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    FERR(j) = 0.;
	    BERR(j) = 0.;
/* L10: */
	}
	return 0;
    }

/*     NZ = maximum number of nonzero elements in each row of A, plus 1   

   Computing MIN */
    i__1 = *n + 1, i__2 = (*kd << 1) + 2;
    nz = min(i__1,i__2);
    eps = dlamch_("Epsilon");
    safmin = dlamch_("Safe minimum");
    safe1 = nz * safmin;
    safe2 = safe1 / eps;

/*     Do for each right hand side */

    i__1 = *nrhs;
    for (j = 1; j <= *nrhs; ++j) {

	count = 1;
	lstres = 3.;
L20:

/*        Loop until stopping criterion is satisfied.   

          Compute residual R = B - A * X */

	zcopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
	z__1.r = -1., z__1.i = 0.;
	zhbmv_(uplo, n, kd, &z__1, &AB(1,1), ldab, &X(1,j), &
		c__1, &c_b1, &WORK(1), &c__1);

/*        Compute componentwise relative backward error from formula 
  

          max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )   

          where abs(Z) is the componentwise absolute value of the matr
ix   
          or vector Z.  If the i-th component of the denominator is le
ss   
          than SAFE2, then SAFE1 is added to the i-th components of th
e   
          numerator and denominator before dividing. */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    i__3 = i + j * b_dim1;
	    RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L30: */
	}

/*        Compute abs(A)*abs(X) + abs(B). */

	if (upper) {
	    i__2 = *n;
	    for (k = 1; k <= *n; ++k) {
		s = 0.;
		i__3 = k + j * x_dim1;
		xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
		l = *kd + 1 - k;
/* Computing MAX */
		i__3 = 1, i__4 = k - *kd;
		i__5 = k - 1;
		for (i = max(1,k-*kd); i <= k-1; ++i) {
		    i__3 = l + i + k * ab_dim1;
		    RWORK(i) += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = 
			    d_imag(&AB(l+i,k)), abs(d__2))) * 
			    xk;
		    i__3 = l + i + k * ab_dim1;
		    i__4 = i + j * x_dim1;
		    s += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = d_imag(&AB(l+i,k)), abs(d__2))) * ((d__3 = X(i,j).r, abs(d__3)) + (d__4 = d_imag(&X(i,j)), abs(d__4)));
/* L40: */
		}
		i__5 = *kd + 1 + k * ab_dim1;
		RWORK(k) = RWORK(k) + (d__1 = AB(*kd+1,k).r, abs(d__1)) * xk + s;
/* L50: */
	    }
	} else {
	    i__2 = *n;
	    for (k = 1; k <= *n; ++k) {
		s = 0.;
		i__5 = k + j * x_dim1;
		xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
		i__5 = k * ab_dim1 + 1;
		RWORK(k) += (d__1 = AB(1,k).r, abs(d__1)) * xk;
		l = 1 - k;
/* Computing MIN */
		i__3 = *n, i__4 = k + *kd;
		i__5 = min(i__3,i__4);
		for (i = k + 1; i <= min(*n,k+*kd); ++i) {
		    i__3 = l + i + k * ab_dim1;
		    RWORK(i) += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = 
			    d_imag(&AB(l+i,k)), abs(d__2))) * 
			    xk;
		    i__3 = l + i + k * ab_dim1;
		    i__4 = i + j * x_dim1;
		    s += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = d_imag(&AB(l+i,k)), abs(d__2))) * ((d__3 = X(i,j).r, abs(d__3)) + (d__4 = d_imag(&X(i,j)), abs(d__4)));
/* L60: */
		}
		RWORK(k) += s;
/* L70: */
	    }
	}
	s = 0.;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
/* Computing MAX */
		i__5 = i;
		d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 = 
			d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
		s = max(d__3,d__4);
	    } else {
/* Computing MAX */
		i__5 = i;
		d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 = 
			d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) + 
			safe1);
		s = max(d__3,d__4);
	    }
/* L80: */
	}
	BERR(j) = s;

/*        Test stopping criterion. Continue iterating if   
             1) The residual BERR(J) is larger than machine epsilon, a
nd   
             2) BERR(J) decreased by at least a factor of 2 during the
   
                last iteration, and   
             3) At most ITMAX iterations tried. */

	if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {

/*           Update solution and try again. */

	    zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1), n, 
		    info);
	    zaxpy_(n, &c_b1, &WORK(1), &c__1, &X(1,j), &c__1);
	    lstres = BERR(j);
	    ++count;
	    goto L20;
	}

/*        Bound error from formula   

          norm(X - XTRUE) / norm(X) .le. FERR =   
          norm( abs(inv(A))*   
             ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)   

          where   
            norm(Z) is the magnitude of the largest component of Z   
            inv(A) is the inverse of A   
            abs(Z) is the componentwise absolute value of the matrix o
r   
               vector Z   
            NZ is the maximum number of nonzeros in any row of A, plus
 1   
            EPS is machine epsilon   

          The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) 
  
          is incremented by SAFE1 if the i-th component of   
          abs(A)*abs(X) + abs(B) is less than SAFE2.   

          Use ZLACON to estimate the infinity-norm of the matrix   
             inv(A) * diag(W),   
          where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
		i__5 = i;
		RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
			WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
	    } else {
		i__5 = i;
		RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
			WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
	    }
/* L90: */
	}

	kase = 0;
L100:
	zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
	if (kase != 0) {
	    if (kase == 1) {

/*              Multiply by diag(W)*inv(A'). */

		zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
			 n, info);
		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__5 = i;
		    i__3 = i;
		    i__4 = i;
		    z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L110: */
		}
	    } else if (kase == 2) {

/*              Multiply by inv(A)*diag(W). */

		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__5 = i;
		    i__3 = i;
		    i__4 = i;
		    z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L120: */
		}
		zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
			 n, info);
	    }
	    goto L100;
	}

/*        Normalize error. */

	lstres = 0.;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
/* Computing MAX */
	    i__5 = i + j * x_dim1;
	    d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 = 
		    d_imag(&X(i,j)), abs(d__2));
	    lstres = max(d__3,d__4);
/* L130: */
	}
	if (lstres != 0.) {
	    FERR(j) /= lstres;
	}

/* L140: */
    }

    return 0;

/*     End of ZPBRFS */

} /* zpbrfs_ */
Esempio n. 7
0
/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d, real *e, 
	complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork,
	 integer *iwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    Using the divide and conquer method, CLAED0 computes all eigenvalues 
  
    of a symmetric tridiagonal matrix which is one diagonal block of   
    those from reducing a dense or band Hermitian matrix and   
    corresponding eigenvectors of the dense or band matrix.   

    Arguments   
    =========   

    QSIZ   (input) INTEGER   
           The dimension of the unitary matrix used to reduce   
           the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1. 
  

    N      (input) INTEGER   
           The dimension of the symmetric tridiagonal matrix.  N >= 0.   

    D      (input/output) REAL array, dimension (N)   
           On entry, the diagonal elements of the tridiagonal matrix.   
           On exit, the eigenvalues in ascending order.   

    E      (input/output) REAL array, dimension (N-1)   
           On entry, the off-diagonal elements of the tridiagonal matrix. 
  
           On exit, E has been destroyed.   

    Q      (input/output) COMPLEX array, dimension (LDQ,N)   
           On entry, Q must contain an QSIZ x N matrix whose columns   
           unitarily orthonormal. It is a part of the unitary matrix   
           that reduces the full dense Hermitian matrix to a   
           (reducible) symmetric tridiagonal matrix.   

    LDQ    (input) INTEGER   
           The leading dimension of the array Q.  LDQ >= max(1,N).   

    IWORK  (workspace) INTEGER array,   
           the dimension of IWORK must be at least   
                        6 + 6*N + 5*N*lg N   
                        ( lg( N ) = smallest integer k   
                                    such that 2^k >= N )   

    RWORK  (workspace) REAL array,   
                                 dimension (1 + 3*N + 2*N*lg N + 3*N**2) 
  
                          ( lg( N ) = smallest integer k   
                                      such that 2^k >= N )   

    QSTORE (workspace) COMPLEX array, dimension (LDQS, N)   
           Used to store parts of   
           the eigenvector matrix when the updating matrix multiplies   
           take place.   

    LDQS   (input) INTEGER   
           The leading dimension of the array QSTORE.   
           LDQS >= max(1,N).   

    INFO   (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   
            > 0:  The algorithm failed to compute an eigenvalue while   
                  working on the submatrix lying in rows and columns   
                  INFO/(N+1) through mod(INFO,N+1).   

    ===================================================================== 
  

    Warning:      N could be as big as QSIZ!   


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__2 = 2;
    static integer c__1 = 1;
    
    /* System generated locals */
    integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
    real r__1;
    /* Builtin functions */
    double log(doublereal);
    integer pow_ii(integer *, integer *);
    /* Local variables */
    static real temp;
    static integer curr, i, j, k, iperm;
    extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
	    complex *, integer *);
    static integer indxq, iwrem;
    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
	    integer *);
    static integer iqptr;
    extern /* Subroutine */ int claed7_(integer *, integer *, integer *, 
	    integer *, integer *, integer *, real *, complex *, integer *, 
	    real *, integer *, real *, integer *, integer *, integer *, 
	    integer *, integer *, real *, complex *, real *, integer *, 
	    integer *);
    static integer tlvls, ll, iq;
    extern /* Subroutine */ int clacrm_(integer *, integer *, complex *, 
	    integer *, real *, integer *, complex *, integer *, real *);
    static integer igivcl;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static integer igivnm, submat, curprb, subpbs, igivpt, curlvl, matsiz, 
	    iprmpt;
    extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, 
	    real *, integer *, real *, integer *);
    static integer lgn, msd2, smm1, spm1, spm2;



#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]

#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define QSTORE(I,J) qstore[(I)-1 + ((J)-1)* ( *ldqs)]

    *info = 0;

/*     IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN   
          INFO = -1   
       ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )   
      $        THEN */
    if (*qsiz < max(0,*n)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*ldq < max(1,*n)) {
	*info = -6;
    } else if (*ldqs < max(1,*n)) {
	*info = -8;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CLAED0", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/*     Determine the size and placement of the submatrices, and save in   
       the leading elements of IWORK. */

    IWORK(1) = *n;
    subpbs = 1;
    tlvls = 0;
L10:
    if (IWORK(subpbs) > 25) {
	for (j = subpbs; j >= 1; --j) {
	    IWORK(j * 2) = (IWORK(j) + 1) / 2;
	    IWORK((j << 1) - 1) = IWORK(j) / 2;
/* L20: */
	}
	++tlvls;
	subpbs <<= 1;
	goto L10;
    }
    i__1 = subpbs;
    for (j = 2; j <= subpbs; ++j) {
	IWORK(j) += IWORK(j - 1);
/* L30: */
    }

/*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 
  
       using rank-1 modifications (cuts). */

    spm1 = subpbs - 1;
    i__1 = spm1;
    for (i = 1; i <= spm1; ++i) {
	submat = IWORK(i) + 1;
	smm1 = submat - 1;
	D(smm1) -= (r__1 = E(smm1), dabs(r__1));
	D(submat) -= (r__1 = E(smm1), dabs(r__1));
/* L40: */
    }

    indxq = (*n << 2) + 3;

/*     Set up workspaces for eigenvalues only/accumulate new vectors   
       routine */

    temp = log((real) (*n)) / log(2.f);
    lgn = (integer) temp;
    if (pow_ii(&c__2, &lgn) < *n) {
	++lgn;
    }
    if (pow_ii(&c__2, &lgn) < *n) {
	++lgn;
    }
    iprmpt = indxq + *n + 1;
    iperm = iprmpt + *n * lgn;
    iqptr = iperm + *n * lgn;
    igivpt = iqptr + *n + 2;
    igivcl = igivpt + *n * lgn;

    igivnm = 1;
    iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
    i__1 = *n;
    iwrem = iq + i__1 * i__1 + 1;
/*     Initialize pointers */
    i__1 = subpbs;
    for (i = 0; i <= subpbs; ++i) {
	IWORK(iprmpt + i) = 1;
	IWORK(igivpt + i) = 1;
/* L50: */
    }
    IWORK(iqptr) = 1;

/*     Solve each submatrix eigenproblem at the bottom of the divide and 
  
       conquer tree. */

    curr = 0;
    i__1 = spm1;
    for (i = 0; i <= spm1; ++i) {
	if (i == 0) {
	    submat = 1;
	    matsiz = IWORK(1);
	} else {
	    submat = IWORK(i) + 1;
	    matsiz = IWORK(i + 1) - IWORK(i);
	}
	ll = iq - 1 + IWORK(iqptr + curr);
	ssteqr_("I", &matsiz, &D(submat), &E(submat), &RWORK(ll), &matsiz, &
		RWORK(1), info);
	clacrm_(qsiz, &matsiz, &Q(1,submat), ldq, &RWORK(ll), &
		matsiz, &QSTORE(1,submat), ldqs, &RWORK(iwrem)
		);
/* Computing 2nd power */
	i__2 = matsiz;
	IWORK(iqptr + curr + 1) = IWORK(iqptr + curr) + i__2 * i__2;
	++curr;
	if (*info > 0) {
	    *info = submat * (*n + 1) + submat + matsiz - 1;
	    return 0;
	}
	k = 1;
	i__2 = IWORK(i + 1);
	for (j = submat; j <= IWORK(i+1); ++j) {
	    IWORK(indxq + j) = k;
	    ++k;
/* L60: */
	}
/* L70: */
    }

/*     Successively merge eigensystems of adjacent submatrices   
       into eigensystem for the corresponding larger matrix.   

       while ( SUBPBS > 1 ) */

    curlvl = 1;
L80:
    if (subpbs > 1) {
	spm2 = subpbs - 2;
	i__1 = spm2;
	for (i = 0; i <= spm2; i += 2) {
	    if (i == 0) {
		submat = 1;
		matsiz = IWORK(2);
		msd2 = IWORK(1);
		curprb = 0;
	    } else {
		submat = IWORK(i) + 1;
		matsiz = IWORK(i + 2) - IWORK(i);
		msd2 = matsiz / 2;
		++curprb;
	    }

/*     Merge lower order eigensystems (of size MSD2 and MATSIZ - M
SD2)   
       into an eigensystem of size MATSIZ.  CLAED7 handles the cas
e   
       when the eigenvectors of a full or band Hermitian matrix (w
hich   
       was reduced to tridiagonal form) are desired.   

       I am free to use Q as a valuable working space until Loop 1
50. */

	    claed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &D(submat)
		    , &QSTORE(1,submat), ldqs, &E(submat + 
		    msd2 - 1), &IWORK(indxq + submat), &RWORK(iq), &IWORK(
		    iqptr), &IWORK(iprmpt), &IWORK(iperm), &IWORK(igivpt), &
		    IWORK(igivcl), &RWORK(igivnm), &Q(1,submat), &
		    RWORK(iwrem), &IWORK(subpbs + 1), info);
	    if (*info > 0) {
		*info = submat * (*n + 1) + submat + matsiz - 1;
		return 0;
	    }
	    IWORK(i / 2 + 1) = IWORK(i + 2);
/* L90: */
	}
	subpbs /= 2;
	++curlvl;
	goto L80;
    }

/*     end while   

       Re-merge the eigenvalues/vectors which were deflated at the final 
  
       merge step. */

    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	j = IWORK(indxq + i);
	RWORK(i) = D(j);
	ccopy_(qsiz, &QSTORE(1,j), &c__1, &Q(1,i), 
		&c__1);
/* L100: */
    }
    scopy_(n, &RWORK(1), &c__1, &D(1), &c__1);

    return 0;

/*     End of CLAED0 */

} /* claed0_ */
Esempio n. 8
0
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
                             complex *h, integer *ldh, complex *w, complex *v, complex *b, integer
                             *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
    /*  -- LAPACK auxiliary routine (version 2.0) --
           Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
           Courant Institute, Argonne National Lab, and Rice University
           September 30, 1994


        Purpose
        =======

        CLAEIN uses inverse iteration to find a right or left eigenvector
        corresponding to the eigenvalue W of a complex upper Hessenberg
        matrix H.

        Arguments
        =========

        RIGHTV   (input) LOGICAL
                = .TRUE. : compute right eigenvector;
                = .FALSE.: compute left eigenvector.

        NOINIT   (input) LOGICAL
                = .TRUE. : no initial vector supplied in V
                = .FALSE.: initial vector supplied in V.

        N       (input) INTEGER
                The order of the matrix H.  N >= 0.

        H       (input) COMPLEX array, dimension (LDH,N)
                The upper Hessenberg matrix H.

        LDH     (input) INTEGER
                The leading dimension of the array H.  LDH >= max(1,N).

        W       (input) COMPLEX
                The eigenvalue of H whose corresponding right or left
                eigenvector is to be computed.

        V       (input/output) COMPLEX array, dimension (N)
                On entry, if NOINIT = .FALSE., V must contain a starting
                vector for inverse iteration; otherwise V need not be set.
                On exit, V contains the computed eigenvector, normalized so
                that the component of largest magnitude has magnitude 1; here

                the magnitude of a complex number (x,y) is taken to be
                |x| + |y|.

        B       (workspace) COMPLEX array, dimension (LDB,N)

        LDB     (input) INTEGER
                The leading dimension of the array B.  LDB >= max(1,N).

        RWORK   (workspace) REAL array, dimension (N)

        EPS3    (input) REAL
                A small machine-dependent value which is used to perturb
                close eigenvalues, and to replace zero pivots.

        SMLNUM  (input) REAL
                A machine-dependent value close to the underflow threshold.

        INFO    (output) INTEGER
                = 0:  successful exit
                = 1:  inverse iteration did not converge; V is set to the
                      last iterate.

        =====================================================================




       Parameter adjustments
           Function Body */
    /* Table of constant values */
    static integer c__1 = 1;

    /* System generated locals */
    integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    doublereal d__1;
    complex q__1, q__2;
    /* Builtin functions */
    double sqrt(doublereal), r_imag(complex *);
    /* Local variables */
    static integer ierr;
    static complex temp;
    static integer i, j;
    static real scale;
    static complex x;
    static char trans[1];
    static real rtemp, rootn, vnorm;
    extern doublereal scnrm2_(integer *, complex *, integer *);
    static complex ei, ej;
    extern integer icamax_(integer *, complex *, integer *);
    extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
                                        *), clatrs_(char *, char *, char *, char *, integer *, complex *,
                                                integer *, complex *, real *, real *, integer *);
    extern doublereal scasum_(integer *, complex *, integer *);
    static char normin[1];
    static real nrmsml, growto;
    static integer its;



#define V(I) v[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define H(I,J) h[(I)-1 + ((J)-1)* ( *ldh)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]

    *info = 0;

    /*     GROWTO is the threshold used in the acceptance test for an
           eigenvector. */

    rootn = sqrt((real) (*n));
    growto = .1f / rootn;
    /* Computing MAX */
    r__1 = 1.f, r__2 = *eps3 * rootn;
    nrmsml = dmax(r__1,r__2) * *smlnum;

    /*     Form B = H - W*I (except that the subdiagonal elements are not
           stored). */

    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
        i__2 = j - 1;
        for (i = 1; i <= j-1; ++i) {
            i__3 = i + j * b_dim1;
            i__4 = i + j * h_dim1;
            B(i,j).r = H(i,j).r, B(i,j).i = H(i,j).i;
            /* L10: */
        }
        i__2 = j + j * b_dim1;
        i__3 = j + j * h_dim1;
        q__1.r = H(j,j).r - w->r, q__1.i = H(j,j).i - w->i;
        B(j,j).r = q__1.r, B(j,j).i = q__1.i;
        /* L20: */
    }

    if (*noinit) {

        /*        Initialize V. */

        i__1 = *n;
        for (i = 1; i <= *n; ++i) {
            i__2 = i;
            V(i).r = *eps3, V(i).i = 0.f;
            /* L30: */
        }
    } else {

        /*        Scale supplied initial vector. */

        vnorm = scnrm2_(n, &V(1), &c__1);
        r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
        csscal_(n, &r__1, &V(1), &c__1);
    }

    if (*rightv) {

        /*        LU decomposition with partial pivoting of B, replacing zero

                  pivots by EPS3. */

        i__1 = *n - 1;
        for (i = 1; i <= *n-1; ++i) {
            i__2 = i + 1 + i * h_dim1;
            ei.r = H(i+1,i).r, ei.i = H(i+1,i).i;
            i__2 = i + i * b_dim1;
            if ((r__1 = B(i,i).r, dabs(r__1)) + (r__2 = r_imag(&B(i,i)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4
                    = r_imag(&ei), dabs(r__4))) {

                /*              Interchange rows and eliminate. */

                cladiv_(&q__1, &B(i,i), &ei);
                x.r = q__1.r, x.i = q__1.i;
                i__2 = i + i * b_dim1;
                B(i,i).r = ei.r, B(i,i).i = ei.i;
                i__2 = *n;
                for (j = i + 1; j <= *n; ++j) {
                    i__3 = i + 1 + j * b_dim1;
                    temp.r = B(i+1,j).r, temp.i = B(i+1,j).i;
                    i__3 = i + 1 + j * b_dim1;
                    i__4 = i + j * b_dim1;
                    q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
                             temp.i + x.i * temp.r;
                    q__1.r = B(i,j).r - q__2.r, q__1.i = B(i,j).i - q__2.i;
                    B(i+1,j).r = q__1.r, B(i+1,j).i = q__1.i;
                    i__3 = i + j * b_dim1;
                    B(i,j).r = temp.r, B(i,j).i = temp.i;
                    /* L40: */
                }
            } else {

                /*              Eliminate without interchange. */

                i__2 = i + i * b_dim1;
                if (B(i,i).r == 0.f && B(i,i).i == 0.f) {
                    i__3 = i + i * b_dim1;
                    B(i,i).r = *eps3, B(i,i).i = 0.f;
                }
                cladiv_(&q__1, &ei, &B(i,i));
                x.r = q__1.r, x.i = q__1.i;
                if (x.r != 0.f || x.i != 0.f) {
                    i__2 = *n;
                    for (j = i + 1; j <= *n; ++j) {
                        i__3 = i + 1 + j * b_dim1;
                        i__4 = i + 1 + j * b_dim1;
                        i__5 = i + j * b_dim1;
                        q__2.r = x.r * B(i,j).r - x.i * B(i,j).i, q__2.i =
                                     x.r * B(i,j).i + x.i * B(i,j).r;
                        q__1.r = B(i+1,j).r - q__2.r, q__1.i = B(i+1,j).i -
                                                               q__2.i;
                        B(i+1,j).r = q__1.r, B(i+1,j).i = q__1.i;
                        /* L50: */
                    }
                }
            }
            /* L60: */
        }
        i__1 = *n + *n * b_dim1;
        if (B(*n,*n).r == 0.f && B(*n,*n).i == 0.f) {
            i__2 = *n + *n * b_dim1;
            B(*n,*n).r = *eps3, B(*n,*n).i = 0.f;
        }

        *(unsigned char *)trans = 'N';

    } else {

        /*        UL decomposition with partial pivoting of B, replacing zero

                  pivots by EPS3. */

        for (j = *n; j >= 2; --j) {
            i__1 = j + (j - 1) * h_dim1;
            ej.r = H(j,j-1).r, ej.i = H(j,j-1).i;
            i__1 = j + j * b_dim1;
            if ((r__1 = B(j,j).r, dabs(r__1)) + (r__2 = r_imag(&B(j,j)), dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4
                    = r_imag(&ej), dabs(r__4))) {

                /*              Interchange columns and eliminate. */

                cladiv_(&q__1, &B(j,j), &ej);
                x.r = q__1.r, x.i = q__1.i;
                i__1 = j + j * b_dim1;
                B(j,j).r = ej.r, B(j,j).i = ej.i;
                i__1 = j - 1;
                for (i = 1; i <= j-1; ++i) {
                    i__2 = i + (j - 1) * b_dim1;
                    temp.r = B(i,j-1).r, temp.i = B(i,j-1).i;
                    i__2 = i + (j - 1) * b_dim1;
                    i__3 = i + j * b_dim1;
                    q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
                             temp.i + x.i * temp.r;
                    q__1.r = B(i,j).r - q__2.r, q__1.i = B(i,j).i - q__2.i;
                    B(i,j-1).r = q__1.r, B(i,j-1).i = q__1.i;
                    i__2 = i + j * b_dim1;
                    B(i,j).r = temp.r, B(i,j).i = temp.i;
                    /* L70: */
                }
            } else {

                /*              Eliminate without interchange. */

                i__1 = j + j * b_dim1;
                if (B(j,j).r == 0.f && B(j,j).i == 0.f) {
                    i__2 = j + j * b_dim1;
                    B(j,j).r = *eps3, B(j,j).i = 0.f;
                }
                cladiv_(&q__1, &ej, &B(j,j));
                x.r = q__1.r, x.i = q__1.i;
                if (x.r != 0.f || x.i != 0.f) {
                    i__1 = j - 1;
                    for (i = 1; i <= j-1; ++i) {
                        i__2 = i + (j - 1) * b_dim1;
                        i__3 = i + (j - 1) * b_dim1;
                        i__4 = i + j * b_dim1;
                        q__2.r = x.r * B(i,j).r - x.i * B(i,j).i, q__2.i =
                                     x.r * B(i,j).i + x.i * B(i,j).r;
                        q__1.r = B(i,j-1).r - q__2.r, q__1.i = B(i,j-1).i -
                                                               q__2.i;
                        B(i,j-1).r = q__1.r, B(i,j-1).i = q__1.i;
                        /* L80: */
                    }
                }
            }
            /* L90: */
        }
        i__1 = b_dim1 + 1;
        if (B(1,1).r == 0.f && B(1,1).i == 0.f) {
            i__2 = b_dim1 + 1;
            B(1,1).r = *eps3, B(1,1).i = 0.f;
        }

        *(unsigned char *)trans = 'C';

    }

    *(unsigned char *)normin = 'N';
    i__1 = *n;
    for (its = 1; its <= *n; ++its) {

        /*        Solve U*x = scale*v for a right eigenvector
                    or U'*x = scale*v for a left eigenvector,
                  overwriting x on v. */

        clatrs_("Upper", trans, "Nonunit", normin, n, &B(1,1), ldb, &V(1)
                , &scale, &RWORK(1), &ierr);
        *(unsigned char *)normin = 'Y';

        /*        Test for sufficient growth in the norm of v. */

        vnorm = scasum_(n, &V(1), &c__1);
        if (vnorm >= growto * scale) {
            goto L120;
        }

        /*        Choose new orthogonal starting vector and try again. */

        rtemp = *eps3 / (rootn + 1.f);
        V(1).r = *eps3, V(1).i = 0.f;
        i__2 = *n;
        for (i = 2; i <= *n; ++i) {
            i__3 = i;
            V(i).r = rtemp, V(i).i = 0.f;
            /* L100: */
        }
        i__2 = *n - its + 1;
        i__3 = *n - its + 1;
        d__1 = *eps3 * rootn;
        q__1.r = V(*n-its+1).r - d__1, q__1.i = V(*n-its+1).i;
        V(*n-its+1).r = q__1.r, V(*n-its+1).i = q__1.i;
        /* L110: */
    }

    /*     Failure to find eigenvector in N iterations. */

    *info = 1;

L120:

    /*     Normalize eigenvector. */

    i = icamax_(n, &V(1), &c__1);
    i__1 = i;
    r__3 = 1.f / ((r__1 = V(i).r, dabs(r__1)) + (r__2 = r_imag(&V(i)),
                  dabs(r__2)));
    csscal_(n, &r__3, &V(1), &c__1);

    return 0;

    /*     End of CLAEIN */

} /* claein_ */
Esempio n. 9
0
/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap, 
	doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal 
	*rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    ZPPCON estimates the reciprocal of the condition number (in the   
    1-norm) of a complex Hermitian positive definite packed matrix using 
  
    the Cholesky factorization A = U**H*U or A = L*L**H computed by   
    ZPPTRF.   

    An estimate is obtained for norm(inv(A)), and the reciprocal of the   
    condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)   
            The triangular factor U or L from the Cholesky factorization 
  
            A = U**H*U or A = L*L**H, packed columnwise in a linear   
            array.  The j-th column of U or L is stored in the array AP   
            as follows:   
            if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;   
            if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.   

    ANORM   (input) DOUBLE PRECISION   
            The 1-norm (or infinity-norm) of the Hermitian matrix A.   

    RCOND   (output) DOUBLE PRECISION   
            The reciprocal of the condition number of the matrix A,   
            computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an   
            estimate of the 1-norm of inv(A) computed in this routine.   

    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   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    /* Local variables */
    static integer kase;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    static logical upper;
    extern doublereal dlamch_(char *);
    static integer ix;
    static doublereal scalel, scaleu;
    extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    integer *);
    static doublereal ainvnm;
    extern integer izamax_(integer *, doublecomplex *, integer *);
    extern /* Subroutine */ int zdrscl_(integer *, doublereal *, 
	    doublecomplex *, integer *);
    static char normin[1];
    static doublereal smlnum;
    extern /* Subroutine */ int zlatps_(char *, char *, char *, char *, 
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    doublereal *, integer *);



#define RWORK(I) rwork[(I)-1]
#define WORK(I) work[(I)-1]
#define AP(I) ap[(I)-1]


    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*anorm < 0.) {
	*info = -4;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZPPCON", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *rcond = 0.;
    if (*n == 0) {
	*rcond = 1.;
	return 0;
    } else if (*anorm == 0.) {
	return 0;
    }

    smlnum = dlamch_("Safe minimum");

/*     Estimate the 1-norm of the inverse. */

    kase = 0;
    *(unsigned char *)normin = 'N';
L10:
    zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
    if (kase != 0) {
	if (upper) {

/*           Multiply by inv(U'). */

	    zlatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
		    AP(1), &WORK(1), &scalel, &RWORK(1), info);
	    *(unsigned char *)normin = 'Y';

/*           Multiply by inv(U). */

	    zlatps_("Upper", "No transpose", "Non-unit", normin, n, &AP(1), &
		    WORK(1), &scaleu, &RWORK(1), info);
	} else {

/*           Multiply by inv(L). */

	    zlatps_("Lower", "No transpose", "Non-unit", normin, n, &AP(1), &
		    WORK(1), &scalel, &RWORK(1), info);
	    *(unsigned char *)normin = 'Y';

/*           Multiply by inv(L'). */

	    zlatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, &
		    AP(1), &WORK(1), &scaleu, &RWORK(1), info);
	}

/*        Multiply by 1/SCALE if doing so will not cause overflow. */

	scale = scalel * scaleu;
	if (scale != 1.) {
	    ix = izamax_(n, &WORK(1), &c__1);
	    i__1 = ix;
	    if (scale < ((d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
		    WORK(ix)), abs(d__2))) * smlnum || scale == 0.) {
		goto L20;
	    }
	    zdrscl_(n, &scale, &WORK(1), &c__1);
	}
	goto L10;
    }

/*     Compute the estimate of the reciprocal condition number. */

    if (ainvnm != 0.) {
	*rcond = 1. / ainvnm / *anorm;
    }

L20:
    return 0;

/*     End of ZPPCON */

} /* zppcon_ */
Esempio n. 10
0
/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap, 
	real *w, complex *z, integer *ldz, complex *work, real *rwork, 
	integer *info)
{
/*  -- 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   


    Purpose   
    =======   

    CHPEV computes all the eigenvalues and, optionally, eigenvectors of a 
  
    complex Hermitian matrix in packed storage.   

    Arguments   
    =========   

    JOBZ    (input) CHARACTER*1   
            = 'N':  Compute eigenvalues only;   
            = 'V':  Compute eigenvalues and eigenvectors.   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)   
            On entry, the upper or lower triangle of the Hermitian matrix 
  
            A, packed columnwise in a linear array.  The j-th column of A 
  
            is stored in the array AP as follows:   
            if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;   
            if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. 
  

            On exit, AP is overwritten by values generated during the   
            reduction to tridiagonal form.  If UPLO = 'U', the diagonal   
            and first superdiagonal of the tridiagonal matrix T overwrite 
  
            the corresponding elements of A, and if UPLO = 'L', the   
            diagonal and first subdiagonal of T overwrite the   
            corresponding elements of A.   

    W       (output) REAL array, dimension (N)   
            If INFO = 0, the eigenvalues in ascending order.   

    Z       (output) COMPLEX array, dimension (LDZ, N)   
            If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal   
            eigenvectors of the matrix A, with the i-th column of Z   
            holding the eigenvector associated with W(i).   
            If JOBZ = 'N', then Z is not referenced.   

    LDZ     (input) INTEGER   
            The leading dimension of the array Z.  LDZ >= 1, and if   
            JOBZ = 'V', LDZ >= max(1,N).   

    WORK    (workspace) COMPLEX array, dimension (max(1, 2*N-1))   

    RWORK   (workspace) REAL array, dimension (max(1, 3*N-2))   

    INFO    (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   
            > 0:  if INFO = i, the algorithm failed to converge; i   
                  off-diagonal elements of an intermediate tridiagonal   
                  form did not converge to zero.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer z_dim1, z_offset, i__1;
    real r__1;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static integer inde;
    static real anrm;
    static integer imax;
    static real rmin, rmax, sigma;
    extern logical lsame_(char *, char *);
    static integer iinfo;
    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
    static logical wantz;
    static integer iscale;
    extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *);
    static real safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static real bignum;
    static integer indtau;
    extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *, 
	    real *, complex *, integer *);
    static integer indrwk, indwrk;
    extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *, 
	    complex *, integer *, real *, integer *), cupgtr_(char *, 
	    integer *, complex *, complex *, complex *, integer *, complex *, 
	    integer *), ssterf_(integer *, real *, real *, integer *);
    static real smlnum, eps;



#define AP(I) ap[(I)-1]
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]

    wantz = lsame_(jobz, "V");

    *info = 0;
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (lsame_(uplo, "L") || lsame_(uplo, "U"))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -7;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CHPEV ", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	W(1) = AP(1).r;
	RWORK(1) = 1.f;
	if (wantz) {
	    i__1 = z_dim1 + 1;
	    Z(1,1).r = 1.f, Z(1,1).i = 0.f;
	}
	return 0;
    }

/*     Get machine constants. */

    safmin = slamch_("Safe minimum");
    eps = slamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1.f / smlnum;
    rmin = sqrt(smlnum);
    rmax = sqrt(bignum);

/*     Scale matrix to allowable range, if necessary. */

    anrm = clanhp_("M", uplo, n, &AP(1), &RWORK(1));
    iscale = 0;
    if (anrm > 0.f && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	i__1 = *n * (*n + 1) / 2;
	csscal_(&i__1, &sigma, &AP(1), &c__1);
    }

/*     Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. 
*/

    inde = 1;
    indtau = 1;
    chptrd_(uplo, n, &AP(1), &W(1), &RWORK(inde), &WORK(indtau), &iinfo);

/*     For eigenvalues only, call SSTERF.  For eigenvectors, first call   
       CUPGTR to generate the orthogonal matrix, then call CSTEQR. */

    if (! wantz) {
	ssterf_(n, &W(1), &RWORK(inde), info);
    } else {
	indwrk = indtau + *n;
	cupgtr_(uplo, n, &AP(1), &WORK(indtau), &Z(1,1), ldz, &WORK(
		indwrk), &iinfo);
	indrwk = inde + *n;
	csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
		indrwk), info);
    }

/*     If matrix was scaled, then rescale eigenvalues appropriately. */

    if (iscale == 1) {
	if (*info == 0) {
	    imax = *n;
	} else {
	    imax = *info - 1;
	}
	r__1 = 1.f / sigma;
	sscal_(&imax, &r__1, &W(1), &c__1);
    }

    return 0;

/*     End of CHPEV */

} /* chpev_ */
Esempio n. 11
0
/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n, 
	integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond, 
	doublecomplex *work, doublereal *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    ZTBCON estimates the reciprocal of the condition number of a   
    triangular band matrix A, in either the 1-norm or the infinity-norm. 
  

    The norm of A is computed and an estimate is obtained for   
    norm(inv(A)), then the reciprocal of the condition number is   
    computed as   
       RCOND = 1 / ( norm(A) * norm(inv(A)) ).   

    Arguments   
    =========   

    NORM    (input) CHARACTER*1   
            Specifies whether the 1-norm condition number or the   
            infinity-norm condition number is required:   
            = '1' or 'O':  1-norm;   
            = 'I':         Infinity-norm.   

    UPLO    (input) CHARACTER*1   
            = 'U':  A is upper triangular;   
            = 'L':  A is lower triangular.   

    DIAG    (input) CHARACTER*1   
            = 'N':  A is non-unit triangular;   
            = 'U':  A is unit triangular.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    KD      (input) INTEGER   
            The number of superdiagonals or subdiagonals of the   
            triangular band matrix A.  KD >= 0.   

    AB      (input) COMPLEX*16 array, dimension (LDAB,N)   
            The upper or lower triangular band matrix A, stored in the   
            first kd+1 rows of the array. The j-th column of A is stored 
  
            in the j-th column of the array AB as follows:   
            if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; 
  
            if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). 
  
            If DIAG = 'U', the diagonal elements of A are not referenced 
  
            and are assumed to be 1.   

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KD+1.   

    RCOND   (output) DOUBLE PRECISION   
            The reciprocal of the condition number of the matrix A,   
            computed as RCOND = 1/(norm(A) * norm(inv(A))).   

    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   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, i__1;
    doublereal d__1, d__2;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    /* Local variables */
    static integer kase, kase1;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    static doublereal anorm;
    static logical upper;
    static doublereal xnorm;
    extern doublereal dlamch_(char *);
    static integer ix;
    extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    integer *);
    static doublereal ainvnm;
    extern integer izamax_(integer *, doublecomplex *, integer *);
    extern doublereal zlantb_(char *, char *, char *, integer *, integer *, 
	    doublecomplex *, integer *, doublereal *);
    static logical onenrm;
    extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *, 
	    integer *);
    static char normin[1];
    static doublereal smlnum;
    static logical nounit;



#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]

    *info = 0;
    upper = lsame_(uplo, "U");
    onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
    nounit = lsame_(diag, "N");

    if (! onenrm && ! lsame_(norm, "I")) {
	*info = -1;
    } else if (! upper && ! lsame_(uplo, "L")) {
	*info = -2;
    } else if (! nounit && ! lsame_(diag, "U")) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*kd < 0) {
	*info = -5;
    } else if (*ldab < *kd + 1) {
	*info = -7;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTBCON", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	*rcond = 1.;
	return 0;
    }

    *rcond = 0.;
    smlnum = dlamch_("Safe minimum") * (doublereal) max(*n,1);

/*     Compute the 1-norm of the triangular matrix A or A'. */

    anorm = zlantb_(norm, uplo, diag, n, kd, &AB(1,1), ldab, &RWORK(1));

/*     Continue only if ANORM > 0. */

    if (anorm > 0.) {

/*        Estimate the 1-norm of the inverse of A. */

	ainvnm = 0.;
	*(unsigned char *)normin = 'N';
	if (onenrm) {
	    kase1 = 1;
	} else {
	    kase1 = 2;
	}
	kase = 0;
L10:
	zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
	if (kase != 0) {
	    if (kase == kase1) {

/*              Multiply by inv(A). */

		zlatbs_(uplo, "No transpose", diag, normin, n, kd, &AB(1,1), ldab, &WORK(1), &scale, &RWORK(1), info);
	    } else {

/*              Multiply by inv(A'). */

		zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &AB(1,1), ldab, &WORK(1), &scale, &RWORK(1), info);
	    }
	    *(unsigned char *)normin = 'Y';

/*           Multiply by 1/SCALE if doing so will not cause overfl
ow. */

	    if (scale != 1.) {
		ix = izamax_(n, &WORK(1), &c__1);
		i__1 = ix;
		xnorm = (d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
			WORK(ix)), abs(d__2));
		if (scale < xnorm * smlnum || scale == 0.) {
		    goto L20;
		}
		zdrscl_(n, &scale, &WORK(1), &c__1);
	    }
	    goto L10;
	}

/*        Compute the estimate of the reciprocal condition number. */

	if (ainvnm != 0.) {
	    *rcond = 1. / anorm / ainvnm;
	}
    }

L20:
    return 0;

/*     End of ZTBCON */

} /* ztbcon_ */
Esempio n. 12
0
/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *
	a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
	b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, 
	complex *work, real *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    CHERFS improves the computed solution to a system of linear   
    equations when the coefficient matrix is Hermitian indefinite, and   
    provides error bounds and backward error estimates for the solution. 
  

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    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) COMPLEX array, dimension (LDA,N)   
            The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N   
            upper triangular part of A contains the upper triangular part 
  
            of the matrix A, and the strictly lower triangular part of A 
  
            is not referenced.  If UPLO = 'L', the leading N-by-N lower   
            triangular part of A contains the lower triangular part of   
            the matrix A, and the strictly upper triangular part of A is 
  
            not referenced.   

    LDA     (input) INTEGER   
            The leading dimension of the array A.  LDA >= max(1,N).   

    AF      (input) COMPLEX array, dimension (LDAF,N)   
            The factored form of the matrix A.  AF contains the block   
            diagonal matrix D and the multipliers used to obtain the   
            factor U or L from the factorization A = U*D*U**H or   
            A = L*D*L**H as computed by CHETRF.   

    LDAF    (input) INTEGER   
            The leading dimension of the array AF.  LDAF >= max(1,N).   

    IPIV    (input) INTEGER array, dimension (N)   
            Details of the interchanges and the block structure of D   
            as determined by CHETRF.   

    B       (input) COMPLEX array, dimension (LDB,NRHS)   
            The right hand side matrix B.   

    LDB     (input) INTEGER   
            The leading dimension of the array B.  LDB >= max(1,N).   

    X       (input/output) COMPLEX array, dimension (LDX,NRHS)   
            On entry, the solution matrix X, as computed by CHETRS.   
            On exit, the improved solution matrix X.   

    LDX     (input) INTEGER   
            The leading dimension of the array X.  LDX >= max(1,N).   

    FERR    (output) REAL array, dimension (NRHS)   
            The estimated forward error bound for each solution vector   
            X(j) (the j-th column of the solution matrix X).   
            If XTRUE is the true solution corresponding to X(j), FERR(j) 
  
            is an estimated upper bound for the magnitude of the largest 
  
            element in (X(j) - XTRUE) divided by the magnitude of the   
            largest element in X(j).  The estimate is as reliable as   
            the estimate for RCOND, and is almost always a slight   
            overestimate of the true error.   

    BERR    (output) REAL array, dimension (NRHS)   
            The componentwise relative backward error of each solution   
            vector X(j) (i.e., the smallest relative change in   
            any element of A or B that makes X(j) an exact solution).   

    WORK    (workspace) COMPLEX array, dimension (2*N)   

    RWORK   (workspace) REAL array, dimension (N)   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   

    Internal Parameters   
    ===================   

    ITMAX is the maximum number of steps of iterative refinement.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static complex c_b1 = {1.f,0.f};
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, 
	    x_offset, i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    complex q__1;
    /* Builtin functions */
    double r_imag(complex *);
    /* Local variables */
    static integer kase;
    static real safe1, safe2;
    static integer i, j, k;
    static real s;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
	    , integer *, complex *, integer *, complex *, complex *, integer *
	    ), ccopy_(integer *, complex *, integer *, complex *, 
	    integer *), caxpy_(integer *, complex *, complex *, integer *, 
	    complex *, integer *);
    static integer count;
    static logical upper;
    extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real 
	    *, integer *);
    static real xk;
    extern doublereal slamch_(char *);
    static integer nz;
    static real safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *), chetrs_(
	    char *, integer *, integer *, complex *, integer *, integer *, 
	    complex *, integer *, integer *);
    static real lstres, eps;



#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]

    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*nrhs < 0) {
	*info = -3;
    } else if (*lda < max(1,*n)) {
	*info = -5;
    } else if (*ldaf < max(1,*n)) {
	*info = -7;
    } else if (*ldb < max(1,*n)) {
	*info = -10;
    } else if (*ldx < max(1,*n)) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CHERFS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    FERR(j) = 0.f;
	    BERR(j) = 0.f;
/* L10: */
	}
	return 0;
    }

/*     NZ = maximum number of nonzero elements in each row of A, plus 1 */

    nz = *n + 1;
    eps = slamch_("Epsilon");
    safmin = slamch_("Safe minimum");
    safe1 = nz * safmin;
    safe2 = safe1 / eps;

/*     Do for each right hand side */

    i__1 = *nrhs;
    for (j = 1; j <= *nrhs; ++j) {

	count = 1;
	lstres = 3.f;
L20:

/*        Loop until stopping criterion is satisfied.   

          Compute residual R = B - A * X */

	ccopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
	q__1.r = -1.f, q__1.i = 0.f;
	chemv_(uplo, n, &q__1, &A(1,1), lda, &X(1,j), &c__1, &
		c_b1, &WORK(1), &c__1);

/*        Compute componentwise relative backward error from formula 
  

          max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )   

          where abs(Z) is the componentwise absolute value of the matr
ix   
          or vector Z.  If the i-th component of the denominator is le
ss   
          than SAFE2, then SAFE1 is added to the i-th components of th
e   
          numerator and denominator before dividing. */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    i__3 = i + j * b_dim1;
	    RWORK(i) = (r__1 = B(i,j).r, dabs(r__1)) + (r__2 = r_imag(&B(i,j)), dabs(r__2));
/* L30: */
	}

/*        Compute abs(A)*abs(X) + abs(B). */

	if (upper) {
	    i__2 = *n;
	    for (k = 1; k <= *n; ++k) {
		s = 0.f;
		i__3 = k + j * x_dim1;
		xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
		i__3 = k - 1;
		for (i = 1; i <= k-1; ++i) {
		    i__4 = i + k * a_dim1;
		    RWORK(i) += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 = 
			    r_imag(&A(i,k)), dabs(r__2))) * xk;
		    i__4 = i + k * a_dim1;
		    i__5 = i + j * x_dim1;
		    s += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 = r_imag(&A(i,k)), dabs(r__2))) * ((r__3 = X(i,j)
			    .r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L40: */
		}
		i__3 = k + k * a_dim1;
		RWORK(k) = RWORK(k) + (r__1 = A(k,k).r, dabs(r__1)) * xk + s;
/* L50: */
	    }
	} else {
	    i__2 = *n;
	    for (k = 1; k <= *n; ++k) {
		s = 0.f;
		i__3 = k + j * x_dim1;
		xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
		i__3 = k + k * a_dim1;
		RWORK(k) += (r__1 = A(k,k).r, dabs(r__1)) * xk;
		i__3 = *n;
		for (i = k + 1; i <= *n; ++i) {
		    i__4 = i + k * a_dim1;
		    RWORK(i) += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 = 
			    r_imag(&A(i,k)), dabs(r__2))) * xk;
		    i__4 = i + k * a_dim1;
		    i__5 = i + j * x_dim1;
		    s += ((r__1 = A(i,k).r, dabs(r__1)) + (r__2 = r_imag(&A(i,k)), dabs(r__2))) * ((r__3 = X(i,j)
			    .r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L60: */
		}
		RWORK(k) += s;
/* L70: */
	    }
	}
	s = 0.f;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
/* Computing MAX */
		i__3 = i;
		r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 = 
			r_imag(&WORK(i)), dabs(r__2))) / RWORK(i);
		s = dmax(r__3,r__4);
	    } else {
/* Computing MAX */
		i__3 = i;
		r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 = 
			r_imag(&WORK(i)), dabs(r__2)) + safe1) / (RWORK(i) + 
			safe1);
		s = dmax(r__3,r__4);
	    }
/* L80: */
	}
	BERR(j) = s;

/*        Test stopping criterion. Continue iterating if   
             1) The residual BERR(J) is larger than machine epsilon, a
nd   
             2) BERR(J) decreased by at least a factor of 2 during the
   
                last iteration, and   
             3) At most ITMAX iterations tried. */

	if (BERR(j) > eps && BERR(j) * 2.f <= lstres && count <= 5) {

/*           Update solution and try again. */

	    chetrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(1), 
		    n, info);
	    caxpy_(n, &c_b1, &WORK(1), &c__1, &X(1,j), &c__1);
	    lstres = BERR(j);
	    ++count;
	    goto L20;
	}

/*        Bound error from formula   

          norm(X - XTRUE) / norm(X) .le. FERR =   
          norm( abs(inv(A))*   
             ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)   

          where   
            norm(Z) is the magnitude of the largest component of Z   
            inv(A) is the inverse of A   
            abs(Z) is the componentwise absolute value of the matrix o
r   
               vector Z   
            NZ is the maximum number of nonzeros in any row of A, plus
 1   
            EPS is machine epsilon   

          The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) 
  
          is incremented by SAFE1 if the i-th component of   
          abs(A)*abs(X) + abs(B) is less than SAFE2.   

          Use CLACON to estimate the infinity-norm of the matrix   
             inv(A) * diag(W),   
          where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
		i__3 = i;
		RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
			&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i);
	    } else {
		i__3 = i;
		RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
			&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i) + safe1;
	    }
/* L90: */
	}

	kase = 0;
L100:
	clacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
	if (kase != 0) {
	    if (kase == 1) {

/*              Multiply by diag(W)*inv(A'). */

		chetrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
			1), n, info);
		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__3 = i;
		    i__4 = i;
		    i__5 = i;
		    q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L110: */
		}
	    } else if (kase == 2) {

/*              Multiply by inv(A)*diag(W). */

		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__3 = i;
		    i__4 = i;
		    i__5 = i;
		    q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L120: */
		}
		chetrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
			1), n, info);
	    }
	    goto L100;
	}

/*        Normalize error. */

	lstres = 0.f;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
/* Computing MAX */
	    i__3 = i + j * x_dim1;
	    r__3 = lstres, r__4 = (r__1 = X(i,j).r, dabs(r__1)) + (r__2 = 
		    r_imag(&X(i,j)), dabs(r__2));
	    lstres = dmax(r__3,r__4);
/* L130: */
	}
	if (lstres != 0.f) {
	    FERR(j) /= lstres;
	}

/* L140: */
    }

    return 0;

/*     End of CHERFS */

} /* cherfs_ */
Esempio n. 13
0
/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *
	nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
	ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
	 integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, 
	doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/*  -- 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   


    Purpose   
    =======   

    ZSYSVX uses the diagonal pivoting factorization to compute the   
    solution to a complex system of linear equations A * X = B,   
    where A is an N-by-N symmetric matrix and X and B are N-by-NRHS   
    matrices.   

    Error bounds on the solution and a condition estimate are also   
    provided.   

    Description   
    ===========   

    The following steps are performed:   

    1. If FACT = 'N', the diagonal pivoting method is used to factor A.   
       The form of the factorization is   
          A = U * D * U**T,  if UPLO = 'U', or   
          A = L * D * L**T,  if UPLO = 'L',   
       where U (or L) is a product of permutation and unit upper (lower) 
  
       triangular matrices, and D is symmetric and block diagonal with   
       1-by-1 and 2-by-2 diagonal blocks.   

    2. The factored form of A is used to estimate the condition number   
       of the matrix A.  If the reciprocal of the condition number is   
       less than machine precision, steps 3 and 4 are skipped.   

    3. The system of equations is solved for X using the factored form   
       of A.   

    4. Iterative refinement is applied to improve the computed solution   
       matrix and calculate error bounds and backward error estimates   
       for it.   

    Arguments   
    =========   

    FACT    (input) CHARACTER*1   
            Specifies whether or not the factored form of A has been   
            supplied on entry.   
            = 'F':  On entry, AF and IPIV contain the factored form   
                    of A.  A, AF and IPIV will not be modified.   
            = 'N':  The matrix A will be copied to AF and factored.   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    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 matrices B and X.  NRHS >= 0.   

    A       (input) COMPLEX*16 array, dimension (LDA,N)   
            The symmetric matrix A.  If UPLO = 'U', the leading N-by-N   
            upper triangular part of A contains the upper triangular part 
  
            of the matrix A, and the strictly lower triangular part of A 
  
            is not referenced.  If UPLO = 'L', the leading N-by-N lower   
            triangular part of A contains the lower triangular part of   
            the matrix A, and the strictly upper triangular part of A is 
  
            not referenced.   

    LDA     (input) INTEGER   
            The leading dimension of the array A.  LDA >= max(1,N).   

    AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)   
            If FACT = 'F', then AF is an input argument and on entry   
            contains the block diagonal matrix D and the multipliers used 
  
            to obtain the factor U or L from the factorization   
            A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.   

            If FACT = 'N', then AF is an output argument and on exit   
            returns the block diagonal matrix D and the multipliers used 
  
            to obtain the factor U or L from the factorization   
            A = U*D*U**T or A = L*D*L**T.   

    LDAF    (input) INTEGER   
            The leading dimension of the array AF.  LDAF >= max(1,N).   

    IPIV    (input or output) INTEGER array, dimension (N)   
            If FACT = 'F', then IPIV is an input argument and on entry   
            contains details of the interchanges and the block structure 
  
            of D, as determined by ZSYTRF.   
            If IPIV(k) > 0, then rows and columns k and IPIV(k) were   
            interchanged and D(k,k) is a 1-by-1 diagonal block.   
            If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and   
            columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) 
  
            is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =   
            IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were   
            interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.   

            If FACT = 'N', then IPIV is an output argument and on exit   
            contains details of the interchanges and the block structure 
  
            of D, as determined by ZSYTRF.   

    B       (input) COMPLEX*16 array, dimension (LDB,NRHS)   
            The N-by-NRHS right hand side matrix B.   

    LDB     (input) INTEGER   
            The leading dimension of the array B.  LDB >= max(1,N).   

    X       (output) COMPLEX*16 array, dimension (LDX,NRHS)   
            If INFO = 0, the N-by-NRHS solution matrix X.   

    LDX     (input) INTEGER   
            The leading dimension of the array X.  LDX >= max(1,N).   

    RCOND   (output) DOUBLE PRECISION   
            The estimate of the reciprocal condition number of the matrix 
  
            A.  If RCOND is less than the machine precision (in   
            particular, if RCOND = 0), the matrix is singular to working 
  
            precision.  This condition is indicated by a return code of   
            INFO > 0, and the solution and error bounds are not computed. 
  

    FERR    (output) DOUBLE PRECISION array, dimension (NRHS)   
            The estimated forward error bound for each solution vector   
            X(j) (the j-th column of the solution matrix X).   
            If XTRUE is the true solution corresponding to X(j), FERR(j) 
  
            is an estimated upper bound for the magnitude of the largest 
  
            element in (X(j) - XTRUE) divided by the magnitude of the   
            largest element in X(j).  The estimate is as reliable as   
            the estimate for RCOND, and is almost always a slight   
            overestimate of the true error.   

    BERR    (output) DOUBLE PRECISION array, dimension (NRHS)   
            The componentwise relative backward error of each solution   
            vector X(j) (i.e., the smallest relative change in   
            any element of A or B that makes X(j) an exact solution).   

    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 WORK.  LWORK >= 2*N, and for best performance   
            LWORK >= N*NB, where NB is the optimal blocksize for   
            ZSYTRF.   

    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   
            > 0: if INFO = i, and i is   
                 <= N: D(i,i) is exactly zero.  The factorization   
                       has been completed, but the block diagonal   
                       matrix D is exactly singular, so the solution and 
  
                       error bounds could not be computed.   
                 = N+1: the block diagonal matrix D is nonsingular, but   
                       RCOND is less than machine precision.  The   
                       factorization has been completed, but the matrix   
                       is singular to working precision, so the solution 
  
                       and error bounds have not been computed.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, 
	    x_offset, i__1;
    /* Local variables */
    extern logical lsame_(char *, char *);
    static doublereal anorm;
    extern doublereal dlamch_(char *);
    static logical nofact;
    extern /* Subroutine */ int xerbla_(char *, integer *), zlacpy_(
	    char *, integer *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *);
    extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *, 
	    integer *, integer *, doublereal *, doublereal *, doublecomplex *,
	     integer *), zsyrfs_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *,
	     doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublecomplex *, doublereal *, 
	    integer *), zsytrf_(char *, integer *, doublecomplex *, 
	    integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *, 
	    integer *, integer *, doublecomplex *, integer *, integer *);


#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]

    *info = 0;
    nofact = lsame_(fact, "N");
    if (! nofact && ! lsame_(fact, "F")) {
	*info = -1;
    } else if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*lda < max(1,*n)) {
	*info = -6;
    } else if (*ldaf < max(1,*n)) {
	*info = -8;
    } else if (*ldb < max(1,*n)) {
	*info = -11;
    } else if (*ldx < max(1,*n)) {
	*info = -13;
    } else if (*lwork < *n << 1) {
	*info = -18;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZSYSVX", &i__1);
	return 0;
    }

    if (nofact) {

/*        Compute the factorization A = U*D*U' or A = L*D*L'. */

	zlacpy_(uplo, n, n, &A(1,1), lda, &AF(1,1), ldaf);
	zsytrf_(uplo, n, &AF(1,1), ldaf, &IPIV(1), &WORK(1), lwork, 
		info);

/*        Return if INFO is non-zero. */

	if (*info != 0) {
	    if (*info > 0) {
		*rcond = 0.;
	    }
	    return 0;
	}
    }

/*     Compute the norm of the matrix A. */

    anorm = zlansy_("I", uplo, n, &A(1,1), lda, &RWORK(1));

/*     Compute the reciprocal of the condition number of A. */

    zsycon_(uplo, n, &AF(1,1), ldaf, &IPIV(1), &anorm, rcond, &WORK(1), 
	    info);

/*     Return if the matrix is singular to working precision. */

    if (*rcond < dlamch_("Epsilon")) {
	*info = *n + 1;
	return 0;
    }

/*     Compute the solution vectors X. */

    zlacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
    zsytrs_(uplo, n, nrhs, &AF(1,1), ldaf, &IPIV(1), &X(1,1), ldx, 
	    info);

/*     Use iterative refinement to improve the computed solutions and   
       compute error bounds and backward error estimates for them. */

    zsyrfs_(uplo, n, nrhs, &A(1,1), lda, &AF(1,1), ldaf, &IPIV(1), 
	    &B(1,1), ldb, &X(1,1), ldx, &FERR(1), &BERR(1), &WORK(1)
	    , &RWORK(1), info);

    return 0;

/*     End of ZSYSVX */

} /* zsysvx_ */
Esempio n. 14
0
/* Subroutine */ int zgegs_(char *jobvsl, char *jobvsr, integer *n,
                            doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
                            doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl,
                            integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *
                            work, integer *lwork, doublereal *rwork, integer *info)
{
    /*  -- 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


        Purpose
        =======

        DGEGS computes for a pair of N-by-N complex nonsymmetric matrices A,

        B:  the generalized eigenvalues (alpha, beta), the complex Schur
        form (A, B), and optionally left and/or right Schur vectors
        (VSL and VSR).

        (If only the generalized eigenvalues are needed, use the driver ZGEGV

        instead.)

        A generalized eigenvalue for a pair of matrices (A,B) is, roughly
        speaking, a scalar w or a ratio  alpha/beta = w, such that  A - w*B
        is singular.  It is usually represented as the pair (alpha,beta),
        as there is a reasonable interpretation for beta=0, and even for
        both being zero.  A good beginning reference is the book, "VISMatrix
        Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)

        The (generalized) Schur form of a pair of matrices is the result of
        multiplying both matrices on the left by one unitary matrix and
        both on the right by another unitary matrix, these two unitary
        matrices being chosen so as to bring the pair of matrices into
        upper triangular form with the diagonal elements of B being
        non-negative real numbers (this is also called complex Schur form.)

        The left and right Schur vectors are the columns of VSL and VSR,
        respectively, where VSL and VSR are the unitary matrices
        which reduce A and B to Schur form:

        Schur form of (A,B) = ( (VSL)**H A (VSR), (VSL)**H B (VSR) )

        Arguments
        =========

        JOBVSL   (input) CHARACTER*1
                = 'N':  do not compute the left Schur vectors;
                = 'V':  compute the left Schur vectors.

        JOBVSR   (input) CHARACTER*1
                = 'N':  do not compute the right Schur vectors;
                = 'V':  compute the right Schur vectors.

        N       (input) INTEGER
                The order of the matrices A, B, VSL, and VSR.  N >= 0.

        A       (input/output) COMPLEX*16 array, dimension (LDA, N)
                On entry, the first of the pair of matrices whose generalized

                eigenvalues and (optionally) Schur vectors are to be
                computed.
                On exit, the generalized Schur form of A.

        LDA     (input) INTEGER
                The leading dimension of A.  LDA >= max(1,N).

        B       (input/output) COMPLEX*16 array, dimension (LDB, N)
                On entry, the second of the pair of matrices whose
                generalized eigenvalues and (optionally) Schur vectors are
                to be computed.
                On exit, the generalized Schur form of B.

        LDB     (input) INTEGER
                The leading dimension of B.  LDB >= max(1,N).

        ALPHA   (output) COMPLEX*16 array, dimension (N)
        BETA    (output) COMPLEX*16 array, dimension (N)
                On exit,  ALPHA(j)/BETA(j), j=1,...,N, will be the
                generalized eigenvalues.  ALPHA(j), j=1,...,N  and  BETA(j),

                j=1,...,N  are the diagonals of the complex Schur form (A,B)

                output by ZGEGS.  The  BETA(j) will be non-negative real.

                Note: the quotients ALPHA(j)/BETA(j) may easily over- or
                underflow, and BETA(j) may even be zero.  Thus, the user
                should avoid naively computing the ratio alpha/beta.
                However, ALPHA will be always less than and usually
                comparable with norm(A) in magnitude, and BETA always less
                than and usually comparable with norm(B).

        VSL     (output) COMPLEX*16 array, dimension (LDVSL,N)
                If JOBVSL = 'V', VSL will contain the left Schur vectors.
                (See "Purpose", above.)
                Not referenced if JOBVSL = 'N'.

        LDVSL   (input) INTEGER
                The leading dimension of the matrix VSL. LDVSL >= 1, and
                if JOBVSL = 'V', LDVSL >= N.

        VSR     (output) COMPLEX*16 array, dimension (LDVSR,N)
                If JOBVSR = 'V', VSR will contain the right Schur vectors.
                (See "Purpose", above.)
                Not referenced if JOBVSR = 'N'.

        LDVSR   (input) INTEGER
                The leading dimension of the matrix VSR. LDVSR >= 1, and
                if JOBVSR = 'V', LDVSR >= 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.
                To compute the optimal value of LWORK, call ILAENV to get
                blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.)  Then compute:
                NB  -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;

                the optimal LWORK is N*(NB+1).

        RWORK   (workspace) DOUBLE PRECISION array, dimension (3*N)

        INFO    (output) INTEGER
                = 0:  successful exit
                < 0:  if INFO = -i, the i-th argument had an illegal value.
                =1,...,N:
                      The QZ iteration failed.  (A,B) are not in Schur
                      form, but ALPHA(j) and BETA(j) should be correct for
                      j=INFO+1,...,N.
                > N:  errors that usually indicate LAPACK problems:
                      =N+1: error return from ZGGBAL
                      =N+2: error return from ZGEQRF
                      =N+3: error return from ZUNMQR
                      =N+4: error return from ZUNGQR
                      =N+5: error return from ZGGHRD
                      =N+6: error return from ZHGEQZ (other than failed
                                                     iteration)
                      =N+7: error return from ZGGBAK (computing VSL)
                      =N+8: error return from ZGGBAK (computing VSR)
                      =N+9: error return from ZLASCL (various places)

        =====================================================================



           Decode the input arguments


       Parameter adjustments
           Function Body */
    /* Table of constant values */
    static doublecomplex c_b1 = {0.,0.};
    static doublecomplex c_b2 = {1.,0.};
    static integer c_n1 = -1;
    static integer c__1 = 1;

    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
            vsr_dim1, vsr_offset, i__1, i__2, i__3;
    /* Local variables */
    static doublereal anrm, bnrm;
    static integer itau;
    extern logical lsame_(char *, char *);
    static integer ileft, iinfo, icols;
    static logical ilvsl;
    static integer iwork;
    static logical ilvsr;
    static integer irows;
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
                                        integer *, doublereal *, doublereal *, integer *, doublecomplex *,
                                        integer *, integer *), zggbal_(char *, integer *,
                                                doublecomplex *, integer *, doublecomplex *, integer *, integer *
                                                , integer *, doublereal *, doublereal *, doublereal *, integer *);
    static logical ilascl, ilbscl;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
                              integer *, doublereal *);
    static doublereal bignum;
    static integer ijobvl, iright;
    extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
                                        integer *, doublecomplex *, integer *, doublecomplex *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, integer *, integer *
                                       ), zlascl_(char *, integer *, integer *,
                                               doublereal *, doublereal *, integer *, integer *, doublecomplex *,
                                               integer *, integer *);
    static integer ijobvr;
    extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
                                        integer *, doublecomplex *, doublecomplex *, integer *, integer *
                                       );
    static doublereal anrmto;
    static integer lwkmin;
    static doublereal bnrmto;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, integer *),
                                                      zlaset_(char *, integer *, integer *, doublecomplex *,
                                                              doublecomplex *, doublecomplex *, integer *), zhgeqz_(
                                                                      char *, char *, char *, integer *, integer *, integer *,
                                                                      doublecomplex *, integer *, doublecomplex *, integer *,
                                                                      doublecomplex *, doublecomplex *, doublecomplex *, integer *,
                                                                      doublecomplex *, integer *, doublecomplex *, integer *,
                                                                      doublereal *, integer *);
    static doublereal smlnum;
    static integer irwork, lwkopt;
    extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, doublecomplex *,
                                        integer *, integer *), zunmqr_(char *, char *, integer *, integer
                                                *, integer *, doublecomplex *, integer *, doublecomplex *,
                                                doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static integer ihi, ilo;
    static doublereal eps;



#define ALPHA(I) alpha[(I)-1]
#define BETA(I) beta[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define VSL(I,J) vsl[(I)-1 + ((J)-1)* ( *ldvsl)]
#define VSR(I,J) vsr[(I)-1 + ((J)-1)* ( *ldvsr)]

    if (lsame_(jobvsl, "N")) {
        ijobvl = 1;
        ilvsl = FALSE_;
    } else if (lsame_(jobvsl, "V")) {
        ijobvl = 2;
        ilvsl = TRUE_;
    } else {
        ijobvl = -1;
        ilvsl = FALSE_;
    }

    if (lsame_(jobvsr, "N")) {
        ijobvr = 1;
        ilvsr = FALSE_;
    } else if (lsame_(jobvsr, "V")) {
        ijobvr = 2;
        ilvsr = TRUE_;
    } else {
        ijobvr = -1;
        ilvsr = FALSE_;
    }

    /*     Test the input arguments

       Computing MAX */
    i__1 = *n << 1;
    lwkmin = max(i__1,1);
    lwkopt = lwkmin;
    *info = 0;
    if (ijobvl <= 0) {
        *info = -1;
    } else if (ijobvr <= 0) {
        *info = -2;
    } else if (*n < 0) {
        *info = -3;
    } else if (*lda < max(1,*n)) {
        *info = -5;
    } else if (*ldb < max(1,*n)) {
        *info = -7;
    } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
        *info = -11;
    } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
        *info = -13;
    } else if (*lwork < lwkmin) {
        *info = -15;
    }

    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("ZGEGS ", &i__1);
        return 0;
    }

    /*     Quick return if possible */

    WORK(1).r = (doublereal) lwkopt, WORK(1).i = 0.;
    if (*n == 0) {
        return 0;
    }

    /*     Get machine constants */

    eps = dlamch_("E") * dlamch_("B");
    safmin = dlamch_("S");
    smlnum = *n * safmin / eps;
    bignum = 1. / smlnum;

    /*     Scale A if max element outside range [SMLNUM,BIGNUM] */

    anrm = zlange_("M", n, n, &A(1,1), lda, &RWORK(1));
    ilascl = FALSE_;
    if (anrm > 0. && anrm < smlnum) {
        anrmto = smlnum;
        ilascl = TRUE_;
    } else if (anrm > bignum) {
        anrmto = bignum;
        ilascl = TRUE_;
    }

    if (ilascl) {
        zlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &A(1,1), lda, &
                iinfo);
        if (iinfo != 0) {
            *info = *n + 9;
            return 0;
        }
    }

    /*     Scale B if max element outside range [SMLNUM,BIGNUM] */

    bnrm = zlange_("M", n, n, &B(1,1), ldb, &RWORK(1));
    ilbscl = FALSE_;
    if (bnrm > 0. && bnrm < smlnum) {
        bnrmto = smlnum;
        ilbscl = TRUE_;
    } else if (bnrm > bignum) {
        bnrmto = bignum;
        ilbscl = TRUE_;
    }

    if (ilbscl) {
        zlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &B(1,1), ldb, &
                iinfo);
        if (iinfo != 0) {
            *info = *n + 9;
            return 0;
        }
    }

    /*     Permute the matrix to make it more nearly triangular */

    ileft = 1;
    iright = *n + 1;
    irwork = iright + *n;
    iwork = 1;
    zggbal_("P", n, &A(1,1), lda, &B(1,1), ldb, &ilo, &ihi, &RWORK(
                ileft), &RWORK(iright), &RWORK(irwork), &iinfo);
    if (iinfo != 0) {
        *info = *n + 1;
        goto L10;
    }

    /*     Reduce B to triangular form, and initialize VSL and/or VSR */

    irows = ihi + 1 - ilo;
    icols = *n + 1 - ilo;
    itau = iwork;
    iwork = itau + irows;
    i__1 = *lwork + 1 - iwork;
    zgeqrf_(&irows, &icols, &B(ilo,ilo), ldb, &WORK(itau), &WORK(
                iwork), &i__1, &iinfo);
    if (iinfo >= 0) {
        /* Computing MAX */
        i__3 = iwork;
        i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
        lwkopt = max(i__1,i__2);
    }
    if (iinfo != 0) {
        *info = *n + 2;
        goto L10;
    }

    i__1 = *lwork + 1 - iwork;
    zunmqr_("L", "C", &irows, &icols, &irows, &B(ilo,ilo), ldb, &
            WORK(itau), &A(ilo,ilo), lda, &WORK(iwork), &i__1, &
            iinfo);
    if (iinfo >= 0) {
        /* Computing MAX */
        i__3 = iwork;
        i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
        lwkopt = max(i__1,i__2);
    }
    if (iinfo != 0) {
        *info = *n + 3;
        goto L10;
    }

    if (ilvsl) {
        zlaset_("Full", n, n, &c_b1, &c_b2, &VSL(1,1), ldvsl);
        i__1 = irows - 1;
        i__2 = irows - 1;
        zlacpy_("L", &i__1, &i__2, &B(ilo+1,ilo), ldb, &VSL(ilo+1,ilo), ldvsl);
        i__1 = *lwork + 1 - iwork;
        zungqr_(&irows, &irows, &irows, &VSL(ilo,ilo), ldvsl, &
                WORK(itau), &WORK(iwork), &i__1, &iinfo);
        if (iinfo >= 0) {
            /* Computing MAX */
            i__3 = iwork;
            i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
            lwkopt = max(i__1,i__2);
        }
        if (iinfo != 0) {
            *info = *n + 4;
            goto L10;
        }
    }

    if (ilvsr) {
        zlaset_("Full", n, n, &c_b1, &c_b2, &VSR(1,1), ldvsr);
    }

    /*     Reduce to generalized Hessenberg form */

    zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &A(1,1), lda, &B(1,1),
            ldb, &VSL(1,1), ldvsl, &VSR(1,1), ldvsr, &iinfo);
    if (iinfo != 0) {
        *info = *n + 5;
        goto L10;
    }

    /*     Perform QZ algorithm, computing Schur vectors if desired */

    iwork = itau;
    i__1 = *lwork + 1 - iwork;
    zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &A(1,1), lda, &B(1,1), ldb, &ALPHA(1), &BETA(1), &VSL(1,1), ldvsl, &
            VSR(1,1), ldvsr, &WORK(iwork), &i__1, &RWORK(irwork), &
            iinfo);
    if (iinfo >= 0) {
        /* Computing MAX */
        i__3 = iwork;
        i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
        lwkopt = max(i__1,i__2);
    }
    if (iinfo != 0) {
        if (iinfo > 0 && iinfo <= *n) {
            *info = iinfo;
        } else if (iinfo > *n && iinfo <= *n << 1) {
            *info = iinfo - *n;
        } else {
            *info = *n + 6;
        }
        goto L10;
    }

    /*     Apply permutation to VSL and VSR */

    if (ilvsl) {
        zggbak_("P", "L", n, &ilo, &ihi, &RWORK(ileft), &RWORK(iright), n, &
                VSL(1,1), ldvsl, &iinfo);
        if (iinfo != 0) {
            *info = *n + 7;
            goto L10;
        }
    }
    if (ilvsr) {
        zggbak_("P", "R", n, &ilo, &ihi, &RWORK(ileft), &RWORK(iright), n, &
                VSR(1,1), ldvsr, &iinfo);
        if (iinfo != 0) {
            *info = *n + 8;
            goto L10;
        }
    }

    /*     Undo scaling */

    if (ilascl) {
        zlascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &A(1,1), lda, &
                iinfo);
        if (iinfo != 0) {
            *info = *n + 9;
            return 0;
        }
        zlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &ALPHA(1), n, &
                iinfo);
        if (iinfo != 0) {
            *info = *n + 9;
            return 0;
        }
    }

    if (ilbscl) {
        zlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &B(1,1), ldb, &
                iinfo);
        if (iinfo != 0) {
            *info = *n + 9;
            return 0;
        }
        zlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &BETA(1), n, &
                iinfo);
        if (iinfo != 0) {
            *info = *n + 9;
            return 0;
        }
    }

L10:
    WORK(1).r = (doublereal) lwkopt, WORK(1).i = 0.;

    return 0;

    /*     End of ZGEGS */

} /* zgegs_ */
Esempio n. 15
0
/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select, 
	integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, 
	integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, 
	doublereal *sep, integer *mm, integer *m, doublecomplex *work, 
	integer *ldwork, doublereal *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    ZTRSNA estimates reciprocal condition numbers for specified   
    eigenvalues and/or right eigenvectors of a complex upper triangular   
    matrix T (or of any matrix Q*T*Q**H with Q unitary).   

    Arguments   
    =========   

    JOB     (input) CHARACTER*1   
            Specifies whether condition numbers are required for   
            eigenvalues (S) or eigenvectors (SEP):   
            = 'E': for eigenvalues only (S);   
            = 'V': for eigenvectors only (SEP);   
            = 'B': for both eigenvalues and eigenvectors (S and SEP).   

    HOWMNY  (input) CHARACTER*1   
            = 'A': compute condition numbers for all eigenpairs;   
            = 'S': compute condition numbers for selected eigenpairs   
                   specified by the array SELECT.   

    SELECT  (input) LOGICAL array, dimension (N)   
            If HOWMNY = 'S', SELECT specifies the eigenpairs for which   
            condition numbers are required. To select condition numbers   
            for the j-th eigenpair, SELECT(j) must be set to .TRUE..   
            If HOWMNY = 'A', SELECT is not referenced.   

    N       (input) INTEGER   
            The order of the matrix T. N >= 0.   

    T       (input) COMPLEX*16 array, dimension (LDT,N)   
            The upper triangular matrix T.   

    LDT     (input) INTEGER   
            The leading dimension of the array T. LDT >= max(1,N).   

    VL      (input) COMPLEX*16 array, dimension (LDVL,M)   
            If JOB = 'E' or 'B', VL must contain left eigenvectors of T   
            (or of any Q*T*Q**H with Q unitary), corresponding to the   
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VL, as returned by   
            ZHSEIN or ZTREVC.   
            If JOB = 'V', VL is not referenced.   

    LDVL    (input) INTEGER   
            The leading dimension of the array VL.   
            LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.   

    VR      (input) COMPLEX*16 array, dimension (LDVR,M)   
            If JOB = 'E' or 'B', VR must contain right eigenvectors of T 
  
            (or of any Q*T*Q**H with Q unitary), corresponding to the   
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VR, as returned by   
            ZHSEIN or ZTREVC.   
            If JOB = 'V', VR is not referenced.   

    LDVR    (input) INTEGER   
            The leading dimension of the array VR.   
            LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.   

    S       (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'E' or 'B', the reciprocal condition numbers of the 
  
            selected eigenvalues, stored in consecutive elements of the   
            array. Thus S(j), SEP(j), and the j-th columns of VL and VR   
            all correspond to the same eigenpair (but not in general the 
  
            j-th eigenpair, unless all eigenpairs are selected).   
            If JOB = 'V', S is not referenced.   

    SEP     (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'V' or 'B', the estimated reciprocal condition   
            numbers of the selected eigenvectors, stored in consecutive   
            elements of the array.   
            If JOB = 'E', SEP is not referenced.   

    MM      (input) INTEGER   
            The number of elements in the arrays S (if JOB = 'E' or 'B') 
  
             and/or SEP (if JOB = 'V' or 'B'). MM >= M.   

    M       (output) INTEGER   
            The number of elements of the arrays S and/or SEP actually   
            used to store the estimated condition numbers.   
            If HOWMNY = 'A', M is set to N.   

    WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,N+1)   
            If JOB = 'E', WORK is not referenced.   

    LDWORK  (input) INTEGER   
            The leading dimension of the array WORK.   
            LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (N)   
            If JOB = 'E', RWORK is not referenced.   

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -i, the i-th argument had an illegal value   

    Further Details   
    ===============   

    The reciprocal of the condition number of an eigenvalue lambda is   
    defined as   

            S(lambda) = |v'*u| / (norm(u)*norm(v))   

    where u and v are the right and left eigenvectors of T corresponding 
  
    to lambda; v' denotes the conjugate transpose of v, and norm(u)   
    denotes the Euclidean norm. These reciprocal condition numbers always 
  
    lie between zero (very badly conditioned) and one (very well   
    conditioned). If n = 1, S(lambda) is defined to be 1.   

    An approximate error bound for a computed eigenvalue W(i) is given by 
  

                        EPS * norm(T) / S(i)   

    where EPS is the machine precision.   

    The reciprocal of the condition number of the right eigenvector u   
    corresponding to lambda is defined as follows. Suppose   

                T = ( lambda  c  )   
                    (   0    T22 )   

    Then the reciprocal condition number is   

            SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )   

    where sigma-min denotes the smallest singular value. We approximate   
    the smallest singular value by the reciprocal of an estimate of the   
    one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is   
    defined to be abs(T(1,1)).   

    An approximate error bound for a computed right eigenvector VR(i)   
    is given by   

                        EPS * norm(T) / SEP(i)   

    ===================================================================== 
  


       Decode and test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, 
	    work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2;
    doublecomplex z__1;
    /* Builtin functions */
    double z_abs(doublecomplex *), d_imag(doublecomplex *);
    /* Local variables */
    static integer kase, ierr;
    static doublecomplex prod;
    static doublereal lnrm, rnrm;
    static integer i, j, k;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublecomplex dummy[1];
    static logical wants;
    static doublereal xnorm;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
	    char *);
    static integer ks, ix;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    static logical wantbh;
    extern /* Subroutine */ int zlacon_(integer *, doublecomplex *, 
	    doublecomplex *, doublereal *, integer *);
    extern integer izamax_(integer *, doublecomplex *, integer *);
    static logical somcon;
    extern /* Subroutine */ int zdrscl_(integer *, doublereal *, 
	    doublecomplex *, integer *);
    static char normin[1];
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublereal smlnum;
    static logical wantsp;
    extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, integer *);
    static doublereal eps, est;



#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]

    wantbh = lsame_(job, "B");
    wants = lsame_(job, "E") || wantbh;
    wantsp = lsame_(job, "V") || wantbh;

    somcon = lsame_(howmny, "S");

/*     Set M to the number of eigenpairs for which condition numbers are 
  
       to be computed. */

    if (somcon) {
	*m = 0;
	i__1 = *n;
	for (j = 1; j <= *n; ++j) {
	    if (SELECT(j)) {
		++(*m);
	    }
/* L10: */
	}
    } else {
	*m = *n;
    }

    *info = 0;
    if (! wants && ! wantsp) {
	*info = -1;
    } else if (! lsame_(howmny, "A") && ! somcon) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*ldt < max(1,*n)) {
	*info = -6;
    } else if (*ldvl < 1 || wants && *ldvl < *n) {
	*info = -8;
    } else if (*ldvr < 1 || wants && *ldvr < *n) {
	*info = -10;
    } else if (*mm < *m) {
	*info = -13;
    } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
	*info = -16;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTRSNA", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	if (somcon) {
	    if (! SELECT(1)) {
		return 0;
	    }
	}
	if (wants) {
	    S(1) = 1.;
	}
	if (wantsp) {
	    SEP(1) = z_abs(&T(1,1));
	}
	return 0;
    }

/*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S") / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

    ks = 1;
    i__1 = *n;
    for (k = 1; k <= *n; ++k) {

	if (somcon) {
	    if (! SELECT(k)) {
		goto L50;
	    }
	}

	if (wants) {

/*           Compute the reciprocal condition number of the k-th 
  
             eigenvalue. */

	    zdotc_(&z__1, n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
	    prod.r = z__1.r, prod.i = z__1.i;
	    rnrm = dznrm2_(n, &VR(1,ks), &c__1);
	    lnrm = dznrm2_(n, &VL(1,ks), &c__1);
	    S(ks) = z_abs(&prod) / (rnrm * lnrm);

	}

	if (wantsp) {

/*           Estimate the reciprocal condition number of the k-th 
  
             eigenvector.   

             Copy the matrix T to the array WORK and swap the k-th
   
             diagonal element to the (1,1) position. */

	    zlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1), 
		    ldwork);
	    ztrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &k, &
		    c__1, &ierr);

/*           Form  C = T22 - lambda*I in WORK(2:N,2:N). */

	    i__2 = *n;
	    for (i = 2; i <= *n; ++i) {
		i__3 = i + i * work_dim1;
		i__4 = i + i * work_dim1;
		i__5 = work_dim1 + 1;
		z__1.r = WORK(i,i).r - WORK(1,1).r, z__1.i = WORK(i,i).i - 
			WORK(1,1).i;
		WORK(i,i).r = z__1.r, WORK(i,i).i = z__1.i;
/* L20: */
	    }

/*           Estimate a lower bound for the 1-norm of inv(C'). The
 1st   
             and (N+1)th columns of WORK are used to store work ve
ctors. */

	    SEP(ks) = 0.;
	    est = 0.;
	    kase = 0;
	    *(unsigned char *)normin = 'N';
L30:
	    i__2 = *n - 1;
	    zlacon_(&i__2, &WORK(1,*n+1), &WORK(1,1)
		    , &est, &kase);

	    if (kase != 0) {
		if (kase == 1) {

/*                 Solve C'*x = scale*b */

		    i__2 = *n - 1;
		    zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
			     &i__2, &WORK(2,2), ldwork, &
			    WORK(1,1), &scale, &RWORK(1), &ierr);
		} else {

/*                 Solve C*x = scale*b */

		    i__2 = *n - 1;
		    zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
			     &WORK(2,2), ldwork, &WORK(1,1), &scale, &RWORK(1), &ierr);
		}
		*(unsigned char *)normin = 'Y';
		if (scale != 1.) {

/*                 Multiply by 1/SCALE if doing so will no
t cause   
                   overflow. */

		    i__2 = *n - 1;
		    ix = izamax_(&i__2, &WORK(1,1), &c__1);
		    i__2 = ix + work_dim1;
		    xnorm = (d__1 = WORK(ix,1).r, abs(d__1)) + (d__2 = d_imag(
			    &WORK(ix,1)), abs(d__2));
		    if (scale < xnorm * smlnum || scale == 0.) {
			goto L40;
		    }
		    zdrscl_(n, &scale, &WORK(1,1), &c__1);
		}
		goto L30;
	    }

	    SEP(ks) = 1. / max(est,smlnum);
	}

L40:
	++ks;
L50:
	;
    }
    return 0;

/*     End of ZTRSNA */

} /* ztrsna_ */
Esempio n. 16
0
/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n, 
	integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, 
	doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, 
	doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
	rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    ZTBRFS provides error bounds and backward error estimates for the   
    solution to a system of linear equations with a triangular band   
    coefficient matrix.   

    The solution matrix X must be computed by ZTBTRS or some other   
    means before entering this routine.  ZTBRFS does not do iterative   
    refinement because doing so cannot improve the backward error.   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  A is upper triangular;   
            = 'L':  A is lower triangular.   

    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)   

    DIAG    (input) CHARACTER*1   
            = 'N':  A is non-unit triangular;   
            = 'U':  A is unit triangular.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    KD      (input) INTEGER   
            The number of superdiagonals or subdiagonals of the   
            triangular band matrix A.  KD >= 0.   

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of columns   
            of the matrices B and X.  NRHS >= 0.   

    AB      (input) COMPLEX*16 array, dimension (LDAB,N)   
            The upper or lower triangular band matrix A, stored in the   
            first kd+1 rows of the array. The j-th column of A is stored 
  
            in the j-th column of the array AB as follows:   
            if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; 
  
            if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). 
  
            If DIAG = 'U', the diagonal elements of A are not referenced 
  
            and are assumed to be 1.   

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KD+1.   

    B       (input) COMPLEX*16 array, dimension (LDB,NRHS)   
            The right hand side matrix B.   

    LDB     (input) INTEGER   
            The leading dimension of the array B.  LDB >= max(1,N).   

    X       (input) COMPLEX*16 array, dimension (LDX,NRHS)   
            The solution matrix X.   

    LDX     (input) INTEGER   
            The leading dimension of the array X.  LDX >= max(1,N).   

    FERR    (output) DOUBLE PRECISION array, dimension (NRHS)   
            The estimated forward error bound for each solution vector   
            X(j) (the j-th column of the solution matrix X).   
            If XTRUE is the true solution corresponding to X(j), FERR(j) 
  
            is an estimated upper bound for the magnitude of the largest 
  
            element in (X(j) - XTRUE) divided by the magnitude of the   
            largest element in X(j).  The estimate is as reliable as   
            the estimate for RCOND, and is almost always a slight   
            overestimate of the true error.   

    BERR    (output) DOUBLE PRECISION array, dimension (NRHS)   
            The componentwise relative backward error of each solution   
            vector X(j) (i.e., the smallest relative change in   
            any element of A or B that makes X(j) an exact solution).   

    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   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, 
	    i__2, i__3, i__4, i__5;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    /* Local variables */
    static integer kase;
    static doublereal safe1, safe2;
    static integer i, j, k;
    static doublereal s;
    extern logical lsame_(char *, char *);
    static logical upper;
    extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *), ztbsv_(char *, char *, 
	    char *, integer *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), zaxpy_(
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *);
    extern doublereal dlamch_(char *);
    static doublereal xk;
    static integer nz;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    integer *);
    static logical notran;
    static char transn[1], transt[1];
    static logical nounit;
    static doublereal lstres, eps;



#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]

    *info = 0;
    upper = lsame_(uplo, "U");
    notran = lsame_(trans, "N");
    nounit = lsame_(diag, "N");

    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, 
	    "C")) {
	*info = -2;
    } else if (! nounit && ! lsame_(diag, "U")) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*kd < 0) {
	*info = -5;
    } else if (*nrhs < 0) {
	*info = -6;
    } else if (*ldab < *kd + 1) {
	*info = -8;
    } else if (*ldb < max(1,*n)) {
	*info = -10;
    } else if (*ldx < max(1,*n)) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTBRFS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    FERR(j) = 0.;
	    BERR(j) = 0.;
/* L10: */
	}
	return 0;
    }

    if (notran) {
	*(unsigned char *)transn = 'N';
	*(unsigned char *)transt = 'C';
    } else {
	*(unsigned char *)transn = 'C';
	*(unsigned char *)transt = 'N';
    }

/*     NZ = maximum number of nonzero elements in each row of A, plus 1 */

    nz = *kd + 2;
    eps = dlamch_("Epsilon");
    safmin = dlamch_("Safe minimum");
    safe1 = nz * safmin;
    safe2 = safe1 / eps;

/*     Do for each right hand side */

    i__1 = *nrhs;
    for (j = 1; j <= *nrhs; ++j) {

/*        Compute residual R = B - op(A) * X,   
          where op(A) = A, A**T, or A**H, depending on TRANS. */

	zcopy_(n, &X(1,j), &c__1, &WORK(1), &c__1);
	ztbmv_(uplo, trans, diag, n, kd, &AB(1,1), ldab, &WORK(1), &
		c__1);
	z__1.r = -1., z__1.i = 0.;
	zaxpy_(n, &z__1, &B(1,j), &c__1, &WORK(1), &c__1);

/*        Compute componentwise relative backward error from formula 
  

          max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )   

          where abs(Z) is the componentwise absolute value of the matr
ix   
          or vector Z.  If the i-th component of the denominator is le
ss   
          than SAFE2, then SAFE1 is added to the i-th components of th
e   
          numerator and denominator before dividing. */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    i__3 = i + j * b_dim1;
	    RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L20: */
	}

	if (notran) {

/*           Compute abs(A)*abs(X) + abs(B). */

	    if (upper) {
		if (nounit) {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			i__3 = k + j * x_dim1;
			xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
				X(k,j)), abs(d__2));
/* Computing MAX */
			i__3 = 1, i__4 = k - *kd;
			i__5 = k;
			for (i = max(1,k-*kd); i <= k; ++i) {
			    i__3 = *kd + 1 + i - k + k * ab_dim1;
			    RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
				    d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L30: */
			}
/* L40: */
		    }
		} else {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			i__5 = k + j * x_dim1;
			xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
				X(k,j)), abs(d__2));
/* Computing MAX */
			i__5 = 1, i__3 = k - *kd;
			i__4 = k - 1;
			for (i = max(1,k-*kd); i <= k-1; ++i) {
			    i__5 = *kd + 1 + i - k + k * ab_dim1;
			    RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
				    d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L50: */
			}
			RWORK(k) += xk;
/* L60: */
		    }
		}
	    } else {
		if (nounit) {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			i__4 = k + j * x_dim1;
			xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
				X(k,j)), abs(d__2));
/* Computing MIN */
			i__5 = *n, i__3 = k + *kd;
			i__4 = min(i__5,i__3);
			for (i = k; i <= min(*n,k+*kd); ++i) {
			    i__5 = i + 1 - k + k * ab_dim1;
			    RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
				    d__2 = d_imag(&AB(i+1-k,k)
				    ), abs(d__2))) * xk;
/* L70: */
			}
/* L80: */
		    }
		} else {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			i__4 = k + j * x_dim1;
			xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
				X(k,j)), abs(d__2));
/* Computing MIN */
			i__5 = *n, i__3 = k + *kd;
			i__4 = min(i__5,i__3);
			for (i = k + 1; i <= min(*n,k+*kd); ++i) {
			    i__5 = i + 1 - k + k * ab_dim1;
			    RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
				    d__2 = d_imag(&AB(i+1-k,k)
				    ), abs(d__2))) * xk;
/* L90: */
			}
			RWORK(k) += xk;
/* L100: */
		    }
		}
	    }
	} else {

/*           Compute abs(A**H)*abs(X) + abs(B). */

	    if (upper) {
		if (nounit) {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			s = 0.;
/* Computing MAX */
			i__4 = 1, i__5 = k - *kd;
			i__3 = k;
			for (i = max(1,k-*kd); i <= k; ++i) {
			    i__4 = *kd + 1 + i - k + k * ab_dim1;
			    i__5 = i + j * x_dim1;
			    s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 = 
				    d_imag(&AB(*kd+1+i-k,k))
				    , abs(d__2))) * ((d__3 = X(i,j).r, abs(
				    d__3)) + (d__4 = d_imag(&X(i,j)
				    ), abs(d__4)));
/* L110: */
			}
			RWORK(k) += s;
/* L120: */
		    }
		} else {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			i__3 = k + j * x_dim1;
			s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MAX */
			i__3 = 1, i__4 = k - *kd;
			i__5 = k - 1;
			for (i = max(1,k-*kd); i <= k-1; ++i) {
			    i__3 = *kd + 1 + i - k + k * ab_dim1;
			    i__4 = i + j * x_dim1;
			    s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 = 
				    d_imag(&AB(*kd+1+i-k,k))
				    , abs(d__2))) * ((d__3 = X(i,j).r, abs(
				    d__3)) + (d__4 = d_imag(&X(i,j)
				    ), abs(d__4)));
/* L130: */
			}
			RWORK(k) += s;
/* L140: */
		    }
		}
	    } else {
		if (nounit) {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			s = 0.;
/* Computing MIN */
			i__3 = *n, i__4 = k + *kd;
			i__5 = min(i__3,i__4);
			for (i = k; i <= min(*n,k+*kd); ++i) {
			    i__3 = i + 1 - k + k * ab_dim1;
			    i__4 = i + j * x_dim1;
			    s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 = 
				    d_imag(&AB(i+1-k,k)), abs(
				    d__2))) * ((d__3 = X(i,j).r, abs(d__3)) 
				    + (d__4 = d_imag(&X(i,j)), abs(
				    d__4)));
/* L150: */
			}
			RWORK(k) += s;
/* L160: */
		    }
		} else {
		    i__2 = *n;
		    for (k = 1; k <= *n; ++k) {
			i__5 = k + j * x_dim1;
			s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MIN */
			i__3 = *n, i__4 = k + *kd;
			i__5 = min(i__3,i__4);
			for (i = k + 1; i <= min(*n,k+*kd); ++i) {
			    i__3 = i + 1 - k + k * ab_dim1;
			    i__4 = i + j * x_dim1;
			    s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 = 
				    d_imag(&AB(i+1-k,k)), abs(
				    d__2))) * ((d__3 = X(i,j).r, abs(d__3)) 
				    + (d__4 = d_imag(&X(i,j)), abs(
				    d__4)));
/* L170: */
			}
			RWORK(k) += s;
/* L180: */
		    }
		}
	    }
	}
	s = 0.;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
/* Computing MAX */
		i__5 = i;
		d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 = 
			d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
		s = max(d__3,d__4);
	    } else {
/* Computing MAX */
		i__5 = i;
		d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 = 
			d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) + 
			safe1);
		s = max(d__3,d__4);
	    }
/* L190: */
	}
	BERR(j) = s;

/*        Bound error from formula   

          norm(X - XTRUE) / norm(X) .le. FERR =   
          norm( abs(inv(op(A)))*   
             ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X
)   

          where   
            norm(Z) is the magnitude of the largest component of Z   
            inv(op(A)) is the inverse of op(A)   
            abs(Z) is the componentwise absolute value of the matrix o
r   
               vector Z   
            NZ is the maximum number of nonzeros in any row of A, plus
 1   
            EPS is machine epsilon   

          The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B
))   
          is incremented by SAFE1 if the i-th component of   
          abs(op(A))*abs(X) + abs(B) is less than SAFE2.   

          Use ZLACON to estimate the infinity-norm of the matrix   
             inv(op(A)) * diag(W),   
          where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
		i__5 = i;
		RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
			WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
	    } else {
		i__5 = i;
		RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
			WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
	    }
/* L200: */
	}

	kase = 0;
L210:
	zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
	if (kase != 0) {
	    if (kase == 1) {

/*              Multiply by diag(W)*inv(op(A)**H). */

		ztbsv_(uplo, transt, diag, n, kd, &AB(1,1), ldab, &WORK(
			1), &c__1);
		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__5 = i;
		    i__3 = i;
		    i__4 = i;
		    z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L220: */
		}
	    } else {

/*              Multiply by inv(op(A))*diag(W). */

		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__5 = i;
		    i__3 = i;
		    i__4 = i;
		    z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L230: */
		}
		ztbsv_(uplo, transn, diag, n, kd, &AB(1,1), ldab, &WORK(
			1), &c__1);
	    }
	    goto L210;
	}

/*        Normalize error. */

	lstres = 0.;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
/* Computing MAX */
	    i__5 = i + j * x_dim1;
	    d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 = 
		    d_imag(&X(i,j)), abs(d__2));
	    lstres = max(d__3,d__4);
/* L240: */
	}
	if (lstres != 0.) {
	    FERR(j) /= lstres;
	}

/* L250: */
    }

    return 0;

/*     End of ZTBRFS */

} /* ztbrfs_ */
Esempio n. 17
0
/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a, 
	integer *lda, doublereal *b, integer *ldb, doublecomplex *c, integer *
	ldc, doublereal *rwork)
{
/*  -- LAPACK auxiliary routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    ZLACRM performs a very simple matrix-matrix multiplication:   
             C := A * B,   
    where A is M by N and complex; B is N by N and real;   
    C is M by N and complex.   

    Arguments   
    =========   

    M       (input) INTEGER   
            The number of rows of the matrix A and of the matrix C.   
            M >= 0.   

    N       (input) INTEGER   
            The number of columns and rows of the matrix B and   
            the number of columns of the matrix C.   
            N >= 0.   

    A       (input) COMPLEX*16 array, dimension (LDA, N)   
            A contains the M by N matrix A.   

    LDA     (input) INTEGER   
            The leading dimension of the array A. LDA >=max(1,M).   

    B       (input) DOUBLE PRECISION array, dimension (LDB, N)   
            B contains the N by N matrix B.   

    LDB     (input) INTEGER   
            The leading dimension of the array B. LDB >=max(1,N).   

    C       (input) COMPLEX*16 array, dimension (LDC, N)   
            C contains the M by N matrix C.   

    LDC     (input) INTEGER   
            The leading dimension of the array C. LDC >=max(1,N).   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (2*M*N)   

    ===================================================================== 
  


       Quick return if possible.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static doublereal c_b6 = 1.;
    static doublereal c_b7 = 0.;
    
    /* System generated locals */
    integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, 
	    i__3, i__4, i__5;
    doublereal d__1;
    doublecomplex z__1;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    /* Local variables */
    static integer i, j, l;
    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *);



#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]

    if (*m == 0 || *n == 0) {
	return 0;
    }

    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
	i__2 = *m;
	for (i = 1; i <= *m; ++i) {
	    i__3 = i + j * a_dim1;
	    RWORK((j - 1) * *m + i) = A(i,j).r;
/* L10: */
	}
/* L20: */
    }

    l = *m * *n + 1;
    dgemm_("N", "N", m, n, n, &c_b6, &RWORK(1), m, &B(1,1), ldb, &c_b7, &
	    RWORK(l), m);
    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
	i__2 = *m;
	for (i = 1; i <= *m; ++i) {
	    i__3 = i + j * c_dim1;
	    i__4 = l + (j - 1) * *m + i - 1;
	    C(i,j).r = RWORK(l+(j-1)**m+i-1), C(i,j).i = 0.;
/* L30: */
	}
/* L40: */
    }

    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
	i__2 = *m;
	for (i = 1; i <= *m; ++i) {
	    RWORK((j - 1) * *m + i) = d_imag(&A(i,j));
/* L50: */
	}
/* L60: */
    }
    dgemm_("N", "N", m, n, n, &c_b6, &RWORK(1), m, &B(1,1), ldb, &c_b7, &
	    RWORK(l), m);
    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
	i__2 = *m;
	for (i = 1; i <= *m; ++i) {
	    i__3 = i + j * c_dim1;
	    i__4 = i + j * c_dim1;
	    d__1 = C(i,j).r;
	    i__5 = l + (j - 1) * *m + i - 1;
	    z__1.r = d__1, z__1.i = RWORK(l+(j-1)**m+i-1);
	    C(i,j).r = z__1.r, C(i,j).i = z__1.i;
/* L70: */
	}
/* L80: */
    }

    return 0;

/*     End of ZLACRM */

} /* zlacrm_ */
Esempio n. 18
0
/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select, 
	integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer 
	*ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
	ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
	 integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   



    Purpose   
    =======   

    ZTGEVC computes some or all of the right and/or left generalized   
    eigenvectors of a pair of complex upper triangular matrices (A,B).   

    The right generalized eigenvector x and the left generalized   
    eigenvector y of (A,B) corresponding to a generalized eigenvalue   
    w are defined by:   

            (A - wB) * x = 0  and  y**H * (A - wB) = 0   

    where y**H denotes the conjugate tranpose of y.   

    If an eigenvalue w is determined by zero diagonal elements of both A 
  
    and B, a unit vector is returned as the corresponding eigenvector.   

    If all eigenvectors are requested, the routine may either return   
    the matrices X and/or Y of right or left eigenvectors of (A,B), or   
    the products Z*X and/or Q*Y, where Z and Q are input unitary   
    matrices.  If (A,B) was obtained from the generalized Schur   
    factorization of an original pair of matrices   
       (A0,B0) = (Q*A*Z**H,Q*B*Z**H),   
    then Z*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 matrices A and B.  N >= 0.   

    A       (input) COMPLEX*16 array, dimension (LDA,N)   
            The upper triangular matrix A.   

    LDA     (input) INTEGER   
            The leading dimension of array A.  LDA >= max(1,N).   

    B       (input) COMPLEX*16 array, dimension (LDB,N)   
            The upper triangular matrix B.  B must have real diagonal   
            elements.   

    LDB     (input) INTEGER   
            The leading dimension of array B.  LDB >= 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 left Schur vectors returned by ZHGEQZ).   
            On exit, if SIDE = 'L' or 'B', VL contains:   
            if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); 
  
            if HOWMNY = 'B', the matrix Q*Y;   
            if HOWMNY = 'S', the left eigenvectors of (A,B) 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 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 Z   
            of right Schur vectors returned by ZHGEQZ).   
            On exit, if SIDE = 'R' or 'B', VR contains:   
            if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); 
  
            if HOWMNY = 'B', the matrix Z*X;   
            if HOWMNY = 'S', the right eigenvectors of (A,B) 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 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 (2*N)   

    INFO    (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   

    ===================================================================== 
  


       Decode and Test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static doublecomplex c_b1 = {0.,0.};
    static doublecomplex c_b2 = {1.,0.};
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_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, d__4, d__5, d__6;
    doublecomplex z__1, z__2, z__3, z__4;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *, 
	    doublecomplex *, doublecomplex *);
    /* Local variables */
    static integer ibeg, ieig, iend;
    static doublereal dmin__;
    static integer isrc;
    static doublereal temp;
    static doublecomplex suma, sumb;
    static doublereal xmax;
    static doublecomplex d;
    static integer i, j;
    static doublereal scale;
    static logical ilall;
    static integer iside;
    static doublereal sbeta;
    extern logical lsame_(char *, char *);
    static doublereal small;
    static logical compl;
    static doublereal anorm, bnorm;
    static logical compr;
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *);
    static doublecomplex ca, cb;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static logical ilbbad;
    static doublereal acoefa;
    static integer je;
    static doublereal bcoefa, acoeff;
    static doublecomplex bcoeff;
    static logical ilback;
    static integer im;
    static doublereal ascale, bscale;
    extern doublereal dlamch_(char *);
    static integer jr;
    static doublecomplex salpha;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    static logical ilcomp;
    static integer ihwmny;
    static doublereal big;
    static logical lsa, lsb;
    static doublereal ulp;
    static doublecomplex sum;



#define SELECT(I) select[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]

    if (lsame_(howmny, "A")) {
	ihwmny = 1;
	ilall = TRUE_;
	ilback = FALSE_;
    } else if (lsame_(howmny, "S")) {
	ihwmny = 2;
	ilall = FALSE_;
	ilback = FALSE_;
    } else if (lsame_(howmny, "B") || lsame_(howmny, "T")) {
	ihwmny = 3;
	ilall = TRUE_;
	ilback = TRUE_;
    } else {
	ihwmny = -1;
    }

    if (lsame_(side, "R")) {
	iside = 1;
	compl = FALSE_;
	compr = TRUE_;
    } else if (lsame_(side, "L")) {
	iside = 2;
	compl = TRUE_;
	compr = FALSE_;
    } else if (lsame_(side, "B")) {
	iside = 3;
	compl = TRUE_;
	compr = TRUE_;
    } else {
	iside = -1;
    }

/*     Count the number of eigenvectors */

    if (! ilall) {
	im = 0;
	i__1 = *n;
	for (j = 1; j <= *n; ++j) {
	    if (SELECT(j)) {
		++im;
	    }
/* L10: */
	}
    } else {
	im = *n;
    }

/*     Check diagonal of B */

    ilbbad = FALSE_;
    i__1 = *n;
    for (j = 1; j <= *n; ++j) {
	if (d_imag(&B(j,j)) != 0.) {
	    ilbbad = TRUE_;
	}
/* L20: */
    }

    *info = 0;
    if (iside < 0) {
	*info = -1;
    } else if (ihwmny < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*lda < max(1,*n)) {
	*info = -6;
    } else if (ilbbad) {
	*info = -7;
    } else if (*ldb < max(1,*n)) {
	*info = -8;
    } else if (compl && *ldvl < *n || *ldvl < 1) {
	*info = -10;
    } else if (compr && *ldvr < *n || *ldvr < 1) {
	*info = -12;
    } else if (*mm < im) {
	*info = -13;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTGEVC", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *m = im;
    if (*n == 0) {
	return 0;
    }

/*     Machine Constants */

    safmin = dlamch_("Safe minimum");
    big = 1. / safmin;
    dlabad_(&safmin, &big);
    ulp = dlamch_("Epsilon") * dlamch_("Base");
    small = safmin * *n / ulp;
    big = 1. / small;
    bignum = 1. / (safmin * *n);

/*     Compute the 1-norm of each column of the strictly upper triangular 
  
       part of A and B to check for possible overflow in the triangular   
       solver. */

    i__1 = a_dim1 + 1;
    anorm = (d__1 = A(1,1).r, abs(d__1)) + (d__2 = d_imag(&A(1,1)), 
	    abs(d__2));
    i__1 = b_dim1 + 1;
    bnorm = (d__1 = B(1,1).r, abs(d__1)) + (d__2 = d_imag(&B(1,1)), 
	    abs(d__2));
    RWORK(1) = 0.;
    RWORK(*n + 1) = 0.;
    i__1 = *n;
    for (j = 2; j <= *n; ++j) {
	RWORK(j) = 0.;
	RWORK(*n + j) = 0.;
	i__2 = j - 1;
	for (i = 1; i <= j-1; ++i) {
	    i__3 = i + j * a_dim1;
	    RWORK(j) += (d__1 = A(i,j).r, abs(d__1)) + (d__2 = d_imag(&A(i,j)), abs(d__2));
	    i__3 = i + j * b_dim1;
	    RWORK(*n + j) += (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&
		    B(i,j)), abs(d__2));
/* L30: */
	}
/* Computing MAX */
	i__2 = j + j * a_dim1;
	d__3 = anorm, d__4 = RWORK(j) + ((d__1 = A(j,j).r, abs(d__1)) + (
		d__2 = d_imag(&A(j,j)), abs(d__2)));
	anorm = max(d__3,d__4);
/* Computing MAX */
	i__2 = j + j * b_dim1;
	d__3 = bnorm, d__4 = RWORK(*n + j) + ((d__1 = B(j,j).r, abs(d__1)) + 
		(d__2 = d_imag(&B(j,j)), abs(d__2)));
	bnorm = max(d__3,d__4);
/* L40: */
    }

    ascale = 1. / max(anorm,safmin);
    bscale = 1. / max(bnorm,safmin);

/*     Left eigenvectors */

    if (compl) {
	ieig = 0;

/*        Main loop over eigenvalues */

	i__1 = *n;
	for (je = 1; je <= *n; ++je) {
	    if (ilall) {
		ilcomp = TRUE_;
	    } else {
		ilcomp = SELECT(je);
	    }
	    if (ilcomp) {
		++ieig;

		i__2 = je + je * a_dim1;
		i__3 = je + je * b_dim1;
		if ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2)) <= safmin && (d__3 = B(je,je).r,
			 abs(d__3)) <= safmin) {

/*                 Singular matrix pencil -- return unit e
igenvector */

		    i__2 = *n;
		    for (jr = 1; jr <= *n; ++jr) {
			i__3 = jr + ieig * vl_dim1;
			VL(jr,ieig).r = 0., VL(jr,ieig).i = 0.;
/* L50: */
		    }
		    i__2 = ieig + ieig * vl_dim1;
		    VL(ieig,ieig).r = 1., VL(ieig,ieig).i = 0.;
		    goto L140;
		}

/*              Non-singular eigenvalue:   
                Compute coefficients  a  and  b  in   
                     H   
                   y  ( a A - b B ) = 0   

   Computing MAX */
		i__2 = je + je * a_dim1;
		i__3 = je + je * b_dim1;
		d__4 = ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2))) * ascale, d__5 = (d__3 = 
			B(je,je).r, abs(d__3)) * bscale, d__4 = max(d__4,d__5);
		temp = 1. / max(d__4,safmin);
		i__2 = je + je * a_dim1;
		z__2.r = temp * A(je,je).r, z__2.i = temp * A(je,je).i;
		z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
		salpha.r = z__1.r, salpha.i = z__1.i;
		i__2 = je + je * b_dim1;
		sbeta = temp * B(je,je).r * bscale;
		acoeff = sbeta * ascale;
		z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
		bcoeff.r = z__1.r, bcoeff.i = z__1.i;

/*              Scale to avoid underflow */

		lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
		lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), 
			abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) 
			+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;

		scale = 1.;
		if (lsa) {
		    scale = small / abs(sbeta) * min(anorm,big);
		}
		if (lsb) {
/* Computing MAX */
		    d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
			     + (d__2 = d_imag(&salpha), abs(d__2))) * min(
			    bnorm,big);
		    scale = max(d__3,d__4);
		}
		if (lsa || lsb) {
/* Computing MIN   
   Computing MAX */
		    d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6), 
			    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = 
			    d_imag(&bcoeff), abs(d__2));
		    d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
		    scale = min(d__3,d__4);
		    if (lsa) {
			acoeff = ascale * (scale * sbeta);
		    } else {
			acoeff = scale * acoeff;
		    }
		    if (lsb) {
			z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
			z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    } else {
			z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    }
		}

		acoefa = abs(acoeff);
		bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
			bcoeff), abs(d__2));
		xmax = 1.;
		i__2 = *n;
		for (jr = 1; jr <= *n; ++jr) {
		    i__3 = jr;
		    WORK(jr).r = 0., WORK(jr).i = 0.;
/* L60: */
		}
		i__2 = je;
		WORK(je).r = 1., WORK(je).i = 0.;
/* Computing MAX */
		d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, 
			d__1 = max(d__1,d__2);
		dmin__ = max(d__1,safmin);

/*                                              H   
                Triangular solve of  (a A - b B)  y = 0   

                                        H   
                (rowwise in  (a A - b B) , or columnwise in a 
A - b B) */

		i__2 = *n;
		for (j = je + 1; j <= *n; ++j) {

/*                 Compute   
                         j-1   
                   SUM = sum  conjg( a*A(k,j) - b*B(k,j) )
*x(k)   
                         k=je   
                   (Scale if necessary) */

		    temp = 1. / xmax;
		    if (acoefa * RWORK(j) + bcoefa * RWORK(*n + j) > bignum * 
			    temp) {
			i__3 = j - 1;
			for (jr = je; jr <= j-1; ++jr) {
			    i__4 = jr;
			    i__5 = jr;
			    z__1.r = temp * WORK(jr).r, z__1.i = temp * 
				    WORK(jr).i;
			    WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L70: */
			}
			xmax = 1.;
		    }
		    suma.r = 0., suma.i = 0.;
		    sumb.r = 0., sumb.i = 0.;

		    i__3 = j - 1;
		    for (jr = je; jr <= j-1; ++jr) {
			d_cnjg(&z__3, &A(jr,j));
			i__4 = jr;
			z__2.r = z__3.r * WORK(jr).r - z__3.i * WORK(jr)
				.i, z__2.i = z__3.r * WORK(jr).i + z__3.i * 
				WORK(jr).r;
			z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
			suma.r = z__1.r, suma.i = z__1.i;
			d_cnjg(&z__3, &B(jr,j));
			i__4 = jr;
			z__2.r = z__3.r * WORK(jr).r - z__3.i * WORK(jr)
				.i, z__2.i = z__3.r * WORK(jr).i + z__3.i * 
				WORK(jr).r;
			z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
			sumb.r = z__1.r, sumb.i = z__1.i;
/* L80: */
		    }
		    z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
		    d_cnjg(&z__4, &bcoeff);
		    z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i = 
			    z__4.r * sumb.i + z__4.i * sumb.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;

/*                 Form x(j) = - SUM / conjg( a*A(j,j) - b
*B(j,j) )   

                   with scaling and perturbation of the de
nominator */

		    i__3 = j + j * a_dim1;
		    z__3.r = acoeff * A(j,j).r, z__3.i = acoeff * A(j,j).i;
		    i__4 = j + j * b_dim1;
		    z__4.r = bcoeff.r * B(j,j).r - bcoeff.i * B(j,j).i, 
			    z__4.i = bcoeff.r * B(j,j).i + bcoeff.i * B(j,j)
			    .r;
		    z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
		    d_cnjg(&z__1, &z__2);
		    d.r = z__1.r, d.i = z__1.i;
		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) <= dmin__) {
			z__1.r = dmin__, z__1.i = 0.;
			d.r = z__1.r, d.i = z__1.i;
		    }

		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) < 1.) {
			if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum), 
				abs(d__2)) >= bignum * ((d__3 = d.r, abs(d__3)
				) + (d__4 = d_imag(&d), abs(d__4)))) {
			    temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 = 
				    d_imag(&sum), abs(d__2)));
			    i__3 = j - 1;
			    for (jr = je; jr <= j-1; ++jr) {
				i__4 = jr;
				i__5 = jr;
				z__1.r = temp * WORK(jr).r, z__1.i = temp * 
					WORK(jr).i;
				WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L90: */
			    }
			    xmax = temp * xmax;
			    z__1.r = temp * sum.r, z__1.i = temp * sum.i;
			    sum.r = z__1.r, sum.i = z__1.i;
			}
		    }
		    i__3 = j;
		    z__2.r = -sum.r, z__2.i = -sum.i;
		    z_div(&z__1, &z__2, &d);
		    WORK(j).r = z__1.r, WORK(j).i = z__1.i;
/* Computing MAX */
		    i__3 = j;
		    d__3 = xmax, d__4 = (d__1 = WORK(j).r, abs(d__1)) + (
			    d__2 = d_imag(&WORK(j)), abs(d__2));
		    xmax = max(d__3,d__4);
/* L100: */
		}

/*              Back transform eigenvector if HOWMNY='B'. */

		if (ilback) {
		    i__2 = *n + 1 - je;
		    zgemv_("N", n, &i__2, &c_b2, &VL(1,je), ldvl, 
			    &WORK(je), &c__1, &c_b1, &WORK(*n + 1), &c__1)
			    ;
		    isrc = 2;
		    ibeg = 1;
		} else {
		    isrc = 1;
		    ibeg = je;
		}

/*              Copy and scale eigenvector into column of VL 
*/

		xmax = 0.;
		i__2 = *n;
		for (jr = ibeg; jr <= *n; ++jr) {
/* Computing MAX */
		    i__3 = (isrc - 1) * *n + jr;
		    d__3 = xmax, d__4 = (d__1 = WORK((isrc-1)**n+jr).r, abs(d__1)) + (
			    d__2 = d_imag(&WORK((isrc - 1) * *n + jr)), abs(
			    d__2));
		    xmax = max(d__3,d__4);
/* L110: */
		}

		if (xmax > safmin) {
		    temp = 1. / xmax;
		    i__2 = *n;
		    for (jr = ibeg; jr <= *n; ++jr) {
			i__3 = jr + ieig * vl_dim1;
			i__4 = (isrc - 1) * *n + jr;
			z__1.r = temp * WORK((isrc-1)**n+jr).r, z__1.i = temp * WORK(
				(isrc-1)**n+jr).i;
			VL(jr,ieig).r = z__1.r, VL(jr,ieig).i = z__1.i;
/* L120: */
		    }
		} else {
		    ibeg = *n + 1;
		}

		i__2 = ibeg - 1;
		for (jr = 1; jr <= ibeg-1; ++jr) {
		    i__3 = jr + ieig * vl_dim1;
		    VL(jr,ieig).r = 0., VL(jr,ieig).i = 0.;
/* L130: */
		}

	    }
L140:
	    ;
	}
    }

/*     Right eigenvectors */

    if (compr) {
	ieig = im + 1;

/*        Main loop over eigenvalues */

	for (je = *n; je >= 1; --je) {
	    if (ilall) {
		ilcomp = TRUE_;
	    } else {
		ilcomp = SELECT(je);
	    }
	    if (ilcomp) {
		--ieig;

		i__1 = je + je * a_dim1;
		i__2 = je + je * b_dim1;
		if ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2)) <= safmin && (d__3 = B(je,je).r,
			 abs(d__3)) <= safmin) {

/*                 Singular matrix pencil -- return unit e
igenvector */

		    i__1 = *n;
		    for (jr = 1; jr <= *n; ++jr) {
			i__2 = jr + ieig * vr_dim1;
			VR(jr,ieig).r = 0., VR(jr,ieig).i = 0.;
/* L150: */
		    }
		    i__1 = ieig + ieig * vr_dim1;
		    VR(ieig,ieig).r = 1., VR(ieig,ieig).i = 0.;
		    goto L250;
		}

/*              Non-singular eigenvalue:   
                Compute coefficients  a  and  b  in   

                ( a A - b B ) x  = 0   

   Computing MAX */
		i__1 = je + je * a_dim1;
		i__2 = je + je * b_dim1;
		d__4 = ((d__1 = A(je,je).r, abs(d__1)) + (d__2 = d_imag(&A(je,je)), abs(d__2))) * ascale, d__5 = (d__3 = 
			B(je,je).r, abs(d__3)) * bscale, d__4 = max(d__4,d__5);
		temp = 1. / max(d__4,safmin);
		i__1 = je + je * a_dim1;
		z__2.r = temp * A(je,je).r, z__2.i = temp * A(je,je).i;
		z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
		salpha.r = z__1.r, salpha.i = z__1.i;
		i__1 = je + je * b_dim1;
		sbeta = temp * B(je,je).r * bscale;
		acoeff = sbeta * ascale;
		z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
		bcoeff.r = z__1.r, bcoeff.i = z__1.i;

/*              Scale to avoid underflow */

		lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
		lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), 
			abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) 
			+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;

		scale = 1.;
		if (lsa) {
		    scale = small / abs(sbeta) * min(anorm,big);
		}
		if (lsb) {
/* Computing MAX */
		    d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
			     + (d__2 = d_imag(&salpha), abs(d__2))) * min(
			    bnorm,big);
		    scale = max(d__3,d__4);
		}
		if (lsa || lsb) {
/* Computing MIN   
   Computing MAX */
		    d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6), 
			    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = 
			    d_imag(&bcoeff), abs(d__2));
		    d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
		    scale = min(d__3,d__4);
		    if (lsa) {
			acoeff = ascale * (scale * sbeta);
		    } else {
			acoeff = scale * acoeff;
		    }
		    if (lsb) {
			z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
			z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    } else {
			z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
			bcoeff.r = z__1.r, bcoeff.i = z__1.i;
		    }
		}

		acoefa = abs(acoeff);
		bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
			bcoeff), abs(d__2));
		xmax = 1.;
		i__1 = *n;
		for (jr = 1; jr <= *n; ++jr) {
		    i__2 = jr;
		    WORK(jr).r = 0., WORK(jr).i = 0.;
/* L160: */
		}
		i__1 = je;
		WORK(je).r = 1., WORK(je).i = 0.;
/* Computing MAX */
		d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, 
			d__1 = max(d__1,d__2);
		dmin__ = max(d__1,safmin);

/*              Triangular solve of  (a A - b B) x = 0  (colum
nwise)   

                WORK(1:j-1) contains sums w,   
                WORK(j+1:JE) contains x */

		i__1 = je - 1;
		for (jr = 1; jr <= je-1; ++jr) {
		    i__2 = jr;
		    i__3 = jr + je * a_dim1;
		    z__2.r = acoeff * A(jr,je).r, z__2.i = acoeff * A(jr,je).i;
		    i__4 = jr + je * b_dim1;
		    z__3.r = bcoeff.r * B(jr,je).r - bcoeff.i * B(jr,je).i, 
			    z__3.i = bcoeff.r * B(jr,je).i + bcoeff.i * B(jr,je)
			    .r;
		    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
		    WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L170: */
		}
		i__1 = je;
		WORK(je).r = 1., WORK(je).i = 0.;

		for (j = je - 1; j >= 1; --j) {

/*                 Form x(j) := - w(j) / d   
                   with scaling and perturbation of the de
nominator */

		    i__1 = j + j * a_dim1;
		    z__2.r = acoeff * A(j,j).r, z__2.i = acoeff * A(j,j).i;
		    i__2 = j + j * b_dim1;
		    z__3.r = bcoeff.r * B(j,j).r - bcoeff.i * B(j,j).i, 
			    z__3.i = bcoeff.r * B(j,j).i + bcoeff.i * B(j,j)
			    .r;
		    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
		    d.r = z__1.r, d.i = z__1.i;
		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) <= dmin__) {
			z__1.r = dmin__, z__1.i = 0.;
			d.r = z__1.r, d.i = z__1.i;
		    }

		    if ((d__1 = d.r, abs(d__1)) + (d__2 = d_imag(&d), abs(
			    d__2)) < 1.) {
			i__1 = j;
			if ((d__1 = WORK(j).r, abs(d__1)) + (d__2 = d_imag(
				&WORK(j)), abs(d__2)) >= bignum * ((d__3 = 
				d.r, abs(d__3)) + (d__4 = d_imag(&d), abs(
				d__4)))) {
			    i__1 = j;
			    temp = 1. / ((d__1 = WORK(j).r, abs(d__1)) + (
				    d__2 = d_imag(&WORK(j)), abs(d__2)));
			    i__1 = je;
			    for (jr = 1; jr <= je; ++jr) {
				i__2 = jr;
				i__3 = jr;
				z__1.r = temp * WORK(jr).r, z__1.i = temp * 
					WORK(jr).i;
				WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L180: */
			    }
			}
		    }

		    i__1 = j;
		    i__2 = j;
		    z__2.r = -WORK(j).r, z__2.i = -WORK(j).i;
		    z_div(&z__1, &z__2, &d);
		    WORK(j).r = z__1.r, WORK(j).i = z__1.i;

		    if (j > 1) {

/*                    w = w + x(j)*(a A(*,j) - b B(*,j
) ) with scaling */

			i__1 = j;
			if ((d__1 = WORK(j).r, abs(d__1)) + (d__2 = d_imag(
				&WORK(j)), abs(d__2)) > 1.) {
			    i__1 = j;
			    temp = 1. / ((d__1 = WORK(j).r, abs(d__1)) + (
				    d__2 = d_imag(&WORK(j)), abs(d__2)));
			    if (acoefa * RWORK(j) + bcoefa * RWORK(*n + j) >= 
				    bignum * temp) {
				i__1 = je;
				for (jr = 1; jr <= je; ++jr) {
				    i__2 = jr;
				    i__3 = jr;
				    z__1.r = temp * WORK(jr).r, z__1.i = 
					    temp * WORK(jr).i;
				    WORK(jr).r = z__1.r, WORK(jr).i = 
					    z__1.i;
/* L190: */
				}
			    }
			}

			i__1 = j;
			z__1.r = acoeff * WORK(j).r, z__1.i = acoeff * 
				WORK(j).i;
			ca.r = z__1.r, ca.i = z__1.i;
			i__1 = j;
			z__1.r = bcoeff.r * WORK(j).r - bcoeff.i * WORK(
				j).i, z__1.i = bcoeff.r * WORK(j).i + 
				bcoeff.i * WORK(j).r;
			cb.r = z__1.r, cb.i = z__1.i;
			i__1 = j - 1;
			for (jr = 1; jr <= j-1; ++jr) {
			    i__2 = jr;
			    i__3 = jr;
			    i__4 = jr + j * a_dim1;
			    z__3.r = ca.r * A(jr,j).r - ca.i * A(jr,j).i, 
				    z__3.i = ca.r * A(jr,j).i + ca.i * A(jr,j)
				    .r;
			    z__2.r = WORK(jr).r + z__3.r, z__2.i = WORK(
				    jr).i + z__3.i;
			    i__5 = jr + j * b_dim1;
			    z__4.r = cb.r * B(jr,j).r - cb.i * B(jr,j).i, 
				    z__4.i = cb.r * B(jr,j).i + cb.i * B(jr,j)
				    .r;
			    z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - 
				    z__4.i;
			    WORK(jr).r = z__1.r, WORK(jr).i = z__1.i;
/* L200: */
			}
		    }
/* L210: */
		}

/*              Back transform eigenvector if HOWMNY='B'. */

		if (ilback) {
		    zgemv_("N", n, &je, &c_b2, &VR(1,1), ldvr, &WORK(1),
			     &c__1, &c_b1, &WORK(*n + 1), &c__1);
		    isrc = 2;
		    iend = *n;
		} else {
		    isrc = 1;
		    iend = je;
		}

/*              Copy and scale eigenvector into column of VR 
*/

		xmax = 0.;
		i__1 = iend;
		for (jr = 1; jr <= iend; ++jr) {
/* Computing MAX */
		    i__2 = (isrc - 1) * *n + jr;
		    d__3 = xmax, d__4 = (d__1 = WORK((isrc-1)**n+jr).r, abs(d__1)) + (
			    d__2 = d_imag(&WORK((isrc - 1) * *n + jr)), abs(
			    d__2));
		    xmax = max(d__3,d__4);
/* L220: */
		}

		if (xmax > safmin) {
		    temp = 1. / xmax;
		    i__1 = iend;
		    for (jr = 1; jr <= iend; ++jr) {
			i__2 = jr + ieig * vr_dim1;
			i__3 = (isrc - 1) * *n + jr;
			z__1.r = temp * WORK((isrc-1)**n+jr).r, z__1.i = temp * WORK(
				(isrc-1)**n+jr).i;
			VR(jr,ieig).r = z__1.r, VR(jr,ieig).i = z__1.i;
/* L230: */
		    }
		} else {
		    iend = 0;
		}

		i__1 = *n;
		for (jr = iend + 1; jr <= *n; ++jr) {
		    i__2 = jr + ieig * vr_dim1;
		    VR(jr,ieig).r = 0., VR(jr,ieig).i = 0.;
/* L240: */
		}

	    }
L250:
	    ;
	}
    }

    return 0;

/*     End of ZTGEVC */

} /* ztgevc_ */
Esempio n. 19
0
/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n, 
	doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, 
	integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
	w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *
	lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *
	info)
{
/*  -- 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   


    Purpose   
    =======   

    ZHEEVX computes selected eigenvalues and, optionally, eigenvectors   
    of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can   
    be selected by specifying either a range of values or a range of   
    indices for the desired eigenvalues.   

    Arguments   
    =========   

    JOBZ    (input) CHARACTER*1   
            = 'N':  Compute eigenvalues only;   
            = 'V':  Compute eigenvalues and eigenvectors.   

    RANGE   (input) CHARACTER*1   
            = 'A': all eigenvalues will be found.   
            = 'V': all eigenvalues in the half-open interval (VL,VU]   
                   will be found.   
            = 'I': the IL-th through IU-th eigenvalues will be found.   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    A       (input/output) COMPLEX*16 array, dimension (LDA, N)   
            On entry, the Hermitian matrix A.  If UPLO = 'U', the   
            leading N-by-N upper triangular part of A contains the   
            upper triangular part of the matrix A.  If UPLO = 'L',   
            the leading N-by-N lower triangular part of A contains   
            the lower triangular part of the matrix A.   
            On exit, the lower triangle (if UPLO='L') or the upper   
            triangle (if UPLO='U') of A, including the diagonal, is   
            destroyed.   

    LDA     (input) INTEGER   
            The leading dimension of the array A.  LDA >= max(1,N).   

    VL      (input) DOUBLE PRECISION   
    VU      (input) DOUBLE PRECISION   
            If RANGE='V', the lower and upper bounds of the interval to   
            be searched for eigenvalues. VL < VU.   
            Not referenced if RANGE = 'A' or 'I'.   

    IL      (input) INTEGER   
    IU      (input) INTEGER   
            If RANGE='I', the indices (in ascending order) of the   
            smallest and largest eigenvalues to be returned.   
            1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.   
            Not referenced if RANGE = 'A' or 'V'.   

    ABSTOL  (input) DOUBLE PRECISION   
            The absolute error tolerance for the eigenvalues.   
            An approximate eigenvalue is accepted as converged   
            when it is determined to lie in an interval [a,b]   
            of width less than or equal to   

                    ABSTOL + EPS *   max( |a|,|b| ) ,   

            where EPS is the machine precision.  If ABSTOL is less than   
            or equal to zero, then  EPS*|T|  will be used in its place,   
            where |T| is the 1-norm of the tridiagonal matrix obtained   
            by reducing A to tridiagonal form.   

            Eigenvalues will be computed most accurately when ABSTOL is   
            set to twice the underflow threshold 2*DLAMCH('S'), not zero. 
  
            If this routine returns with INFO>0, indicating that some   
            eigenvectors did not converge, try setting ABSTOL to   
            2*DLAMCH('S').   

            See "Computing Small Singular Values of Bidiagonal Matrices   
            with Guaranteed High Relative Accuracy," by Demmel and   
            Kahan, LAPACK Working Note #3.   

    M       (output) INTEGER   
            The total number of eigenvalues found.  0 <= M <= N.   
            If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.   

    W       (output) DOUBLE PRECISION array, dimension (N)   
            On normal exit, the first M elements contain the selected   
            eigenvalues in ascending order.   

    Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))   
            If JOBZ = 'V', then if INFO = 0, the first M columns of Z   
            contain the orthonormal eigenvectors of the matrix A   
            corresponding to the selected eigenvalues, with the i-th   
            column of Z holding the eigenvector associated with W(i).   
            If an eigenvector fails to converge, then that column of Z   
            contains the latest approximation to the eigenvector, and the 
  
            index of the eigenvector is returned in IFAIL.   
            If JOBZ = 'N', then Z is not referenced.   
            Note: the user must ensure that at least max(1,M) columns are 
  
            supplied in the array Z; if RANGE = 'V', the exact value of M 
  
            is not known in advance and an upper bound must be used.   

    LDZ     (input) INTEGER   
            The leading dimension of the array Z.  LDZ >= 1, and if   
            JOBZ = 'V', LDZ >= max(1,N).   

    WORK    (workspace/output) COMPLEX*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,2*N-1).   
            For optimal efficiency, LWORK >= (NB+1)*N,   
            where NB is the blocksize for ZHETRD returned by ILAENV.   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)   

    IWORK   (workspace) INTEGER array, dimension (5*N)   

    IFAIL   (output) INTEGER array, dimension (N)   
            If JOBZ = 'V', then if INFO = 0, the first M elements of   
            IFAIL are zero.  If INFO > 0, then IFAIL contains the   
            indices of the eigenvectors that failed to converge.   
            If JOBZ = 'N', then IFAIL is not referenced.   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  if INFO = i, then i eigenvectors failed to converge.   
                  Their indices are stored in array IFAIL.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
    doublereal d__1, d__2;
    doublecomplex z__1;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static integer indd, inde;
    static doublereal anrm;
    static integer imax;
    static doublereal rmin, rmax;
    static integer lopt, itmp1, i, j, indee;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    static doublereal sigma;
    extern logical lsame_(char *, char *);
    static integer iinfo;
    static char order[1];
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    static logical lower, wantz;
    extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *);
    static integer jj;
    extern doublereal dlamch_(char *);
    static logical alleig, indeig;
    static integer iscale, indibl;
    static logical valeig;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
	    integer *, doublereal *, doublecomplex *, integer *);
    static doublereal abstll, bignum;
    extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    static integer indiwk, indisp, indtau;
    extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
	     integer *), dstebz_(char *, char *, integer *, doublereal *, 
	    doublereal *, integer *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *, doublereal *, integer *, 
	    integer *, doublereal *, integer *, integer *);
    static integer indrwk, indwrk;
    extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *, 
	    integer *, doublereal *, doublereal *, doublecomplex *, 
	    doublecomplex *, integer *, integer *), zlacpy_(char *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     integer *);
    static integer llwork, nsplit;
    static doublereal smlnum;
    extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
	     integer *, doublereal *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *, integer *, integer *, integer *), 
	    zsteqr_(char *, integer *, doublereal *, doublereal *, 
	    doublecomplex *, integer *, doublereal *, integer *), 
	    zungtr_(char *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, integer *), 
	    zunmtr_(char *, char *, char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, integer *);
    static doublereal eps, vll, vuu, tmp1;



#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]

    lower = lsame_(uplo, "L");
    wantz = lsame_(jobz, "V");
    alleig = lsame_(range, "A");
    valeig = lsame_(range, "V");
    indeig = lsame_(range, "I");

    *info = 0;
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (alleig || valeig || indeig)) {
	*info = -2;
    } else if (! (lower || lsame_(uplo, "U"))) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*lda < max(1,*n)) {
	*info = -6;
    } else if (valeig && *n > 0 && *vu <= *vl) {
	*info = -8;
    } else if (indeig && *il < 1) {
	*info = -9;
    } else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
	*info = -10;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -15;
    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = 1, i__2 = (*n << 1) - 1;
	if (*lwork < max(i__1,i__2)) {
	    *info = -17;
	}
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZHEEVX", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *m = 0;
    if (*n == 0) {
	WORK(1).r = 1., WORK(1).i = 0.;
	return 0;
    }

    if (*n == 1) {
	WORK(1).r = 1., WORK(1).i = 0.;
	if (alleig || indeig) {
	    *m = 1;
	    i__1 = a_dim1 + 1;
	    W(1) = A(1,1).r;
	} else if (valeig) {
	    i__1 = a_dim1 + 1;
	    i__2 = a_dim1 + 1;
	    if (*vl < A(1,1).r && *vu >= A(1,1).r) {
		*m = 1;
		i__1 = a_dim1 + 1;
		W(1) = A(1,1).r;
	    }
	}
	if (wantz) {
	    i__1 = z_dim1 + 1;
	    Z(1,1).r = 1., Z(1,1).i = 0.;
	}
	return 0;
    }

/*     Get machine constants. */

    safmin = dlamch_("Safe minimum");
    eps = dlamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1. / smlnum;
    rmin = sqrt(smlnum);
/* Computing MIN */
    d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
    rmax = min(d__1,d__2);

/*     Scale matrix to allowable range, if necessary. */

    iscale = 0;
    abstll = *abstol;
    if (valeig) {
	vll = *vl;
	vuu = *vu;
    }
    anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
    if (anrm > 0. && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	if (lower) {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		i__2 = *n - j + 1;
		zdscal_(&i__2, &sigma, &A(j,j), &c__1);
/* L10: */
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		zdscal_(&j, &sigma, &A(1,j), &c__1);
/* L20: */
	    }
	}
	if (*abstol > 0.) {
	    abstll = *abstol * sigma;
	}
	if (valeig) {
	    vll = *vl * sigma;
	    vuu = *vu * sigma;
	}
    }

/*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */

    indd = 1;
    inde = indd + *n;
    indrwk = inde + *n;
    indtau = 1;
    indwrk = indtau + *n;
    llwork = *lwork - indwrk + 1;
    zhetrd_(uplo, n, &A(1,1), lda, &RWORK(indd), &RWORK(inde), &WORK(
	    indtau), &WORK(indwrk), &llwork, &iinfo);
    i__1 = indwrk;
    z__1.r = *n + WORK(indwrk).r, z__1.i = WORK(indwrk).i;
    lopt = (integer) z__1.r;

/*     If all eigenvalues are desired and ABSTOL is less than or equal to 
  
       zero, then call DSTERF or ZUNGTR and ZSTEQR.  If this fails for   
       some eigenvalue, then try DSTEBZ. */

    if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
	dcopy_(n, &RWORK(indd), &c__1, &W(1), &c__1);
	indee = indrwk + (*n << 1);
	if (! wantz) {
	    i__1 = *n - 1;
	    dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
	    dsterf_(n, &W(1), &RWORK(indee), info);
	} else {
	    zlacpy_("A", n, n, &A(1,1), lda, &Z(1,1), ldz);
	    zungtr_(uplo, n, &Z(1,1), ldz, &WORK(indtau), &WORK(indwrk), 
		    &llwork, &iinfo);
	    i__1 = *n - 1;
	    dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
	    zsteqr_(jobz, n, &W(1), &RWORK(indee), &Z(1,1), ldz, &RWORK(
		    indrwk), info);
	    if (*info == 0) {
		i__1 = *n;
		for (i = 1; i <= *n; ++i) {
		    IFAIL(i) = 0;
/* L30: */
		}
	    }
	}
	if (*info == 0) {
	    *m = *n;
	    goto L40;
	}
	*info = 0;
    }

/*     Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */

    if (wantz) {
	*(unsigned char *)order = 'B';
    } else {
	*(unsigned char *)order = 'E';
    }
    indibl = 1;
    indisp = indibl + *n;
    indiwk = indisp + *n;
    dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &RWORK(indd), &
	    RWORK(inde), m, &nsplit, &W(1), &IWORK(indibl), &IWORK(indisp), &
	    RWORK(indrwk), &IWORK(indiwk), info);

    if (wantz) {
	zstein_(n, &RWORK(indd), &RWORK(inde), m, &W(1), &IWORK(indibl), &
		IWORK(indisp), &Z(1,1), ldz, &RWORK(indrwk), &IWORK(
		indiwk), &IFAIL(1), info);

/*        Apply unitary matrix used in reduction to tridiagonal   
          form to eigenvectors returned by ZSTEIN. */

	zunmtr_("L", uplo, "N", n, m, &A(1,1), lda, &WORK(indtau), &Z(1,1), ldz, &WORK(indwrk), &llwork, &iinfo);
    }

/*     If matrix was scaled, then rescale eigenvalues appropriately. */

L40:
    if (iscale == 1) {
	if (*info == 0) {
	    imax = *m;
	} else {
	    imax = *info - 1;
	}
	d__1 = 1. / sigma;
	dscal_(&imax, &d__1, &W(1), &c__1);
    }

/*     If eigenvalues are not in order, then sort them, along with   
       eigenvectors. */

    if (wantz) {
	i__1 = *m - 1;
	for (j = 1; j <= *m-1; ++j) {
	    i = 0;
	    tmp1 = W(j);
	    i__2 = *m;
	    for (jj = j + 1; jj <= *m; ++jj) {
		if (W(jj) < tmp1) {
		    i = jj;
		    tmp1 = W(jj);
		}
/* L50: */
	    }

	    if (i != 0) {
		itmp1 = IWORK(indibl + i - 1);
		W(i) = W(j);
		IWORK(indibl + i - 1) = IWORK(indibl + j - 1);
		W(j) = tmp1;
		IWORK(indibl + j - 1) = itmp1;
		zswap_(n, &Z(1,i), &c__1, &Z(1,j), &
			c__1);
		if (*info != 0) {
		    itmp1 = IFAIL(i);
		    IFAIL(i) = IFAIL(j);
		    IFAIL(j) = itmp1;
		}
	    }
/* L60: */
	}
    }

/*     Set WORK(1) to optimal complex workspace size.   

   Computing MAX */
    i__1 = (*n << 1) - 1;
    d__1 = (doublereal) max(i__1,lopt);
    WORK(1).r = d__1, WORK(1).i = 0.;

    return 0;

/*     End of ZHEEVX */

} /* zheevx_ */
Esempio n. 20
0
/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a, 
	integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
	work, doublereal *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    ZGECON estimates the reciprocal of the condition number of a general 
  
    complex matrix A, in either the 1-norm or the infinity-norm, using   
    the LU factorization computed by ZGETRF.   

    An estimate is obtained for norm(inv(A)), and the reciprocal of the   
    condition number is computed as   
       RCOND = 1 / ( norm(A) * norm(inv(A)) ).   

    Arguments   
    =========   

    NORM    (input) CHARACTER*1   
            Specifies whether the 1-norm condition number or the   
            infinity-norm condition number is required:   
            = '1' or 'O':  1-norm;   
            = 'I':         Infinity-norm.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 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).   

    ANORM   (input) DOUBLE PRECISION   
            If NORM = '1' or 'O', the 1-norm of the original matrix A.   
            If NORM = 'I', the infinity-norm of the original matrix A.   

    RCOND   (output) DOUBLE PRECISION   
            The reciprocal of the condition number of the matrix A,   
            computed as RCOND = 1/(norm(A) * norm(inv(A))).   

    WORK    (workspace) COMPLEX*16 array, dimension (2*N)   

    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   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, i__1;
    doublereal d__1, d__2;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    /* Local variables */
    static integer kase, kase1;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    extern doublereal dlamch_(char *);
    static doublereal sl;
    static integer ix;
    static doublereal su;
    extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
	    integer *, doublecomplex *, doublecomplex *, doublereal *, 
	    integer *);
    static doublereal ainvnm;
    extern integer izamax_(integer *, doublecomplex *, integer *);
    static logical onenrm;
    extern /* Subroutine */ int zdrscl_(integer *, doublereal *, 
	    doublecomplex *, integer *);
    static char normin[1];
    static doublereal smlnum;
    extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublereal *, doublereal *, integer *);



#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

    *info = 0;
    onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
    if (! onenrm && ! lsame_(norm, "I")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < max(1,*n)) {
	*info = -4;
    } else if (*anorm < 0.) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGECON", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *rcond = 0.;
    if (*n == 0) {
	*rcond = 1.;
	return 0;
    } else if (*anorm == 0.) {
	return 0;
    }

    smlnum = dlamch_("Safe minimum");

/*     Estimate the norm of inv(A). */

    ainvnm = 0.;
    *(unsigned char *)normin = 'N';
    if (onenrm) {
	kase1 = 1;
    } else {
	kase1 = 2;
    }
    kase = 0;
L10:
    zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
    if (kase != 0) {
	if (kase == kase1) {

/*           Multiply by inv(L). */

	    zlatrs_("Lower", "No transpose", "Unit", normin, n, &A(1,1), 
		    lda, &WORK(1), &sl, &RWORK(1), info);

/*           Multiply by inv(U). */

	    zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &su, &RWORK(*n + 1), info);
	} else {

/*           Multiply by inv(U'). */

	    zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &su, &RWORK(*n + 1), info);

/*           Multiply by inv(L'). */

	    zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &A(1,1), lda, &WORK(1), &sl, &RWORK(1), info);
	}

/*        Divide X by 1/(SL*SU) if doing so will not cause overflow. 
*/

	scale = sl * su;
	*(unsigned char *)normin = 'Y';
	if (scale != 1.) {
	    ix = izamax_(n, &WORK(1), &c__1);
	    i__1 = ix;
	    if (scale < ((d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
		    WORK(ix)), abs(d__2))) * smlnum || scale == 0.) {
		goto L20;
	    }
	    zdrscl_(n, &scale, &WORK(1), &c__1);
	}
	goto L10;
    }

/*     Compute the estimate of the reciprocal condition number. */

    if (ainvnm != 0.) {
	*rcond = 1. / ainvnm / *anorm;
    }

L20:
    return 0;

/*     End of ZGECON */

} /* zgecon_ */
Esempio n. 21
0
/* Subroutine */ int chbgv_(char *jobz, char *uplo, integer *n, integer *ka, 
	integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, 
	real *w, complex *z, integer *ldz, complex *work, real *rwork, 
	integer *info)
{
/*  -- 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   


    Purpose   
    =======   

    CHBGV computes all the eigenvalues, and optionally, the eigenvectors 
  
    of a complex generalized Hermitian-definite banded eigenproblem, of   
    the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian   
    and banded, and B is also positive definite.   

    Arguments   
    =========   

    JOBZ    (input) CHARACTER*1   
            = 'N':  Compute eigenvalues only;   
            = 'V':  Compute eigenvalues and eigenvectors.   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangles of A and B are stored;   
            = 'L':  Lower triangles of A and B are stored.   

    N       (input) INTEGER   
            The order of the matrices A and B.  N >= 0.   

    KA      (input) INTEGER   
            The number of superdiagonals of the matrix A if UPLO = 'U',   
            or the number of subdiagonals if UPLO = 'L'. KA >= 0.   

    KB      (input) INTEGER   
            The number of superdiagonals of the matrix B if UPLO = 'U',   
            or the number of subdiagonals if UPLO = 'L'. KB >= 0.   

    AB      (input/output) COMPLEX array, dimension (LDAB, N)   
            On entry, the upper or lower triangle of the Hermitian band   
            matrix A, stored in the first ka+1 rows of the array.  The   
            j-th column of A is stored in the j-th column of the array AB 
  
            as follows:   
            if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; 
  
            if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka). 
  

            On exit, the contents of AB are destroyed.   

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KA+1.   

    BB      (input/output) COMPLEX array, dimension (LDBB, N)   
            On entry, the upper or lower triangle of the Hermitian band   
            matrix B, stored in the first kb+1 rows of the array.  The   
            j-th column of B is stored in the j-th column of the array BB 
  
            as follows:   
            if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; 
  
            if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb). 
  

            On exit, the factor S from the split Cholesky factorization   
            B = S**H*S, as returned by CPBSTF.   

    LDBB    (input) INTEGER   
            The leading dimension of the array BB.  LDBB >= KB+1.   

    W       (output) REAL array, dimension (N)   
            If INFO = 0, the eigenvalues in ascending order.   

    Z       (output) COMPLEX array, dimension (LDZ, N)   
            If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of   
            eigenvectors, with the i-th column of Z holding the   
            eigenvector associated with W(i). The eigenvectors are   
            normalized so that Z**H*B*Z = I.   
            If JOBZ = 'N', then Z is not referenced.   

    LDZ     (input) INTEGER   
            The leading dimension of the array Z.  LDZ >= 1, and if   
            JOBZ = 'V', LDZ >= N.   

    WORK    (workspace) COMPLEX array, dimension (N)   

    RWORK   (workspace) REAL array, dimension (3*N)   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  if INFO = i, and i is:   
               <= N:  the algorithm failed to converge:   
                      i off-diagonal elements of an intermediate   
                      tridiagonal form did not converge to zero;   
               > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF   
                      returned INFO = i: B is not positive definite.   
                      The factorization of B could not be completed and   
                      no eigenvalues or eigenvectors were computed.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* System generated locals */
    integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
    /* Local variables */
    static integer inde;
    static char vect[1];
    extern logical lsame_(char *, char *);
    static integer iinfo;
    static logical upper, wantz;
    extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *, 
	    complex *, integer *, real *, real *, complex *, integer *, 
	    complex *, integer *), chbgst_(char *, char *, 
	    integer *, integer *, integer *, complex *, integer *, complex *, 
	    integer *, complex *, integer *, complex *, real *, integer *), xerbla_(char *, integer *), cpbstf_(char 
	    *, integer *, integer *, complex *, integer *, integer *);
    static integer indwrk;
    extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *, 
	    complex *, integer *, real *, integer *), ssterf_(integer 
	    *, real *, real *, integer *);


#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define BB(I,J) bb[(I)-1 + ((J)-1)* ( *ldbb)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]

    wantz = lsame_(jobz, "V");
    upper = lsame_(uplo, "U");

    *info = 0;
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (upper || lsame_(uplo, "L"))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*ka < 0) {
	*info = -4;
    } else if (*kb < 0 || *kb > *ka) {
	*info = -5;
    } else if (*ldab < *ka + 1) {
	*info = -7;
    } else if (*ldbb < *kb + 1) {
	*info = -9;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CHBGV ", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/*     Form a split Cholesky factorization of B. */

    cpbstf_(uplo, n, kb, &BB(1,1), ldbb, info);
    if (*info != 0) {
	*info = *n + *info;
	return 0;
    }

/*     Transform problem to standard eigenvalue problem. */

    inde = 1;
    indwrk = inde + *n;
    chbgst_(jobz, uplo, n, ka, kb, &AB(1,1), ldab, &BB(1,1), ldbb,
	     &Z(1,1), ldz, &WORK(1), &RWORK(indwrk), &iinfo);

/*     Reduce to tridiagonal form. */

    if (wantz) {
	*(unsigned char *)vect = 'U';
    } else {
	*(unsigned char *)vect = 'N';
    }
    chbtrd_(vect, uplo, n, ka, &AB(1,1), ldab, &W(1), &RWORK(inde), &Z(1,1), ldz, &WORK(1), &iinfo);

/*     For eigenvalues only, call SSTERF.  For eigenvectors, call CSTEQR. 
*/

    if (! wantz) {
	ssterf_(n, &W(1), &RWORK(inde), info);
    } else {
	csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
		indwrk), info);
    }
    return 0;

/*     End of CHBGV */

} /* chbgv_ */
void DenseMatrix<T>::_svd_helper (char JOBU,
                                  char JOBVT,
                                  std::vector<Real> & sigma_val,
                                  std::vector<Number> & U_val,
                                  std::vector<Number> & VT_val)
{

  //    M       (input) int *
  //            The number of rows of the matrix A.  M >= 0.
  // In C/C++, pass the number of *cols* of A
  int M = this->n();

  //    N       (input) int *
  //            The number of columns of the matrix A.  N >= 0.
  // In C/C++, pass the number of *rows* of A
  int N = this->m();

  int min_MN = (M < N) ? M : N;
  int max_MN = (M > N) ? M : N;

  //  A       (input/output) DOUBLE PRECISION 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**T (the right singular vectors,
  //                          stored rowwise);
  //          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
  //                          are destroyed.
  // Here, we pass &(_val[0]).

  //    LDA     (input) int *
  //            The leading dimension of the array A.  LDA >= max(1,M).
  int LDA = M;

  //  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
  //          The singular values of A, sorted so that S(i) >= S(i+1).
  sigma_val.resize( min_MN );

  //  LDU     (input) INTEGER
  //          The leading dimension of the array U.  LDU >= 1; if
  //          JOBU = 'S' or 'A', LDU >= M.
  int LDU = M;

  //  U       (output) DOUBLE PRECISION 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 orthogonal 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.
  if (JOBU == 'S')
    U_val.resize( LDU*min_MN );
  else
    U_val.resize( LDU*M );

  //  LDVT    (input) INTEGER
  //          The leading dimension of the array VT.  LDVT >= 1; if
  //          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
  int LDVT = N;
  if (JOBVT == 'S')
    LDVT = min_MN;

  //  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
  //          If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
  //          V**T;
  //          if JOBVT = 'S', VT contains the first min(m,n) rows of
  //          V**T (the right singular vectors, stored rowwise);
  //          if JOBVT = 'N' or 'O', VT is not referenced.
  VT_val.resize( LDVT*N );

  //  LWORK   (input) INTEGER
  //          The dimension of the array WORK.
  //          LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
  //          For good performance, LWORK should generally be larger.
  //
  //          If LWORK = -1, then a workspace query is assumed; the routine
  //          only calculates the optimal size of the WORK array, returns
  //          this value as the first entry of the WORK array, and no error
  //          message related to LWORK is issued by XERBLA.
  int larger = (3*min_MN+max_MN > 5*min_MN) ? 3*min_MN+max_MN : 5*min_MN;
  int LWORK  = (larger > 1) ? larger : 1;


  //  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
  //          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
  //          if INFO > 0, WORK(2:MIN(M,N)) 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.
  std::vector<Number> WORK( LWORK );

  //  INFO    (output) INTEGER
  //          = 0:  successful exit.
  //          < 0:  if INFO = -i, the i-th argument had an illegal value.
  //          > 0:  if DBDSQR did not converge, INFO specifies how many
  //                superdiagonals of an intermediate bidiagonal form B
  //                did not converge to zero. See the description of WORK
  //                above for details.
  int INFO = 0;

  // Ready to call the actual factorization routine through PETSc's interface.
#ifdef LIBMESH_USE_REAL_NUMBERS
  // Note that the call to LAPACKgesvd_ may modify _val
  LAPACKgesvd_(&JOBU, &JOBVT, &M, &N, &(_val[0]), &LDA, &(sigma_val[0]), &(U_val[0]),
               &LDU, &(VT_val[0]), &LDVT, &(WORK[0]), &LWORK, &INFO);
#else
  // When we have LIBMESH_USE_COMPLEX_NUMBERS then we must pass an array of Complex
  // numbers to LAPACKgesvd_, but _val may contain Reals so we copy to Number below to
  // handle both the real-valued and complex-valued cases.
  std::vector<Number> val_copy(_val.size());
  for(unsigned int i=0; i<_val.size(); i++)
    {
      val_copy[i] = _val[i];
    }

  std::vector<Real> RWORK(5 * min_MN);
  LAPACKgesvd_(&JOBU, &JOBVT, &M, &N, &(val_copy[0]), &LDA, &(sigma_val[0]), &(U_val[0]),
               &LDU, &(VT_val[0]), &LDVT, &(WORK[0]), &LWORK, &(RWORK[0]), &INFO);
#endif

  // Check return value for errors
  if (INFO != 0)
    libmesh_error_msg("INFO=" << INFO << ", Error during Lapack SVD calculation!");
}
Esempio n. 23
0
/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
	 integer *kl, integer *ku, complex *ab, integer *ldab, real *d, real *
	e, complex *q, integer *ldq, complex *pt, integer *ldpt, complex *c, 
	integer *ldc, complex *work, real *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    CGBBRD reduces a complex general m-by-n band matrix A to real upper   
    bidiagonal form B by a unitary transformation: Q' * A * P = B.   

    The routine computes B, and optionally forms Q or P', or computes   
    Q'*C for a given matrix C.   

    Arguments   
    =========   

    VECT    (input) CHARACTER*1   
            Specifies whether or not the matrices Q and P' are to be   
            formed.   
            = 'N': do not form Q or P';   
            = 'Q': form Q only;   
            = 'P': form P' only;   
            = 'B': form both.   

    M       (input) INTEGER   
            The number of rows of the matrix A.  M >= 0.   

    N       (input) INTEGER   
            The number of columns of the matrix A.  N >= 0.   

    NCC     (input) INTEGER   
            The number of columns of the matrix C.  NCC >= 0.   

    KL      (input) INTEGER   
            The number of subdiagonals of the matrix A. KL >= 0.   

    KU      (input) INTEGER   
            The number of superdiagonals of the matrix A. KU >= 0.   

    AB      (input/output) COMPLEX array, dimension (LDAB,N)   
            On entry, the m-by-n band matrix A, stored in rows 1 to   
            KL+KU+1. The j-th column of A is stored in the j-th column of 
  
            the array AB as follows:   
            AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).   
            On exit, A is overwritten by values generated during the   
            reduction.   

    LDAB    (input) INTEGER   
            The leading dimension of the array A. LDAB >= KL+KU+1.   

    D       (output) REAL array, dimension (min(M,N))   
            The diagonal elements of the bidiagonal matrix B.   

    E       (output) REAL array, dimension (min(M,N)-1)   
            The superdiagonal elements of the bidiagonal matrix B.   

    Q       (output) COMPLEX array, dimension (LDQ,M)   
            If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.   
            If VECT = 'N' or 'P', the array Q is not referenced.   

    LDQ     (input) INTEGER   
            The leading dimension of the array Q.   
            LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.   

    PT      (output) COMPLEX array, dimension (LDPT,N)   
            If VECT = 'P' or 'B', the n-by-n unitary matrix P'.   
            If VECT = 'N' or 'Q', the array PT is not referenced.   

    LDPT    (input) INTEGER   
            The leading dimension of the array PT.   
            LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.   

    C       (input/output) COMPLEX array, dimension (LDC,NCC)   
            On entry, an m-by-ncc matrix C.   
            On exit, C is overwritten by Q'*C.   
            C is not referenced if NCC = 0.   

    LDC     (input) INTEGER   
            The leading dimension of the array C.   
            LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.   

    WORK    (workspace) COMPLEX array, dimension (max(M,N))   

    RWORK   (workspace) REAL array, dimension (max(M,N))   

    INFO    (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   

    ===================================================================== 
  


       Test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static complex c_b1 = {0.f,0.f};
    static complex c_b2 = {1.f,0.f};
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, 
	    q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
    complex q__1, q__2, q__3;
    /* Builtin functions */
    void r_cnjg(complex *, complex *);
    double c_abs(complex *);
    /* Local variables */
    static integer inca;
    static real abst;
    extern /* Subroutine */ int crot_(integer *, complex *, integer *, 
	    complex *, integer *, real *, complex *);
    static integer i, j, l;
    static complex t;
    extern /* Subroutine */ int cscal_(integer *, complex *, complex *, 
	    integer *);
    extern logical lsame_(char *, char *);
    static logical wantb, wantc;
    static integer minmn;
    static logical wantq;
    static integer j1, j2, kb;
    static complex ra;
    static real rc;
    static integer kk;
    static complex rb;
    static integer ml, nr, mu;
    static complex rs;
    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
	    *, complex *, complex *, integer *), clartg_(complex *, 
	    complex *, real *, complex *, complex *), xerbla_(char *, integer 
	    *), clargv_(integer *, complex *, integer *, complex *, 
	    integer *, real *, integer *), clartv_(integer *, complex *, 
	    integer *, complex *, integer *, real *, complex *, integer *);
    static integer kb1, ml0;
    static logical wantpt;
    static integer mu0, klm, kun, nrt, klu1;



#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define PT(I,J) pt[(I)-1 + ((J)-1)* ( *ldpt)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]

    wantb = lsame_(vect, "B");
    wantq = lsame_(vect, "Q") || wantb;
    wantpt = lsame_(vect, "P") || wantb;
    wantc = *ncc > 0;
    klu1 = *kl + *ku + 1;
    *info = 0;
    if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
	*info = -1;
    } else if (*m < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*ncc < 0) {
	*info = -4;
    } else if (*kl < 0) {
	*info = -5;
    } else if (*ku < 0) {
	*info = -6;
    } else if (*ldab < klu1) {
	*info = -8;
    } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
	*info = -12;
    } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
	*info = -14;
    } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
	*info = -16;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CGBBRD", &i__1);
	return 0;
    }

/*     Initialize Q and P' to the unit matrix, if needed */

    if (wantq) {
	claset_("Full", m, m, &c_b1, &c_b2, &Q(1,1), ldq);
    }
    if (wantpt) {
	claset_("Full", n, n, &c_b1, &c_b2, &PT(1,1), ldpt);
    }

/*     Quick return if possible. */

    if (*m == 0 || *n == 0) {
	return 0;
    }

    minmn = min(*m,*n);

    if (*kl + *ku > 1) {

/*        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
   
          first to lower bidiagonal form and then transform to upper 
  
          bidiagonal */

	if (*ku > 0) {
	    ml0 = 1;
	    mu0 = 2;
	} else {
	    ml0 = 2;
	    mu0 = 1;
	}

/*        Wherever possible, plane rotations are generated and applied
 in   
          vector operations of length NR over the index set J1:J2:KLU1
.   

          The complex sines of the plane rotations are stored in WORK,
   
          and the real cosines in RWORK.   

   Computing MIN */
	i__1 = *m - 1;
	klm = min(i__1,*kl);
/* Computing MIN */
	i__1 = *n - 1;
	kun = min(i__1,*ku);
	kb = klm + kun;
	kb1 = kb + 1;
	inca = kb1 * *ldab;
	nr = 0;
	j1 = klm + 2;
	j2 = 1 - kun;

	i__1 = minmn;
	for (i = 1; i <= minmn; ++i) {

/*           Reduce i-th column and i-th row of matrix to bidiagon
al form */

	    ml = klm + 1;
	    mu = kun + 1;
	    i__2 = kb;
	    for (kk = 1; kk <= kb; ++kk) {
		j1 += kb;
		j2 += kb;

/*              generate plane rotations to annihilate nonzero
 elements   
                which have been created below the band */

		if (nr > 0) {
		    clargv_(&nr, &AB(klu1,j1-klm-1), &inca, 
			    &WORK(j1), &kb1, &RWORK(j1), &kb1);
		}

/*              apply plane rotations from the left */

		i__3 = kb;
		for (l = 1; l <= kb; ++l) {
		    if (j2 - klm + l - 1 > *n) {
			nrt = nr - 1;
		    } else {
			nrt = nr;
		    }
		    if (nrt > 0) {
			clartv_(&nrt, &AB(klu1-l,j1-klm+l-1), &inca, &AB(klu1-l+1,j1-klm+l-1), &inca, &RWORK(j1), &WORK(
				j1), &kb1);
		    }
/* L10: */
		}

		if (ml > ml0) {
		    if (ml <= *m - i + 1) {

/*                    generate plane rotation to annih
ilate a(i+ml-1,i)   
                      within the band, and apply rotat
ion from the left */

			clartg_(&AB(*ku+ml-1,i), &AB(*ku+ml,i), &RWORK(i + ml - 1), &WORK(i + 
				ml - 1), &ra);
			i__3 = *ku + ml - 1 + i * ab_dim1;
			AB(*ku+ml-1,i).r = ra.r, AB(*ku+ml-1,i).i = ra.i;
			if (i < *n) {
/* Computing MIN */
			    i__4 = *ku + ml - 2, i__5 = *n - i;
			    i__3 = min(i__4,i__5);
			    i__6 = *ldab - 1;
			    i__7 = *ldab - 1;
			    crot_(&i__3, &AB(*ku+ml-2,i+1)
				    , &i__6, &AB(*ku+ml-1,i+1), &i__7, &RWORK(i + ml - 1), &
				    WORK(i + ml - 1));
			}
		    }
		    ++nr;
		    j1 -= kb1;
		}

		if (wantq) {

/*                 accumulate product of plane rotations i
n Q */

		    i__3 = j2;
		    i__4 = kb1;
		    for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) 
			    {
			r_cnjg(&q__1, &WORK(j));
			crot_(m, &Q(1,j-1), &c__1, &Q(1,j), &c__1, &RWORK(j), &q__1);
/* L20: */
		    }
		}

		if (wantc) {

/*                 apply plane rotations to C */

		    i__4 = j2;
		    i__3 = kb1;
		    for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) 
			    {
			crot_(ncc, &C(j-1,1), ldc, &C(j,1), 
				ldc, &RWORK(j), &WORK(j));
/* L30: */
		    }
		}

		if (j2 + kun > *n) {

/*                 adjust J2 to keep within the bounds of 
the matrix */

		    --nr;
		    j2 -= kb1;
		}

		i__3 = j2;
		i__4 = kb1;
		for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {

/*                 create nonzero element a(j-1,j+ku) abov
e the band   
                   and store it in WORK(n+1:2*n) */

		    i__5 = j + kun;
		    i__6 = j;
		    i__7 = (j + kun) * ab_dim1 + 1;
		    q__1.r = WORK(j).r * AB(1,j+kun).r - WORK(j).i * AB(1,j+kun).i, q__1.i = WORK(j).r * AB(1,j+kun).i + 
			    WORK(j).i * AB(1,j+kun).r;
		    WORK(j+kun).r = q__1.r, WORK(j+kun).i = q__1.i;
		    i__5 = (j + kun) * ab_dim1 + 1;
		    i__6 = j;
		    i__7 = (j + kun) * ab_dim1 + 1;
		    q__1.r = RWORK(j) * AB(1,j+kun).r, q__1.i = RWORK(j) * 
			    AB(1,j+kun).i;
		    AB(1,j+kun).r = q__1.r, AB(1,j+kun).i = q__1.i;
/* L40: */
		}

/*              generate plane rotations to annihilate nonzero
 elements   
                which have been generated above the band */

		if (nr > 0) {
		    clargv_(&nr, &AB(1,j1+kun-1), &inca, &
			    WORK(j1 + kun), &kb1, &RWORK(j1 + kun), &kb1);
		}

/*              apply plane rotations from the right */

		i__4 = kb;
		for (l = 1; l <= kb; ++l) {
		    if (j2 + l - 1 > *m) {
			nrt = nr - 1;
		    } else {
			nrt = nr;
		    }
		    if (nrt > 0) {
			clartv_(&nrt, &AB(l+1,j1+kun-1), &
				inca, &AB(l,j1+kun), &inca, &
				RWORK(j1 + kun), &WORK(j1 + kun), &kb1);
		    }
/* L50: */
		}

		if (ml == ml0 && mu > mu0) {
		    if (mu <= *n - i + 1) {

/*                    generate plane rotation to annih
ilate a(i,i+mu-1)   
                      within the band, and apply rotat
ion from the right */

			clartg_(&AB(*ku-mu+3,i+mu-2), &
				AB(*ku-mu+2,i+mu-1), &
				RWORK(i + mu - 1), &WORK(i + mu - 1), &ra);
			i__4 = *ku - mu + 3 + (i + mu - 2) * ab_dim1;
			AB(*ku-mu+3,i+mu-2).r = ra.r, AB(*ku-mu+3,i+mu-2).i = ra.i;
/* Computing MIN */
			i__3 = *kl + mu - 2, i__5 = *m - i;
			i__4 = min(i__3,i__5);
			crot_(&i__4, &AB(*ku-mu+4,i+mu-2), &c__1, &AB(*ku-mu+3,i+mu-1), &c__1, &RWORK(i + mu - 1), &
				WORK(i + mu - 1));
		    }
		    ++nr;
		    j1 -= kb1;
		}

		if (wantpt) {

/*                 accumulate product of plane rotations i
n P' */

		    i__4 = j2;
		    i__3 = kb1;
		    for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) 
			    {
			r_cnjg(&q__1, &WORK(j + kun));
			crot_(n, &PT(j+kun-1,1), ldpt, &PT(j+kun,1), ldpt, &RWORK(j + kun), &q__1);
/* L60: */
		    }
		}

		if (j2 + kb > *m) {

/*                 adjust J2 to keep within the bounds of 
the matrix */

		    --nr;
		    j2 -= kb1;
		}

		i__3 = j2;
		i__4 = kb1;
		for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {

/*                 create nonzero element a(j+kl+ku,j+ku-1
) below the   
                   band and store it in WORK(1:n) */

		    i__5 = j + kb;
		    i__6 = j + kun;
		    i__7 = klu1 + (j + kun) * ab_dim1;
		    q__1.r = WORK(j+kun).r * AB(klu1,j+kun).r - WORK(j+kun).i * AB(klu1,j+kun).i, q__1.i = WORK(j+kun).r * AB(klu1,j+kun).i + 
			    WORK(j+kun).i * AB(klu1,j+kun).r;
		    WORK(j+kb).r = q__1.r, WORK(j+kb).i = q__1.i;
		    i__5 = klu1 + (j + kun) * ab_dim1;
		    i__6 = j + kun;
		    i__7 = klu1 + (j + kun) * ab_dim1;
		    q__1.r = RWORK(j+kun) * AB(klu1,j+kun).r, q__1.i = RWORK(j+kun) * 
			    AB(klu1,j+kun).i;
		    AB(klu1,j+kun).r = q__1.r, AB(klu1,j+kun).i = q__1.i;
/* L70: */
		}

		if (ml > ml0) {
		    --ml;
		} else {
		    --mu;
		}
/* L80: */
	    }
/* L90: */
	}
    }

    if (*ku == 0 && *kl > 0) {

/*        A has been reduced to complex lower bidiagonal form   

          Transform lower bidiagonal form to upper bidiagonal by apply
ing   
          plane rotations from the left, overwriting superdiagonal   
          elements on subdiagonal elements   

   Computing MIN */
	i__2 = *m - 1;
	i__1 = min(i__2,*n);
	for (i = 1; i <= min(*m-1,*n); ++i) {
	    clartg_(&AB(1,i), &AB(2,i), &rc, &rs, &ra)
		    ;
	    i__2 = i * ab_dim1 + 1;
	    AB(1,i).r = ra.r, AB(1,i).i = ra.i;
	    if (i < *n) {
		i__2 = i * ab_dim1 + 2;
		i__4 = (i + 1) * ab_dim1 + 1;
		q__1.r = rs.r * AB(1,i+1).r - rs.i * AB(1,i+1).i, q__1.i = rs.r 
			* AB(1,i+1).i + rs.i * AB(1,i+1).r;
		AB(2,i).r = q__1.r, AB(2,i).i = q__1.i;
		i__2 = (i + 1) * ab_dim1 + 1;
		i__4 = (i + 1) * ab_dim1 + 1;
		q__1.r = rc * AB(1,i+1).r, q__1.i = rc * AB(1,i+1).i;
		AB(1,i+1).r = q__1.r, AB(1,i+1).i = q__1.i;
	    }
	    if (wantq) {
		r_cnjg(&q__1, &rs);
		crot_(m, &Q(1,i), &c__1, &Q(1,i+1), 
			&c__1, &rc, &q__1);
	    }
	    if (wantc) {
		crot_(ncc, &C(i,1), ldc, &C(i+1,1), ldc, &rc, 
			&rs);
	    }
/* L100: */
	}
    } else {

/*        A has been reduced to complex upper bidiagonal form or is   
          diagonal */

	if (*ku > 0 && *m < *n) {

/*           Annihilate a(m,m+1) by applying plane rotations from 
the   
             right */

	    i__1 = *ku + (*m + 1) * ab_dim1;
	    rb.r = AB(*ku,*m+1).r, rb.i = AB(*ku,*m+1).i;
	    for (i = *m; i >= 1; --i) {
		clartg_(&AB(*ku+1,i), &rb, &rc, &rs, &ra);
		i__1 = *ku + 1 + i * ab_dim1;
		AB(*ku+1,i).r = ra.r, AB(*ku+1,i).i = ra.i;
		if (i > 1) {
		    r_cnjg(&q__3, &rs);
		    q__2.r = -(doublereal)q__3.r, q__2.i = -(doublereal)
			    q__3.i;
		    i__1 = *ku + i * ab_dim1;
		    q__1.r = q__2.r * AB(*ku,i).r - q__2.i * AB(*ku,i).i, 
			    q__1.i = q__2.r * AB(*ku,i).i + q__2.i * AB(*ku,i)
			    .r;
		    rb.r = q__1.r, rb.i = q__1.i;
		    i__1 = *ku + i * ab_dim1;
		    i__2 = *ku + i * ab_dim1;
		    q__1.r = rc * AB(*ku,i).r, q__1.i = rc * AB(*ku,i).i;
		    AB(*ku,i).r = q__1.r, AB(*ku,i).i = q__1.i;
		}
		if (wantpt) {
		    r_cnjg(&q__1, &rs);
		    crot_(n, &PT(i,1), ldpt, &PT(*m+1,1), 
			    ldpt, &rc, &q__1);
		}
/* L110: */
	    }
	}
    }

/*     Make diagonal and superdiagonal elements real, storing them in D   
       and E */

    i__1 = *ku + 1 + ab_dim1;
    t.r = AB(*ku+1,1).r, t.i = AB(*ku+1,1).i;
    i__1 = minmn;
    for (i = 1; i <= minmn; ++i) {
	abst = c_abs(&t);
	D(i) = abst;
	if (abst != 0.f) {
	    q__1.r = t.r / abst, q__1.i = t.i / abst;
	    t.r = q__1.r, t.i = q__1.i;
	} else {
	    t.r = 1.f, t.i = 0.f;
	}
	if (wantq) {
	    cscal_(m, &t, &Q(1,i), &c__1);
	}
	if (wantc) {
	    r_cnjg(&q__1, &t);
	    cscal_(ncc, &q__1, &C(i,1), ldc);
	}
	if (i < minmn) {
	    if (*ku == 0 && *kl == 0) {
		E(i) = 0.f;
		i__2 = (i + 1) * ab_dim1 + 1;
		t.r = AB(1,i+1).r, t.i = AB(1,i+1).i;
	    } else {
		if (*ku == 0) {
		    i__2 = i * ab_dim1 + 2;
		    r_cnjg(&q__2, &t);
		    q__1.r = AB(2,i).r * q__2.r - AB(2,i).i * q__2.i, 
			    q__1.i = AB(2,i).r * q__2.i + AB(2,i).i * 
			    q__2.r;
		    t.r = q__1.r, t.i = q__1.i;
		} else {
		    i__2 = *ku + (i + 1) * ab_dim1;
		    r_cnjg(&q__2, &t);
		    q__1.r = AB(*ku,i+1).r * q__2.r - AB(*ku,i+1).i * q__2.i, 
			    q__1.i = AB(*ku,i+1).r * q__2.i + AB(*ku,i+1).i * 
			    q__2.r;
		    t.r = q__1.r, t.i = q__1.i;
		}
		abst = c_abs(&t);
		E(i) = abst;
		if (abst != 0.f) {
		    q__1.r = t.r / abst, q__1.i = t.i / abst;
		    t.r = q__1.r, t.i = q__1.i;
		} else {
		    t.r = 1.f, t.i = 0.f;
		}
		if (wantpt) {
		    cscal_(n, &t, &PT(i+1,1), ldpt);
		}
		i__2 = *ku + 1 + (i + 1) * ab_dim1;
		r_cnjg(&q__2, &t);
		q__1.r = AB(*ku+1,i+1).r * q__2.r - AB(*ku+1,i+1).i * q__2.i, q__1.i = 
			AB(*ku+1,i+1).r * q__2.i + AB(*ku+1,i+1).i * q__2.r;
		t.r = q__1.r, t.i = q__1.i;
	    }
	}
/* L120: */
    }
    return 0;

/*     End of CGBBRD */

} /* cgbbrd_ */
Esempio n. 24
0
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a, 
	integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, 
	doublereal *rwork, integer *info)
{
/*  -- LAPACK auxiliary routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    ZGEQPF computes a QR factorization with column pivoting of a   
    complex M-by-N matrix A: A*P = 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 upper triangle of the array contains the   
            min(M,N)-by-N upper triangular matrix R; the elements   
            below the diagonal, together with the array TAU,   
            represent the orthogonal matrix Q as a product of   
            min(m,n) elementary reflectors.   

    LDA     (input) INTEGER   
            The leading dimension of the array A. LDA >= max(1,M).   

    JPVT    (input/output) INTEGER array, dimension (N)   
            On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted 
  
            to the front of A*P (a leading column); if JPVT(i) = 0,   
            the i-th column of A is a free column.   
            On exit, if JPVT(i) = k, then the i-th column of A*P   
            was the k-th column of A.   

    TAU     (output) COMPLEX*16 array, dimension (min(M,N))   
            The scalar factors of the elementary reflectors.   

    WORK    (workspace) COMPLEX*16 array, dimension (N)   

    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   

    Further Details   
    ===============   

    The matrix Q is represented as a product of elementary reflectors   

       Q = H(1) H(2) . . . H(n)   

    Each H(i) has the form   

       H = 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). 
  

    The matrix P is represented in jpvt as follows: If   
       jpvt(j) = i   
    then the jth column of P is the ith canonical unit vector.   

    ===================================================================== 
  


       Test the input arguments   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1;
    doublecomplex z__1;
    /* Builtin functions */
    void d_cnjg(doublecomplex *, doublecomplex *);
    double z_abs(doublecomplex *), sqrt(doublereal);
    /* Local variables */
    static doublereal temp, temp2;
    static integer i, j, itemp;
    extern /* Subroutine */ int zlarf_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, doublecomplex *), zswap_(integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     doublecomplex *, integer *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
    static integer ma, mn;
    extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    extern integer idamax_(integer *, doublereal *, integer *);
    extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *);
    static doublecomplex aii;
    static integer pvt;



#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

    *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_("ZGEQPF", &i__1);
	return 0;
    }

    mn = min(*m,*n);

/*     Move initial columns up front */

    itemp = 1;
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	if (JPVT(i) != 0) {
	    if (i != itemp) {
		zswap_(m, &A(1,i), &c__1, &A(1,itemp), &
			c__1);
		JPVT(i) = JPVT(itemp);
		JPVT(itemp) = i;
	    } else {
		JPVT(i) = i;
	    }
	    ++itemp;
	} else {
	    JPVT(i) = i;
	}
/* L10: */
    }
    --itemp;

/*     Compute the QR factorization and update remaining columns */

    if (itemp > 0) {
	ma = min(itemp,*m);
	zgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
	if (ma < *n) {
	    i__1 = *n - ma;
	    zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &A(1,1)
		    , lda, &TAU(1), &A(1,ma+1), lda, &WORK(1), 
		    info);
	}
    }

    if (itemp < mn) {

/*        Initialize partial column norms. The first n elements of   
          work store the exact column norms. */

	i__1 = *n;
	for (i = itemp + 1; i <= *n; ++i) {
	    i__2 = *m - itemp;
	    RWORK(i) = dznrm2_(&i__2, &A(itemp+1,i), &c__1);
	    RWORK(*n + i) = RWORK(i);
/* L20: */
	}

/*        Compute factorization */

	i__1 = mn;
	for (i = itemp + 1; i <= mn; ++i) {

/*           Determine ith pivot column and swap if necessary */

	    i__2 = *n - i + 1;
	    pvt = i - 1 + idamax_(&i__2, &RWORK(i), &c__1);

	    if (pvt != i) {
		zswap_(m, &A(1,pvt), &c__1, &A(1,i), &
			c__1);
		itemp = JPVT(pvt);
		JPVT(pvt) = JPVT(i);
		JPVT(i) = itemp;
		RWORK(pvt) = RWORK(i);
		RWORK(*n + pvt) = RWORK(*n + i);
	    }

/*           Generate elementary reflector H(i) */

	    i__2 = i + i * a_dim1;
	    aii.r = A(i,i).r, aii.i = A(i,i).i;
	    i__2 = *m - i + 1;
/* Computing MIN */
	    i__3 = i + 1;
	    zlarfg_(&i__2, &aii, &A(min(i+1,*m),i), &c__1, &TAU(i)
		    );
	    i__2 = i + i * a_dim1;
	    A(i,i).r = aii.r, A(i,i).i = aii.i;

	    if (i < *n) {

/*              Apply H(i) to A(i:m,i+1:n) from the left */

		i__2 = i + i * a_dim1;
		aii.r = A(i,i).r, aii.i = A(i,i).i;
		i__2 = i + i * a_dim1;
		A(i,i).r = 1., A(i,i).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), &c__1, &z__1,
			 &A(i,i+1), lda, &WORK(1));
		i__2 = i + i * a_dim1;
		A(i,i).r = aii.r, A(i,i).i = aii.i;
	    }

/*           Update partial column norms */

	    i__2 = *n;
	    for (j = i + 1; j <= *n; ++j) {
		if (RWORK(j) != 0.) {
/* Computing 2nd power */
		    d__1 = z_abs(&A(i,j)) / RWORK(j);
		    temp = 1. - d__1 * d__1;
		    temp = max(temp,0.);
/* Computing 2nd power */
		    d__1 = RWORK(j) / RWORK(*n + j);
		    temp2 = temp * .05 * (d__1 * d__1) + 1.;
		    if (temp2 == 1.) {
			if (*m - i > 0) {
			    i__3 = *m - i;
			    RWORK(j) = dznrm2_(&i__3, &A(i+1,j), 
				    &c__1);
			    RWORK(*n + j) = RWORK(j);
			} else {
			    RWORK(j) = 0.;
			    RWORK(*n + j) = 0.;
			}
		    } else {
			RWORK(j) *= sqrt(temp);
		    }
		}
/* L30: */
	    }

/* L40: */
	}
    }
    return 0;

/*     End of ZGEQPF */

} /* zgeqpf_ */
Esempio n. 25
0
/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab,
	 integer *ldab, real *anorm, real *rcond, complex *work, real *rwork, 
	integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    CPBCON estimates the reciprocal of the condition number (in the   
    1-norm) of a complex Hermitian positive definite band matrix using   
    the Cholesky factorization A = U**H*U or A = L*L**H computed by   
    CPBTRF.   

    An estimate is obtained for norm(inv(A)), and the reciprocal of the   
    condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangular factor stored in AB;   
            = 'L':  Lower triangular factor stored in AB.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    KD      (input) INTEGER   
            The number of superdiagonals of the matrix A if UPLO = 'U',   
            or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.   

    AB      (input) COMPLEX array, dimension (LDAB,N)   
            The triangular factor U or L from the Cholesky factorization 
  
            A = U**H*U or A = L*L**H of the band matrix A, stored in the 
  
            first KD+1 rows of the array.  The j-th column of U or L is   
            stored in the j-th column of the array AB as follows:   
            if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; 
  
            if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd). 
  

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KD+1.   

    ANORM   (input) REAL   
            The 1-norm (or infinity-norm) of the Hermitian band matrix A. 
  

    RCOND   (output) REAL   
            The reciprocal of the condition number of the matrix A,   
            computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an   
            estimate of the 1-norm of inv(A) computed in this routine.   

    WORK    (workspace) COMPLEX array, dimension (2*N)   

    RWORK   (workspace) REAL array, dimension (N)   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, i__1;
    real r__1, r__2;
    /* Builtin functions */
    double r_imag(complex *);
    /* Local variables */
    static integer kase;
    static real scale;
    extern logical lsame_(char *, char *);
    static logical upper;
    extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real 
	    *, integer *);
    static integer ix;
    extern integer icamax_(integer *, complex *, integer *);
    static real scalel;
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, 
	    integer *, integer *, complex *, integer *, complex *, real *, 
	    real *, integer *);
    static real scaleu;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static real ainvnm;
    extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer 
	    *);
    static char normin[1];
    static real smlnum;



#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]

    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kd < 0) {
	*info = -3;
    } else if (*ldab < *kd + 1) {
	*info = -5;
    } else if (*anorm < 0.f) {
	*info = -6;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CPBCON", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *rcond = 0.f;
    if (*n == 0) {
	*rcond = 1.f;
	return 0;
    } else if (*anorm == 0.f) {
	return 0;
    }

    smlnum = slamch_("Safe minimum");

/*     Estimate the 1-norm of the inverse. */

    kase = 0;
    *(unsigned char *)normin = 'N';
L10:
    clacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
    if (kase != 0) {
	if (upper) {

/*           Multiply by inv(U'). */

	    clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd,
		     &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
	    *(unsigned char *)normin = 'Y';

/*           Multiply by inv(U). */

	    clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
	} else {

/*           Multiply by inv(L). */

	    clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
	    *(unsigned char *)normin = 'Y';

/*           Multiply by inv(L'). */

	    clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd,
		     &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
	}

/*        Multiply by 1/SCALE if doing so will not cause overflow. */

	scale = scalel * scaleu;
	if (scale != 1.f) {
	    ix = icamax_(n, &WORK(1), &c__1);
	    i__1 = ix;
	    if (scale < ((r__1 = WORK(ix).r, dabs(r__1)) + (r__2 = r_imag(&
		    WORK(ix)), dabs(r__2))) * smlnum || scale == 0.f) {
		goto L20;
	    }
	    csrscl_(n, &scale, &WORK(1), &c__1);
	}
	goto L10;
    }

/*     Compute the estimate of the reciprocal condition number. */

    if (ainvnm != 0.f) {
	*rcond = 1.f / ainvnm / *anorm;
    }

L20:

    return 0;

/*     End of CPBCON */

} /* cpbcon_ */
Esempio n. 26
0
/* Subroutine */ int zgelss_(integer *m, integer *n, integer *nrhs, 
	doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 
	doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work, 
	integer *lwork, doublereal *rwork, integer *info)
{
/*  -- 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   


    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.   

    ===================================================================== 
  


       Test the input arguments   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static doublecomplex c_b1 = {0.,0.};
    static doublecomplex c_b2 = {1.,0.};
    static integer c__6 = 6;
    static integer c_n1 = -1;
    static integer c__1 = 1;
    static integer c__0 = 0;
    static doublereal c_b78 = 0.;
    
    /* 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_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    static integer maxmn, itaup, itauq, mnthr;
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *);
    static integer iwork;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    static integer bl, ie, il;
    extern doublereal dlamch_(char *);
    static integer mm;
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, integer *), dlaset_(char *, integer *, integer 
	    *, doublereal *, doublereal *, doublereal *, integer *), 
	    xerbla_(char *, integer *), zgebrd_(integer *, integer *, 
	    doublecomplex *, integer *, doublereal *, doublereal *, 
	    doublecomplex *, doublecomplex *, doublecomplex *, integer *, 
	    integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    static doublereal bignum;
    extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
	     integer *, doublecomplex *, doublecomplex *, integer *, integer *
	    ), zlascl_(char *, integer *, integer *, doublereal *, doublereal 
	    *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
	     doublecomplex *, doublecomplex *, integer *, integer *), zdrscl_(
	    integer *, doublereal *, doublecomplex *, integer *);
    static integer ldwork;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    zlaset_(char *, integer *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *), zbdsqr_(
	    char *, integer *, integer *, integer *, integer *, doublereal *, 
	    doublereal *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, doublereal *, integer *);
    static integer minwrk, maxwrk;
    extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer 
	    *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *);
    static doublereal smlnum;
    static integer irwork;
    extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     doublecomplex *, integer *, doublecomplex *, integer *, integer *
	    ), zunmlq_(char *, char *, integer *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     doublecomplex *, integer *, doublecomplex *, integer *, integer *
	    ), zunmqr_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static doublereal eps, thr;



#define VDUM(I) vdum[(I)]
#define S(I) s[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]

    *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);
	return 0;
    }

/*     Quick return if possible */

    if (*m == 0 || *n == 0) {
	*rank = 0;
	return 0;
    }

/*     Get machine parameters */

    eps = dlamch_("P");
    sfmin = dlamch_("S");
    smlnum = sfmin / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

/*     Scale A if max element outside range [SMLNUM,BIGNUM] */

    anrm = zlange_("M", m, n, &A(1,1), lda, &RWORK(1));
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &A(1,1), lda, 
		info);
	iascl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &A(1,1), lda, 
		info);
	iascl = 2;
    } else if (anrm == 0.) {

/*        VISMatrix all zero. Return zero solution. */

	i__1 = max(*m,*n);
	zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &B(1,1), ldb);
	dlaset_("F", &minmn, &c__1, &c_b78, &c_b78, &S(1), &minmn);
	*rank = 0;
	goto L70;
    }

/*     Scale B if max element outside range [SMLNUM,BIGNUM] */

    bnrm = zlange_("M", m, nrhs, &B(1,1), ldb, &RWORK(1));
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &B(1,1), ldb,
		 info);
	ibscl = 1;
    } else if (bnrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &B(1,1), ldb,
		 info);
	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(1,1), 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(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);

/*           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(2,1), lda);
	    }
	}

	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(1,1), 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(1,1), lda, &WORK(itauq), 
		&B(1,1), ldb, &WORK(iwork), &i__1, info);

/*        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(1,1), lda, &WORK(itaup), &WORK(iwork), &
		i__1, info);
	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(1,1), lda, 
		vdum, &c__1, &B(1,1), ldb, &RWORK(irwork), info);
	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 <= *n; ++i) {
	    if (S(i) > thr) {
		zdrscl_(nrhs, &S(i), &B(i,1), ldb);
		++(*rank);
	    } else {
		zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1), ldb);
	    }
/* 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(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), ldb);
	    zlacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
	} else if (*nrhs > 1) {
	    chunk = *lwork / *n;
	    i__1 = *nrhs;
	    i__2 = chunk;
	    for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
		i__3 = *nrhs - i + 1;
		bl = min(i__3,chunk);
		zgemm_("C", "N", n, &bl, n, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), n);
		zlacpy_("G", n, &bl, &WORK(1), n, &B(1,1), ldb);
/* L20: */
	    }
	} else {
	    zgemv_("C", n, n, &c_b2, &A(1,1), lda, &B(1,1), &c__1, &
		    c_b1, &WORK(1), &c__1);
	    zcopy_(n, &WORK(1), &c__1, &B(1,1), &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(1,1), lda, &WORK(itau), &WORK(iwork), &i__2,
		     info);
	    il = iwork;

/*        Copy L to WORK(IL), zeroing out above it */

	    zlacpy_("L", m, m, &A(1,1), lda, &WORK(il), &ldwork);
	    i__2 = *m - 1;
	    i__1 = *m - 1;
	    zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &WORK(il + ldwork), &
		    ldwork);
	    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(1,1), ldb, &WORK(iwork), &i__2, info);

/*        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);
	    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(1,1), lda, &B(1,1), ldb, &RWORK(
		    irwork), info);
	    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 <= *m; ++i) {
		if (S(i) > thr) {
		    zdrscl_(nrhs, &S(i), &B(i,1), ldb);
		    ++(*rank);
		} else {
		    zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1), 
			    ldb);
		}
/* 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(1,1), ldb, &c_b1, &WORK(iwork), ldb);
		zlacpy_("G", m, nrhs, &WORK(iwork), ldb, &B(1,1), ldb);
	    } else if (*nrhs > 1) {
		chunk = (*lwork - iwork + 1) / *m;
		i__2 = *nrhs;
		i__1 = chunk;
		for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
		    i__3 = *nrhs - i + 1;
		    bl = min(i__3,chunk);
		    zgemm_("C", "N", m, &bl, m, &c_b2, &WORK(il), &ldwork, &B(1,i), ldb, &c_b1, &WORK(iwork), n);
		    zlacpy_("G", m, &bl, &WORK(iwork), n, &B(1,1), ldb);
/* L40: */
		}
	    } else {
		zgemv_("C", m, m, &c_b2, &WORK(il), &ldwork, &B(1,1), &
			c__1, &c_b1, &WORK(iwork), &c__1);
		zcopy_(m, &WORK(iwork), &c__1, &B(1,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,1), ldb);
	    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(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);

	} 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(1,1), 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(1,1), lda, &WORK(itauq)
		    , &B(1,1), ldb, &WORK(iwork), &i__1, info);

/*        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(1,1), lda, &WORK(itaup), &WORK(
		    iwork), &i__1, info);
	    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(1,1), 
		    lda, vdum, &c__1, &B(1,1), ldb, &RWORK(irwork), info);
	    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 <= *m; ++i) {
		if (S(i) > thr) {
		    zdrscl_(nrhs, &S(i), &B(i,1), ldb);
		    ++(*rank);
		} else {
		    zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1), 
			    ldb);
		}
/* 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(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), ldb);
		zlacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
	    } else if (*nrhs > 1) {
		chunk = *lwork / *n;
		i__1 = *nrhs;
		i__2 = chunk;
		for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
		    i__3 = *nrhs - i + 1;
		    bl = min(i__3,chunk);
		    zgemm_("C", "N", n, &bl, m, &c_b2, &A(1,1), lda, &B(1,i), ldb, &c_b1, &WORK(1), n);
		    zlacpy_("F", n, &bl, &WORK(1), n, &B(1,i), ldb);
/* L60: */
		}
	    } else {
		zgemv_("C", m, n, &c_b2, &A(1,1), lda, &B(1,1), &
			c__1, &c_b1, &WORK(1), &c__1);
		zcopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
	    }
	}
    }

/*     Undo scaling */

    if (iascl == 1) {
	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &B(1,1), ldb,
		 info);
	dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &S(1), &
		minmn, info);
    } else if (iascl == 2) {
	zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &B(1,1), ldb,
		 info);
	dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &S(1), &
		minmn, info);
    }
    if (ibscl == 1) {
	zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &B(1,1), ldb,
		 info);
    } else if (ibscl == 2) {
	zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &B(1,1), ldb,
		 info);
    }
L70:
    WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
    return 0;

/*     End of ZGELSS */

} /* zgelss_ */
Esempio n. 27
0
/* Subroutine */ int zgtsvx_(char *fact, char *trans, integer *n, integer *
                             nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du,
                             doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
                             doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
                             doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
                             doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
                             info)
{
    /*  -- LAPACK routine (version 2.0) --
           Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
           Courant Institute, Argonne National Lab, and Rice University
           September 30, 1994


        Purpose
        =======

        ZGTSVX uses the LU factorization to compute the solution to a complex

        system of linear equations A * X = B, A**T * X = B, or A**H * X = B,

        where A is a tridiagonal matrix of order N and X and B are N-by-NRHS

        matrices.

        Error bounds on the solution and a condition estimate are also
        provided.

        Description
        ===========

        The following steps are performed:

        1. If FACT = 'N', the LU decomposition is used to factor the matrix A

           as A = L * U, where L is a product of permutation and unit lower
           bidiagonal matrices and U is upper triangular with nonzeros in
           only the main diagonal and first two superdiagonals.

        2. The factored form of A is used to estimate the condition number
           of the matrix A.  If the reciprocal of the condition number is
           less than machine precision, steps 3 and 4 are skipped.

        3. The system of equations is solved for X using the factored form
           of A.

        4. Iterative refinement is applied to improve the computed solution
           matrix and calculate error bounds and backward error estimates
           for it.

        Arguments
        =========

        FACT    (input) CHARACTER*1
                Specifies whether or not the factored form of A has been
                supplied on entry.
                = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored form

                        of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not

                        be modified.
                = 'N':  The matrix will be copied to DLF, DF, and DUF
                        and factored.

        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.

        DL      (input) COMPLEX*16 array, dimension (N-1)
                The (n-1) subdiagonal elements of A.

        D       (input) COMPLEX*16 array, dimension (N)
                The n diagonal elements of A.

        DU      (input) COMPLEX*16 array, dimension (N-1)
                The (n-1) superdiagonal elements of A.

        DLF     (input or output) COMPLEX*16 array, dimension (N-1)
                If FACT = 'F', then DLF is an input argument and on entry
                contains the (n-1) multipliers that define the matrix L from

                the LU factorization of A as computed by ZGTTRF.

                If FACT = 'N', then DLF is an output argument and on exit
                contains the (n-1) multipliers that define the matrix L from

                the LU factorization of A.

        DF      (input or output) COMPLEX*16 array, dimension (N)
                If FACT = 'F', then DF is an input argument and on entry
                contains the n diagonal elements of the upper triangular
                matrix U from the LU factorization of A.

                If FACT = 'N', then DF is an output argument and on exit
                contains the n diagonal elements of the upper triangular
                matrix U from the LU factorization of A.

        DUF     (input or output) COMPLEX*16 array, dimension (N-1)
                If FACT = 'F', then DUF is an input argument and on entry
                contains the (n-1) elements of the first superdiagonal of U.


                If FACT = 'N', then DUF is an output argument and on exit
                contains the (n-1) elements of the first superdiagonal of U.


        DU2     (input or output) COMPLEX*16 array, dimension (N-2)
                If FACT = 'F', then DU2 is an input argument and on entry
                contains the (n-2) elements of the second superdiagonal of
                U.

                If FACT = 'N', then DU2 is an output argument and on exit
                contains the (n-2) elements of the second superdiagonal of
                U.

        IPIV    (input or output) INTEGER array, dimension (N)
                If FACT = 'F', then IPIV is an input argument and on entry
                contains the pivot indices from the LU factorization of A as

                computed by ZGTTRF.

                If FACT = 'N', then IPIV is an output argument and on exit
                contains the pivot indices from the LU factorization of A;
                row i of the matrix was interchanged with row IPIV(i).
                IPIV(i) will always be either i or i+1; IPIV(i) = i indicates

                a row interchange was not required.

        B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
                The N-by-NRHS right hand side matrix B.

        LDB     (input) INTEGER
                The leading dimension of the array B.  LDB >= max(1,N).

        X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
                If INFO = 0, the N-by-NRHS solution matrix X.

        LDX     (input) INTEGER
                The leading dimension of the array X.  LDX >= max(1,N).

        RCOND   (output) DOUBLE PRECISION
                The estimate of the reciprocal condition number of the matrix

                A.  If RCOND is less than the machine precision (in
                particular, if RCOND = 0), the matrix is singular to working

                precision.  This condition is indicated by a return code of
                INFO > 0, and the solution and error bounds are not computed.


        FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
                The estimated forward error bound for each solution vector
                X(j) (the j-th column of the solution matrix X).
                If XTRUE is the true solution corresponding to X(j), FERR(j)

                is an estimated upper bound for the magnitude of the largest

                element in (X(j) - XTRUE) divided by the magnitude of the
                largest element in X(j).  The estimate is as reliable as
                the estimate for RCOND, and is almost always a slight
                overestimate of the true error.

        BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
                The componentwise relative backward error of each solution
                vector X(j) (i.e., the smallest relative change in
                any element of A or B that makes X(j) an exact solution).

        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
                > 0:  if INFO = i, and i is
                      <= N:  U(i,i) is exactly zero.  The factorization
                             has not been completed unless i = N, but the
                             factor U is exactly singular, so the solution
                             and error bounds could not be computed.
                     = N+1:  RCOND is less than machine precision.  The
                             factorization has been completed, but the
                             matrix is singular to working precision, and
                             the solution and error bounds have not been
                             computed.

        =====================================================================




       Parameter adjustments
           Function Body */
    /* Table of constant values */
    static integer c__1 = 1;

    /* System generated locals */
    integer b_dim1, b_offset, x_dim1, x_offset, i__1;
    /* Local variables */
    static char norm[1];
    extern logical lsame_(char *, char *);
    static doublereal anorm;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
                                       doublecomplex *, integer *);
    extern doublereal dlamch_(char *);
    static logical nofact;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern doublereal zlangt_(char *, integer *, doublecomplex *,
                              doublecomplex *, doublecomplex *);
    static logical notran;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, integer *),
                                                      zgtcon_(char *, integer *, doublecomplex *, doublecomplex *,
                                                              doublecomplex *, doublecomplex *, integer *, doublereal *,
                                                              doublereal *, doublecomplex *, integer *), zgtrfs_(char *,
                                                                      integer *, integer *, doublecomplex *, doublecomplex *,
                                                                      doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
                                                                      , doublecomplex *, integer *, doublecomplex *, integer *,
                                                                      doublecomplex *, integer *, doublereal *, doublereal *,
                                                                      doublecomplex *, doublereal *, integer *), zgttrf_(
                                                                              integer *, doublecomplex *, doublecomplex *, doublecomplex *,
                                                                              doublecomplex *, integer *, integer *), zgttrs_(char *, integer *,
                                                                                      integer *, doublecomplex *, doublecomplex *, doublecomplex *,
                                                                                      doublecomplex *, integer *, doublecomplex *, integer *, integer *);



#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define DLF(I) dlf[(I)-1]
#define DF(I) df[(I)-1]
#define DUF(I) duf[(I)-1]
#define DU2(I) du2[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]

    *info = 0;
    nofact = lsame_(fact, "N");
    notran = lsame_(trans, "N");
    if (! nofact && ! lsame_(fact, "F")) {
        *info = -1;
    } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
               "C")) {
        *info = -2;
    } else if (*n < 0) {
        *info = -3;
    } else if (*nrhs < 0) {
        *info = -4;
    } else if (*ldb < max(1,*n)) {
        *info = -14;
    } else if (*ldx < max(1,*n)) {
        *info = -16;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("ZGTSVX", &i__1);
        return 0;
    }

    if (nofact) {

        /*        Compute the LU factorization of A. */

        zcopy_(n, &D(1), &c__1, &DF(1), &c__1);
        if (*n > 1) {
            i__1 = *n - 1;
            zcopy_(&i__1, &DL(1), &c__1, &DLF(1), &c__1);
            i__1 = *n - 1;
            zcopy_(&i__1, &DU(1), &c__1, &DUF(1), &c__1);
        }
        zgttrf_(n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), info);

        /*        Return if INFO is non-zero. */

        if (*info != 0) {
            if (*info > 0) {
                *rcond = 0.;
            }
            return 0;
        }
    }

    /*     Compute the norm of the matrix A. */

    if (notran) {
        *(unsigned char *)norm = '1';
    } else {
        *(unsigned char *)norm = 'I';
    }
    anorm = zlangt_(norm, n, &DL(1), &D(1), &DU(1));

    /*     Compute the reciprocal of the condition number of A. */

    zgtcon_(norm, n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &anorm,
            rcond, &WORK(1), info);

    /*     Return if the matrix is singular to working precision. */

    if (*rcond < dlamch_("Epsilon")) {
        *info = *n + 1;
        return 0;
    }

    /*     Compute the solution vectors X. */

    zlacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
    zgttrs_(trans, n, nrhs, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &X(1,1), ldx, info);

    /*     Use iterative refinement to improve the computed solutions and
           compute error bounds and backward error estimates for them. */

    zgtrfs_(trans, n, nrhs, &DL(1), &D(1), &DU(1), &DLF(1), &DF(1), &DUF(1), &
            DU2(1), &IPIV(1), &B(1,1), ldb, &X(1,1), ldx, &FERR(1),
            &BERR(1), &WORK(1), &RWORK(1), info);

    return 0;

    /*     End of ZGTSVX */

} /* zgtsvx_ */
Esempio n. 28
0
/* Subroutine */ int cgeesx_(char *jobvs, char *sort, L_fp select, char *
	sense, integer *n, complex *a, integer *lda, integer *sdim, complex *
	w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *
	work, integer *lwork, real *rwork, logical *bwork, integer *info)
{
/*  -- 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   


    Purpose   
    =======   

    CGEESX computes for an N-by-N complex nonsymmetric matrix A, the   
    eigenvalues, the Schur form T, and, optionally, the matrix of Schur   
    vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).   

    Optionally, it also orders the eigenvalues on the diagonal of the   
    Schur form so that selected eigenvalues are at the top left;   
    computes a reciprocal condition number for the average of the   
    selected eigenvalues (RCONDE); and computes a reciprocal condition   
    number for the right invariant subspace corresponding to the   
    selected eigenvalues (RCONDV).  The leading columns of Z form an   
    orthonormal basis for this invariant subspace.   

    For further explanation of the reciprocal condition numbers RCONDE   
    and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where   
    these quantities are called s and sep respectively).   

    A complex matrix is in Schur form if it is upper triangular.   

    Arguments   
    =========   

    JOBVS   (input) CHARACTER*1   
            = 'N': Schur vectors are not computed;   
            = 'V': Schur vectors are computed.   

    SORT    (input) CHARACTER*1   
            Specifies whether or not to order the eigenvalues on the   
            diagonal of the Schur form.   
            = 'N': Eigenvalues are not ordered;   
            = 'S': Eigenvalues are ordered (see SELECT).   

    SELECT  (input) LOGICAL FUNCTION of one COMPLEX argument   
            SELECT must be declared EXTERNAL in the calling subroutine.   
            If SORT = 'S', SELECT is used to select eigenvalues to order 
  
            to the top left of the Schur form.   
            If SORT = 'N', SELECT is not referenced.   
            An eigenvalue W(j) is selected if SELECT(W(j)) is true.   

    SENSE   (input) CHARACTER*1   
            Determines which reciprocal condition numbers are computed.   
            = 'N': None are computed;   
            = 'E': Computed for average of selected eigenvalues only;   
            = 'V': Computed for selected right invariant subspace only;   
            = 'B': Computed for both.   
            If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.   

    N       (input) INTEGER   
            The order of the matrix A. N >= 0.   

    A       (input/output) COMPLEX array, dimension (LDA, N)   
            On entry, the N-by-N matrix A.   
            On exit, A is overwritten by its Schur form T.   

    LDA     (input) INTEGER   
            The leading dimension of the array A.  LDA >= max(1,N).   

    SDIM    (output) INTEGER   
            If SORT = 'N', SDIM = 0.   
            If SORT = 'S', SDIM = number of eigenvalues for which   
                           SELECT is true.   

    W       (output) COMPLEX array, dimension (N)   
            W contains the computed eigenvalues, in the same order   
            that they appear on the diagonal of the output Schur form T. 
  

    VS      (output) COMPLEX array, dimension (LDVS,N)   
            If JOBVS = 'V', VS contains the unitary matrix Z of Schur   
            vectors.   
            If JOBVS = 'N', VS is not referenced.   

    LDVS    (input) INTEGER   
            The leading dimension of the array VS.  LDVS >= 1, and if   
            JOBVS = 'V', LDVS >= N.   

    RCONDE  (output) REAL   
            If SENSE = 'E' or 'B', RCONDE contains the reciprocal   
            condition number for the average of the selected eigenvalues. 
  
            Not referenced if SENSE = 'N' or 'V'.   

    RCONDV  (output) REAL   
            If SENSE = 'V' or 'B', RCONDV contains the reciprocal   
            condition number for the selected right invariant subspace.   
            Not referenced if SENSE = 'N' or 'E'.   

    WORK    (workspace/output) COMPLEX array, dimension (LWORK)   
            On exit, if INFO = 0, WORK(1) returns the optimal LWORK.   

    LWORK   (input) INTEGER   
            The dimension of the array WORK.  LWORK >= max(1,2*N).   
            Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), 
  
            where SDIM is the number of selected eigenvalues computed by 
  
            this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2.   
            For good performance, LWORK must generally be larger.   

    RWORK   (workspace) REAL array, dimension (N)   

    BWORK   (workspace) LOGICAL array, dimension (N)   
            Not referenced if SORT = 'N'.   

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -i, the i-th argument had an illegal value.   
            > 0: if INFO = i, and i is   
               <= N: the QR algorithm failed to compute all the   
                     eigenvalues; elements 1:ILO-1 and i+1:N of W   
                     contain those eigenvalues which have converged; if   
                     JOBVS = 'V', VS contains the transformation which   
                     reduces A to its partially converged Schur form.   
               = N+1: the eigenvalues could not be reordered because some 
  
                     eigenvalues were too close to separate (the problem 
  
                     is very ill-conditioned);   
               = N+2: after reordering, roundoff changed values of some   
                     complex eigenvalues so that leading eigenvalues in   
                     the Schur form no longer satisfy SELECT=.TRUE.  This 
  
                     could also be caused by underflow due to scaling.   

    ===================================================================== 
  


       Test the input arguments   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c__0 = 0;
    static integer c__8 = 8;
    static integer c_n1 = -1;
    static integer c__4 = 4;
    
    /* System generated locals */
    integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3, i__4;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static integer ibal, maxb;
    static real anrm;
    static integer ierr, itau, iwrk, i, k, icond, ieval;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
	    complex *, integer *), cgebak_(char *, char *, integer *, integer 
	    *, integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *, 
	    integer *, integer *, real *, integer *), slabad_(real *, 
	    real *);
    static logical scalea;
    extern doublereal clange_(char *, integer *, integer *, complex *, 
	    integer *, real *);
    static real cscale;
    extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *, 
	    complex *, integer *, complex *, complex *, integer *, integer *),
	     clascl_(char *, integer *, integer *, real *, real *, integer *, 
	    integer *, complex *, integer *, integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex 
	    *, integer *, complex *, integer *), xerbla_(char *, 
	    integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static real bignum;
    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
	    real *, integer *, integer *, real *, integer *, integer *), chseqr_(char *, char *, integer *, integer *, integer *, 
	    complex *, integer *, complex *, complex *, integer *, complex *, 
	    integer *, integer *), cunghr_(integer *, integer 
	    *, integer *, complex *, integer *, complex *, complex *, integer 
	    *, integer *);
    static logical wantsb;
    extern /* Subroutine */ int ctrsen_(char *, char *, logical *, integer *, 
	    complex *, integer *, complex *, integer *, complex *, integer *, 
	    real *, real *, complex *, integer *, integer *);
    static logical wantse;
    static integer minwrk, maxwrk;
    static logical wantsn;
    static real smlnum;
    static integer hswork;
    static logical wantst, wantsv, wantvs;
    static integer ihi, ilo;
    static real dum[1], eps;



#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define BWORK(I) bwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define VS(I,J) vs[(I)-1 + ((J)-1)* ( *ldvs)]

    *info = 0;
    wantvs = lsame_(jobvs, "V");
    wantst = lsame_(sort, "S");
    wantsn = lsame_(sense, "N");
    wantse = lsame_(sense, "E");
    wantsv = lsame_(sense, "V");
    wantsb = lsame_(sense, "B");
    if (! wantvs && ! lsame_(jobvs, "N")) {
	*info = -1;
    } else if (! wantst && ! lsame_(sort, "N")) {
	*info = -2;
    } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! 
	    wantsn) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < max(1,*n)) {
	*info = -7;
    } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
	*info = -11;
    }

/*     Compute workspace   
        (Note: Comments in the code beginning "Workspace:" describe the   
         minimal amount of real 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 CHSEQR, as   
         calculated below. HSWORK is computed assuming ILO=1 and IHI=N,   
         the worst case.   
         If SENSE = 'E', 'V' or 'B', then the amount of workspace needed 
  
         depends on SDIM, which is computed by the routine CTRSEN later   
         in the code.) */

    minwrk = 1;
    if (*info == 0 && *lwork >= 1) {
	maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &c__0, 
		6L, 1L);
/* Computing MAX */
	i__1 = 1, i__2 = *n << 1;
	minwrk = max(i__1,i__2);
	if (! wantvs) {
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "CHSEQR", "SN", 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, "CHSEQR", "SN", 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);
	    maxwrk = max(i__1,1);
	} else {
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR", 
		    " ", n, &c__1, n, &c_n1, 6L, 1L);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "CHSEQR", "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, "CHSEQR", "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);
	    maxwrk = max(i__1,1);
	}
	WORK(1).r = (real) maxwrk, WORK(1).i = 0.f;
    }
    if (*lwork < minwrk) {
	*info = -15;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CGEESX", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	*sdim = 0;
	return 0;
    }

/*     Get machine constants */

    eps = slamch_("P");
    smlnum = slamch_("S");
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);
    smlnum = sqrt(smlnum) / eps;
    bignum = 1.f / smlnum;

/*     Scale A if max element outside range [SMLNUM,BIGNUM] */

    anrm = clange_("M", n, n, &A(1,1), lda, dum);
    scalea = FALSE_;
    if (anrm > 0.f && anrm < smlnum) {
	scalea = TRUE_;
	cscale = smlnum;
    } else if (anrm > bignum) {
	scalea = TRUE_;
	cscale = bignum;
    }
    if (scalea) {
	clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &A(1,1), lda, &
		ierr);
    }


/*     Permute the matrix to make it more nearly triangular   
       (CWorkspace: none)   
       (RWorkspace: need N) */

    ibal = 1;
    cgebal_("P", n, &A(1,1), lda, &ilo, &ihi, &RWORK(ibal), &ierr);

/*     Reduce to upper Hessenberg form   
       (CWorkspace: need 2*N, prefer N+N*NB)   
       (RWorkspace: none) */

    itau = 1;
    iwrk = *n + itau;
    i__1 = *lwork - iwrk + 1;
    cgehrd_(n, &ilo, &ihi, &A(1,1), lda, &WORK(itau), &WORK(iwrk), &i__1,
	     &ierr);

    if (wantvs) {

/*        Copy Householder vectors to VS */

	clacpy_("L", n, n, &A(1,1), lda, &VS(1,1), ldvs);

/*        Generate unitary matrix in VS   
          (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)   
          (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	cunghr_(n, &ilo, &ihi, &VS(1,1), ldvs, &WORK(itau), &WORK(iwrk),
		 &i__1, &ierr);
    }

    *sdim = 0;

/*     Perform QR iteration, accumulating Schur vectors in VS if desired 
  
       (CWorkspace: need 1, prefer HSWORK (see comments) )   
       (RWorkspace: none) */

    iwrk = itau;
    i__1 = *lwork - iwrk + 1;
    chseqr_("S", jobvs, n, &ilo, &ihi, &A(1,1), lda, &W(1), &VS(1,1), ldvs, &WORK(iwrk), &i__1, &ieval);
    if (ieval > 0) {
	*info = ieval;
    }

/*     Sort eigenvalues if desired */

    if (wantst && *info == 0) {
	if (scalea) {
	    clascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &W(1), n, &
		    ierr);
	}
	i__1 = *n;
	for (i = 1; i <= *n; ++i) {
	    BWORK(i) = (*select)(&W(i));
/* L10: */
	}

/*        Reorder eigenvalues, transform Schur vectors, and compute   
          reciprocal condition numbers   
          (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM)   
                       otherwise, need none )   
          (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	ctrsen_(sense, jobvs, &BWORK(1), n, &A(1,1), lda, &VS(1,1),
		 ldvs, &W(1), sdim, rconde, rcondv, &WORK(iwrk), &i__1, &
		icond);
	if (! wantsn) {
/* Computing MAX */
	    i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
	    maxwrk = max(i__1,i__2);
	}
	if (icond == -14) {

/*           Not enough complex workspace */

	    *info = -15;
	}
    }

    if (wantvs) {

/*        Undo balancing   
          (CWorkspace: none)   
          (RWorkspace: need N) */

	cgebak_("P", "R", n, &ilo, &ihi, &RWORK(ibal), n, &VS(1,1), 
		ldvs, &ierr);
    }

    if (scalea) {

/*        Undo scaling for the Schur form of A */

	clascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &A(1,1), lda, &
		ierr);
	i__1 = *lda + 1;
	ccopy_(n, &A(1,1), &i__1, &W(1), &c__1);
	if ((wantsv || wantsb) && *info == 0) {
	    dum[0] = *rcondv;
	    slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
		    c__1, &ierr);
	    *rcondv = dum[0];
	}
    }

    WORK(1).r = (real) maxwrk, WORK(1).i = 0.f;
    return 0;

/*     End of CGEESX */

} /* cgeesx_ */
Esempio n. 29
0
/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m, 
	integer *p, integer *n, complex *a, integer *lda, complex *b, integer 
	*ldb, real *tola, real *tolb, integer *k, integer *l, complex *u, 
	integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, 
	integer *iwork, real *rwork, complex *tau, complex *work, integer *
	info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    CGGSVP computes unitary matrices U, V and Q such that   

                     N-K-L  K    L   
     U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;   
                  L ( 0     0   A23 )   
              M-K-L ( 0     0    0  )   

                     N-K-L  K    L   
            =     K ( 0    A12  A13 )  if M-K-L < 0;   
                M-K ( 0     0   A23 )   

                   N-K-L  K    L   
     V'*B*Q =   L ( 0     0   B13 )   
              P-L ( 0     0    0  )   

    where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular   
    upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,   
    otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective   
    numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the   
    conjugate transpose of Z.   

    This decomposition is the preprocessing step for computing the   
    Generalized Singular Value Decomposition (GSVD), see subroutine   
    CGGSVD.   

    Arguments   
    =========   

    JOBU    (input) CHARACTER*1   
            = 'U':  Unitary matrix U is computed;   
            = 'N':  U is not computed.   

    JOBV    (input) CHARACTER*1   
            = 'V':  Unitary matrix V is computed;   
            = 'N':  V is not computed.   

    JOBQ    (input) CHARACTER*1   
            = 'Q':  Unitary matrix Q is computed;   
            = 'N':  Q is not computed.   

    M       (input) INTEGER   
            The number of rows of the matrix A.  M >= 0.   

    P       (input) INTEGER   
            The number of rows of the matrix B.  P >= 0.   

    N       (input) INTEGER   
            The number of columns of the matrices A and B.  N >= 0.   

    A       (input/output) COMPLEX array, dimension (LDA,N)   
            On entry, the M-by-N matrix A.   
            On exit, A contains the triangular (or trapezoidal) matrix   
            described in the Purpose section.   

    LDA     (input) INTEGER   
            The leading dimension of the array A. LDA >= max(1,M).   

    B       (input/output) COMPLEX array, dimension (LDB,N)   
            On entry, the P-by-N matrix B.   
            On exit, B contains the triangular matrix described in   
            the Purpose section.   

    LDB     (input) INTEGER   
            The leading dimension of the array B. LDB >= max(1,P).   

    TOLA    (input) REAL   
    TOLB    (input) REAL   
            TOLA and TOLB are the thresholds to determine the effective   
            numerical rank of matrix B and a subblock of A. Generally,   
            they are set to   
               TOLA = MAX(M,N)*norm(A)*MACHEPS,   
               TOLB = MAX(P,N)*norm(B)*MACHEPS.   
            The size of TOLA and TOLB may affect the size of backward   
            errors of the decomposition.   

    K       (output) INTEGER   
    L       (output) INTEGER   
            On exit, K and L specify the dimension of the subblocks   
            described in Purpose section.   
            K + L = effective numerical rank of (A',B')'.   

    U       (output) COMPLEX array, dimension (LDU,M)   
            If JOBU = 'U', U contains the unitary matrix U.   
            If JOBU = 'N', U is not referenced.   

    LDU     (input) INTEGER   
            The leading dimension of the array U. LDU >= max(1,M) if   
            JOBU = 'U'; LDU >= 1 otherwise.   

    V       (output) COMPLEX array, dimension (LDV,M)   
            If JOBV = 'V', V contains the unitary matrix V.   
            If JOBV = 'N', V is not referenced.   

    LDV     (input) INTEGER   
            The leading dimension of the array V. LDV >= max(1,P) if   
            JOBV = 'V'; LDV >= 1 otherwise.   

    Q       (output) COMPLEX array, dimension (LDQ,N)   
            If JOBQ = 'Q', Q contains the unitary matrix Q.   
            If JOBQ = 'N', Q is not referenced.   

    LDQ     (input) INTEGER   
            The leading dimension of the array Q. LDQ >= max(1,N) if   
            JOBQ = 'Q'; LDQ >= 1 otherwise.   

    IWORK   (workspace) INTEGER array, dimension (N)   

    RWORK   (workspace) REAL array, dimension (2*N)   

    TAU     (workspace) COMPLEX array, dimension (N)   

    WORK    (workspace) COMPLEX array, dimension (max(3*N,M,P))   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   

    Further Details   
    ===============   

    The subroutine uses LAPACK subroutine CGEQPF for the QR factorization 
  
    with column pivoting to detect the effective numerical rank of the   
    a matrix. It may be replaced by a better rank determination strategy. 
  

    ===================================================================== 
  


       Test the input parameters   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static complex c_b1 = {0.f,0.f};
    static complex c_b2 = {1.f,0.f};
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
	    u_offset, v_dim1, v_offset, i__1, i__2, i__3;
    real r__1, r__2;
    /* Builtin functions */
    double r_imag(complex *);
    /* Local variables */
    static integer i, j;
    extern logical lsame_(char *, char *);
    static logical wantq, wantu, wantv;
    extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *, 
	    integer *, complex *, complex *, integer *), cgerq2_(integer *, 
	    integer *, complex *, integer *, complex *, complex *, integer *),
	     cung2r_(integer *, integer *, integer *, complex *, integer *, 
	    complex *, complex *, integer *), cunm2r_(char *, char *, integer 
	    *, integer *, integer *, complex *, integer *, complex *, complex 
	    *, integer *, complex *, integer *), cunmr2_(char 
	    *, char *, integer *, integer *, integer *, complex *, integer *, 
	    complex *, complex *, integer *, complex *, integer *), cgeqpf_(integer *, integer *, complex *, integer *, 
	    integer *, complex *, complex *, real *, integer *), clacpy_(char 
	    *, integer *, integer *, complex *, integer *, complex *, integer 
	    *), claset_(char *, integer *, integer *, complex *, 
	    complex *, complex *, integer *), xerbla_(char *, integer 
	    *), clapmt_(logical *, integer *, integer *, complex *, 
	    integer *, integer *);
    static logical forwrd;



#define IWORK(I) iwork[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define U(I,J) u[(I)-1 + ((J)-1)* ( *ldu)]
#define V(I,J) v[(I)-1 + ((J)-1)* ( *ldv)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]

    wantu = lsame_(jobu, "U");
    wantv = lsame_(jobv, "V");
    wantq = lsame_(jobq, "Q");
    forwrd = TRUE_;

    *info = 0;
    if (! (wantu || lsame_(jobu, "N"))) {
	*info = -1;
    } else if (! (wantv || lsame_(jobv, "N"))) {
	*info = -2;
    } else if (! (wantq || lsame_(jobq, "N"))) {
	*info = -3;
    } else if (*m < 0) {
	*info = -4;
    } else if (*p < 0) {
	*info = -5;
    } else if (*n < 0) {
	*info = -6;
    } else if (*lda < max(1,*m)) {
	*info = -8;
    } else if (*ldb < max(1,*p)) {
	*info = -10;
    } else if (*ldu < 1 || wantu && *ldu < *m) {
	*info = -16;
    } else if (*ldv < 1 || wantv && *ldv < *p) {
	*info = -18;
    } else if (*ldq < 1 || wantq && *ldq < *n) {
	*info = -20;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CGGSVP", &i__1);
	return 0;
    }

/*     QR with column pivoting of B: B*P = V*( S11 S12 )   
                                             (  0   0  ) */

    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	IWORK(i) = 0;
/* L10: */
    }
    cgeqpf_(p, n, &B(1,1), ldb, &IWORK(1), &TAU(1), &WORK(1), &RWORK(1), 
	    info);

/*     Update A := A*P */

    clapmt_(&forwrd, m, n, &A(1,1), lda, &IWORK(1));

/*     Determine the effective rank of matrix B. */

    *l = 0;
    i__1 = min(*p,*n);
    for (i = 1; i <= min(*p,*n); ++i) {
	i__2 = i + i * b_dim1;
	if ((r__1 = B(i,i).r, dabs(r__1)) + (r__2 = r_imag(&B(i,i)
		), dabs(r__2)) > *tolb) {
	    ++(*l);
	}
/* L20: */
    }

    if (wantv) {

/*        Copy the details of V, and form V. */

	claset_("Full", p, p, &c_b1, &c_b1, &V(1,1), ldv);
	if (*p > 1) {
	    i__1 = *p - 1;
	    clacpy_("Lower", &i__1, n, &B(2,1), ldb, &V(2,1), 
		    ldv);
	}
	i__1 = min(*p,*n);
	cung2r_(p, p, &i__1, &V(1,1), ldv, &TAU(1), &WORK(1), info);
    }

/*     Clean up B */

    i__1 = *l - 1;
    for (j = 1; j <= *l-1; ++j) {
	i__2 = *l;
	for (i = j + 1; i <= *l; ++i) {
	    i__3 = i + j * b_dim1;
	    B(i,j).r = 0.f, B(i,j).i = 0.f;
/* L30: */
	}
/* L40: */
    }
    if (*p > *l) {
	i__1 = *p - *l;
	claset_("Full", &i__1, n, &c_b1, &c_b1, &B(*l+1,1), ldb);
    }

    if (wantq) {

/*        Set Q = I and Update Q := Q*P */

	claset_("Full", n, n, &c_b1, &c_b2, &Q(1,1), ldq);
	clapmt_(&forwrd, n, n, &Q(1,1), ldq, &IWORK(1));
    }

    if (*p >= *l && *n != *l) {

/*        RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */

	cgerq2_(l, n, &B(1,1), ldb, &TAU(1), &WORK(1), info);

/*        Update A := A*Z' */

	cunmr2_("Right", "Conjugate transpose", m, n, l, &B(1,1), ldb, &
		TAU(1), &A(1,1), lda, &WORK(1), info);
	if (wantq) {

/*           Update Q := Q*Z' */

	    cunmr2_("Right", "Conjugate transpose", n, n, l, &B(1,1), 
		    ldb, &TAU(1), &Q(1,1), ldq, &WORK(1), info);
	}

/*        Clean up B */

	i__1 = *n - *l;
	claset_("Full", l, &i__1, &c_b1, &c_b1, &B(1,1), ldb);
	i__1 = *n;
	for (j = *n - *l + 1; j <= *n; ++j) {
	    i__2 = *l;
	    for (i = j - *n + *l + 1; i <= *l; ++i) {
		i__3 = i + j * b_dim1;
		B(i,j).r = 0.f, B(i,j).i = 0.f;
/* L50: */
	    }
/* L60: */
	}

    }

/*     Let              N-L     L   
                  A = ( A11    A12 ) M,   

       then the following does the complete QR decomposition of A11:   

                A11 = U*(  0  T12 )*P1'   
                        (  0   0  ) */

    i__1 = *n - *l;
    for (i = 1; i <= *n-*l; ++i) {
	IWORK(i) = 0;
/* L70: */
    }
    i__1 = *n - *l;
    cgeqpf_(m, &i__1, &A(1,1), lda, &IWORK(1), &TAU(1), &WORK(1), &RWORK(
	    1), info);

/*     Determine the effective rank of A11 */

    *k = 0;
/* Computing MIN */
    i__2 = *m, i__3 = *n - *l;
    i__1 = min(i__2,i__3);
    for (i = 1; i <= min(*m,*n-*l); ++i) {
	i__2 = i + i * a_dim1;
	if ((r__1 = A(i,i).r, dabs(r__1)) + (r__2 = r_imag(&A(i,i)
		), dabs(r__2)) > *tola) {
	    ++(*k);
	}
/* L80: */
    }

/*     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )   

   Computing MIN */
    i__2 = *m, i__3 = *n - *l;
    i__1 = min(i__2,i__3);
    cunm2r_("Left", "Conjugate transpose", m, l, &i__1, &A(1,1), lda, &
	    TAU(1), &A(1,*n-*l+1), lda, &WORK(1), info);

    if (wantu) {

/*        Copy the details of U, and form U */

	claset_("Full", m, m, &c_b1, &c_b1, &U(1,1), ldu);
	if (*m > 1) {
	    i__1 = *m - 1;
	    i__2 = *n - *l;
	    clacpy_("Lower", &i__1, &i__2, &A(2,1), lda, &U(2,1)
		    , ldu);
	}
/* Computing MIN */
	i__2 = *m, i__3 = *n - *l;
	i__1 = min(i__2,i__3);
	cung2r_(m, m, &i__1, &U(1,1), ldu, &TAU(1), &WORK(1), info);
    }

    if (wantq) {

/*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1 */

	i__1 = *n - *l;
	clapmt_(&forwrd, n, &i__1, &Q(1,1), ldq, &IWORK(1));
    }

/*     Clean up A: set the strictly lower triangular part of   
       A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */

    i__1 = *k - 1;
    for (j = 1; j <= *k-1; ++j) {
	i__2 = *k;
	for (i = j + 1; i <= *k; ++i) {
	    i__3 = i + j * a_dim1;
	    A(i,j).r = 0.f, A(i,j).i = 0.f;
/* L90: */
	}
/* L100: */
    }
    if (*m > *k) {
	i__1 = *m - *k;
	i__2 = *n - *l;
	claset_("Full", &i__1, &i__2, &c_b1, &c_b1, &A(*k+1,1), lda);
    }

    if (*n - *l > *k) {

/*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */

	i__1 = *n - *l;
	cgerq2_(k, &i__1, &A(1,1), lda, &TAU(1), &WORK(1), info);

	if (wantq) {

/*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */

	    i__1 = *n - *l;
	    cunmr2_("Right", "Conjugate transpose", n, &i__1, k, &A(1,1),
		     lda, &TAU(1), &Q(1,1), ldq, &WORK(1), info)
		    ;
	}

/*        Clean up A */

	i__1 = *n - *l - *k;
	claset_("Full", k, &i__1, &c_b1, &c_b1, &A(1,1), lda);
	i__1 = *n - *l;
	for (j = *n - *l - *k + 1; j <= *n-*l; ++j) {
	    i__2 = *k;
	    for (i = j - *n + *l + *k + 1; i <= *k; ++i) {
		i__3 = i + j * a_dim1;
		A(i,j).r = 0.f, A(i,j).i = 0.f;
/* L110: */
	    }
/* L120: */
	}

    }

    if (*m > *k) {

/*        QR factorization of A( K+1:M,N-L+1:N ) */

	i__1 = *m - *k;
	cgeqr2_(&i__1, l, &A(*k+1,*n-*l+1), lda, &TAU(1), &
		WORK(1), info);

	if (wantu) {

/*           Update U(:,K+1:M) := U(:,K+1:M)*U1 */

	    i__1 = *m - *k;
/* Computing MIN */
	    i__3 = *m - *k;
	    i__2 = min(i__3,*l);
	    cunm2r_("Right", "No transpose", m, &i__1, &i__2, &A(*k+1,*n-*l+1), lda, &TAU(1), &U(1,*k+1), ldu, &WORK(1), info);
	}

/*        Clean up */

	i__1 = *n;
	for (j = *n - *l + 1; j <= *n; ++j) {
	    i__2 = *m;
	    for (i = j - *n + *k + *l + 1; i <= *m; ++i) {
		i__3 = i + j * a_dim1;
		A(i,j).r = 0.f, A(i,j).i = 0.f;
/* L130: */
	    }
/* L140: */
	}

    }

    return 0;

/*     End of CGGSVP */

} /* cggsvp_ */
Esempio n. 30
0
/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n, 
	doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work, 
	integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, 
	integer *liwork, integer *info)
{
/*  -- 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   


    Purpose   
    =======   

    ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a   
    complex Hermitian matrix A.  If eigenvectors are desired, it uses a   
    divide and conquer algorithm.   

    The divide and conquer algorithm makes very mild assumptions about   
    floating point arithmetic. It will work on machines with a guard   
    digit in add/subtract, or on those binary machines without guard   
    digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or   
    Cray-2. It could conceivably fail on hexadecimal or decimal machines 
  
    without guard digits, but we know of none.   

    Arguments   
    =========   

    JOBZ    (input) CHARACTER*1   
            = 'N':  Compute eigenvalues only;   
            = 'V':  Compute eigenvalues and eigenvectors.   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    A       (input/output) COMPLEX*16 array, dimension (LDA, N)   
            On entry, the Hermitian matrix A.  If UPLO = 'U', the   
            leading N-by-N upper triangular part of A contains the   
            upper triangular part of the matrix A.  If UPLO = 'L',   
            the leading N-by-N lower triangular part of A contains   
            the lower triangular part of the matrix A.   
            On exit, if JOBZ = 'V', then if INFO = 0, A contains the   
            orthonormal eigenvectors of the matrix A.   
            If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') 
  
            or the upper triangle (if UPLO='U') of A, including the   
            diagonal, is destroyed.   

    LDA     (input) INTEGER   
            The leading dimension of the array A.  LDA >= max(1,N).   

    W       (output) DOUBLE PRECISION array, dimension (N)   
            If INFO = 0, the eigenvalues in ascending order.   

    WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)   
            On exit, if LWORK > 0, WORK(1) returns the optimal LWORK.   

    LWORK   (input) INTEGER   
            The length of the array WORK.   
            If N <= 1,                LWORK must be at least 1.   
            If JOBZ  = 'N' and N > 1, LWORK must be at least N + 1.   
            If JOBZ  = 'V' and N > 1, LWORK must be at least 2*N + N**2. 
  

    RWORK   (workspace/output) DOUBLE PRECISION array,   
                                           dimension (LRWORK)   
            On exit, if LRWORK > 0, RWORK(1) returns the optimal LRWORK. 
  

    LRWORK  (input) INTEGER   
            The dimension of the array RWORK.   
            If N <= 1,                LRWORK must be at least 1.   
            If JOBZ  = 'N' and N > 1, LRWORK must be at least N.   
            If JOBZ  = 'V' and N > 1, LRWORK must be at least   
                           1 + 4*N + 2*N*lg N + 3*N**2 ,   
                           where lg( N ) = smallest integer k such   
                           that 2**k >= N .   

    IWORK   (workspace/output) INTEGER array, dimension (LIWORK)   
            On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. 
  

    LIWORK  (input) INTEGER   
            The dimension of the array IWORK.   
            If N <= 1,                LIWORK must be at least 1.   
            If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.   
            If JOBZ  = 'V' and N > 1, LIWORK must be at least 2 + 5*N.   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  if INFO = i, the algorithm failed to converge; i   
                  off-diagonal elements of an intermediate tridiagonal   
                  form did not converge to zero.   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__2 = 2;
    static integer c__0 = 0;
    static doublereal c_b16 = 1.;
    static integer c__1 = 1;
    
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;
    /* Builtin functions */
    double log(doublereal);
    integer pow_ii(integer *, integer *);
    double sqrt(doublereal);
    /* Local variables */
    static integer inde;
    static doublereal anrm;
    static integer imax;
    static doublereal rmin, rmax;
    static integer lopt;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    static doublereal sigma;
    extern logical lsame_(char *, char *);
    static integer iinfo, lwmin, liopt;
    static logical lower;
    static integer llrwk, lropt;
    static logical wantz;
    static integer indwk2, llwrk2;
    extern doublereal dlamch_(char *);
    static integer iscale;
    static doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    static integer indtau;
    extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
	     integer *), zlascl_(char *, integer *, integer *, doublereal *, 
	    doublereal *, integer *, integer *, doublecomplex *, integer *, 
	    integer *), zstedc_(char *, integer *, doublereal *, 
	    doublereal *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublereal *, integer *, integer *, integer *, integer 
	    *);
    static integer indrwk, indwrk, liwmin;
    extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *, 
	    integer *, doublereal *, doublereal *, doublecomplex *, 
	    doublecomplex *, integer *, integer *), zlacpy_(char *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     integer *);
    static integer lrwmin, llwork;
    static doublereal smlnum;
    extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static integer lgn;
    static doublereal eps;



#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

    wantz = lsame_(jobz, "V");
    lower = lsame_(uplo, "L");

    *info = 0;
    if (*n <= 1) {
	lgn = 0;
	lwmin = 1;
	lrwmin = 1;
	liwmin = 1;
	lopt = lwmin;
	lropt = lrwmin;
	liopt = liwmin;
    } else {
	lgn = (integer) (log((doublereal) (*n)) / log(2.));
	if (pow_ii(&c__2, &lgn) < *n) {
	    ++lgn;
	}
	if (pow_ii(&c__2, &lgn) < *n) {
	    ++lgn;
	}
	if (wantz) {
	    lwmin = (*n << 1) + *n * *n;
/* Computing 2nd power */
	    i__1 = *n;
	    lrwmin = (*n << 2) + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
	    liwmin = *n * 5 + 2;
	} else {
	    lwmin = *n + 1;
	    lrwmin = *n;
	    liwmin = 1;
	}
	lopt = lwmin;
	lropt = lrwmin;
	liopt = liwmin;
    }
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (lower || lsame_(uplo, "U"))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*lda < max(1,*n)) {
	*info = -5;
    } else if (*lwork < lwmin) {
	*info = -8;
    } else if (*lrwork < lrwmin) {
	*info = -10;
    } else if (*liwork < liwmin) {
	*info = -12;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZHEEVD ", &i__1);
	goto L10;
    }

/*     Quick return if possible */

    if (*n == 0) {
	goto L10;
    }

    if (*n == 1) {
	i__1 = a_dim1 + 1;
	W(1) = A(1,1).r;
	if (wantz) {
	    i__1 = a_dim1 + 1;
	    A(1,1).r = 1., A(1,1).i = 0.;
	}
	goto L10;
    }

/*     Get machine constants. */

    safmin = dlamch_("Safe minimum");
    eps = dlamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1. / smlnum;
    rmin = sqrt(smlnum);
    rmax = sqrt(bignum);

/*     Scale matrix to allowable range, if necessary. */

    anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
    iscale = 0;
    if (anrm > 0. && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	zlascl_(uplo, &c__0, &c__0, &c_b16, &sigma, n, n, &A(1,1), lda, 
		info);
    }

/*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */

    inde = 1;
    indtau = 1;
    indwrk = indtau + *n;
    indrwk = inde + *n;
    indwk2 = indwrk + *n * *n;
    llwork = *lwork - indwrk + 1;
    llwrk2 = *lwork - indwk2 + 1;
    llrwk = *lrwork - indrwk + 1;
    zhetrd_(uplo, n, &A(1,1), lda, &W(1), &RWORK(inde), &WORK(indtau), &
	    WORK(indwrk), &llwork, &iinfo);
/* Computing MAX */
    i__1 = indwrk;
    d__1 = (doublereal) lopt, d__2 = (doublereal) (*n) + WORK(indwrk).r;
    lopt = (integer) max(d__1,d__2);

/*     For eigenvalues only, call DSTERF.  For eigenvectors, first call   
       ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the   
       tridiagonal matrix, then call ZUNMTR to multiply it to the   
       Householder transformations represented as Householder vectors in 
  
       A. */

    if (! wantz) {
	dsterf_(n, &W(1), &RWORK(inde), info);
    } else {
	zstedc_("I", n, &W(1), &RWORK(inde), &WORK(indwrk), n, &WORK(indwk2), 
		&llwrk2, &RWORK(indrwk), &llrwk, &IWORK(1), liwork, info);
	zunmtr_("L", uplo, "N", n, n, &A(1,1), lda, &WORK(indtau), &WORK(
		indwrk), n, &WORK(indwk2), &llwrk2, &iinfo);
	zlacpy_("A", n, n, &WORK(indwrk), n, &A(1,1), lda);
/* Computing MAX   
   Computing 2nd power */
	i__3 = *n;
	i__4 = indwk2;
	i__1 = lopt, i__2 = *n + i__3 * i__3 + (integer) WORK(indwk2).r;
	lopt = max(i__1,i__2);
    }

/*     If matrix was scaled, then rescale eigenvalues appropriately. */

    if (iscale == 1) {
	if (*info == 0) {
	    imax = *n;
	} else {
	    imax = *info - 1;
	}
	d__1 = 1. / sigma;
	dscal_(&imax, &d__1, &W(1), &c__1);
    }

L10:
    if (*lwork > 0) {
	WORK(1).r = (doublereal) lopt, WORK(1).i = 0.;
    }
    if (*lrwork > 0) {
	RWORK(1) = (doublereal) lropt;
    }
    if (*liwork > 0) {
	IWORK(1) = liopt;
    }
    return 0;

/*     End of ZHEEVD */

} /* zheevd_ */