/* lapack/complex16/ztrsen.f -- translated by f2c (version 20090411).
   You must link the resulting object file with libf2c:
        on Microsoft Windows system, link with libf2c.lib;
        on Linux or Unix systems, link with .../path/to/libf2c.a -lm
        or, if you install libf2c.a in a standard place, with -lf2c -lm
        -- in that order, at the end of the command line, as in
                cc *.o -lf2c -lm
        Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,

                http://www.netlib.org/f2c/libf2c.zip
*/

#ifdef __cplusplus
extern "C" {
#endif
#include "v3p_netlib.h"

/* Table of constant values */

static integer c_n1 = -1;

/*<    >*/
/* Subroutine */ int ztrsen_(char *job, char *compq, logical *select, integer
        *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq,
        doublecomplex *w, integer *m, doublereal *s, doublereal *sep,
        doublecomplex *work, integer *lwork, integer *info, ftnlen job_len,
        ftnlen compq_len)
{
    /* System generated locals */
    integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    integer k, n1, n2, nn, ks;
    doublereal est;
    integer kase, ierr;
    doublereal scale;
    extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
    integer isave[3], lwmin;
    logical wantq, wants;
    doublereal rnorm, rwork[1];
    extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
            doublecomplex *, doublereal *, integer *, integer *), xerbla_(
            char *, integer *, ftnlen);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
            integer *, doublereal *, ftnlen);
    logical wantbh;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
            doublecomplex *, integer *, doublecomplex *, integer *, ftnlen);
    logical wantsp;
    extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
            integer *, doublecomplex *, integer *, integer *, integer *,
            integer *, ftnlen);
    logical lquery;
    extern /* Subroutine */ int ztrsyl_(char *, char *, integer *, integer *,
            integer *, doublecomplex *, integer *, doublecomplex *, integer *,
             doublecomplex *, integer *, doublereal *, integer *, ftnlen,
            ftnlen);
    (void)job_len;
    (void)compq_len;

/*  -- LAPACK routine (version 3.2) -- */
/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/*     November 2006 */

/*     Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */

/*     .. Scalar Arguments .. */
/*<       CHARACTER          COMPQ, JOB >*/
/*<       INTEGER            INFO, LDQ, LDT, LWORK, M, N >*/
/*<       DOUBLE PRECISION   S, SEP >*/
/*     .. */
/*     .. Array Arguments .. */
/*<       LOGICAL            SELECT( * ) >*/
/*<       COMPLEX*16         Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) >*/
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZTRSEN reorders the Schur factorization of a complex matrix */
/*  A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in */
/*  the leading positions on the diagonal of the upper triangular matrix */
/*  T, and the leading columns of Q form an orthonormal basis of the */
/*  corresponding right invariant subspace. */

/*  Optionally the routine computes the reciprocal condition numbers of */
/*  the cluster of eigenvalues and/or the invariant subspace. */

/*  Arguments */
/*  ========= */

/*  JOB     (input) CHARACTER*1 */
/*          Specifies whether condition numbers are required for the */
/*          cluster of eigenvalues (S) or the invariant subspace (SEP): */
/*          = 'N': none; */
/*          = 'E': for eigenvalues only (S); */
/*          = 'V': for invariant subspace only (SEP); */
/*          = 'B': for both eigenvalues and invariant subspace (S and */
/*                 SEP). */

/*  COMPQ   (input) CHARACTER*1 */
/*          = 'V': update the matrix Q of Schur vectors; */
/*          = 'N': do not update Q. */

/*  SELECT  (input) LOGICAL array, dimension (N) */
/*          SELECT specifies the eigenvalues in the selected cluster. To */
/*          select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. */

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

/*  T       (input/output) COMPLEX*16 array, dimension (LDT,N) */
/*          On entry, the upper triangular matrix T. */
/*          On exit, T is overwritten by the reordered matrix T, with the */
/*          selected eigenvalues as the leading diagonal elements. */

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

/*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N) */
/*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
/*          On exit, if COMPQ = 'V', Q has been postmultiplied by the */
/*          unitary transformation matrix which reorders T; the leading M */
/*          columns of Q form an orthonormal basis for the specified */
/*          invariant subspace. */
/*          If COMPQ = 'N', Q is not referenced. */

/*  LDQ     (input) INTEGER */
/*          The leading dimension of the array Q. */
/*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */

/*  W       (output) COMPLEX*16 array, dimension (N) */
/*          The reordered eigenvalues of T, in the same order as they */
/*          appear on the diagonal of T. */

/*  M       (output) INTEGER */
/*          The dimension of the specified invariant subspace. */
/*          0 <= M <= N. */

/*  S       (output) DOUBLE PRECISION */
/*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
/*          condition number for the selected cluster of eigenvalues. */
/*          S cannot underestimate the true reciprocal condition number */
/*          by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
/*          If JOB = 'N' or 'V', S is not referenced. */

/*  SEP     (output) DOUBLE PRECISION */
/*          If JOB = 'V' or 'B', SEP is the estimated reciprocal */
/*          condition number of the specified invariant subspace. If */
/*          M = 0 or N, SEP = norm(T). */
/*          If JOB = 'N' or 'E', SEP is not referenced. */

/*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. */
/*          If JOB = 'N', LWORK >= 1; */
/*          if JOB = 'E', LWORK = max(1,M*(N-M)); */
/*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */

/*          If LWORK = -1, then a workspace query is assumed; the routine */
/*          only calculates the optimal size of the WORK array, returns */
/*          this value as the first entry of the WORK array, and no error */
/*          message related to LWORK is issued by XERBLA. */

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

/*  Further Details */
/*  =============== */

/*  ZTRSEN first collects the selected eigenvalues by computing a unitary */
/*  transformation Z to move them to the top left corner of T. In other */
/*  words, the selected eigenvalues are the eigenvalues of T11 in: */

/*                Z'*T*Z = ( T11 T12 ) n1 */
/*                         (  0  T22 ) n2 */
/*                            n1  n2 */

/*  where N = n1+n2 and Z' means the conjugate transpose of Z. The first */
/*  n1 columns of Z span the specified invariant subspace of T. */

/*  If T has been obtained from the Schur factorization of a matrix */
/*  A = Q*T*Q', then the reordered Schur factorization of A is given by */
/*  A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the */
/*  corresponding invariant subspace of A. */

/*  The reciprocal condition number of the average of the eigenvalues of */
/*  T11 may be returned in S. S lies between 0 (very badly conditioned) */
/*  and 1 (very well conditioned). It is computed as follows. First we */
/*  compute R so that */

/*                         P = ( I  R ) n1 */
/*                             ( 0  0 ) n2 */
/*                               n1 n2 */

/*  is the projector on the invariant subspace associated with T11. */
/*  R is the solution of the Sylvester equation: */

/*                        T11*R - R*T22 = T12. */

/*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
/*  the two-norm of M. Then S is computed as the lower bound */

/*                      (1 + F-norm(R)**2)**(-1/2) */

/*  on the reciprocal of 2-norm(P), the true reciprocal condition number. */
/*  S cannot underestimate 1 / 2-norm(P) by more than a factor of */
/*  sqrt(N). */

/*  An approximate error bound for the computed average of the */
/*  eigenvalues of T11 is */

/*                         EPS * norm(T) / S */

/*  where EPS is the machine precision. */

/*  The reciprocal condition number of the right invariant subspace */
/*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
/*  SEP is defined as the separation of T11 and T22: */

/*                     sep( T11, T22 ) = sigma-min( C ) */

/*  where sigma-min(C) is the smallest singular value of the */
/*  n1*n2-by-n1*n2 matrix */

/*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */

/*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
/*  product. We estimate sigma-min(C) by the reciprocal of an estimate of */
/*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
/*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */

/*  When SEP is small, small changes in T can cause large changes in */
/*  the invariant subspace. An approximate bound on the maximum angular */
/*  error in the computed right invariant subspace is */

/*                      EPS * norm(T) / SEP */

/*  ===================================================================== */

/*     .. Parameters .. */
/*<       DOUBLE PRECISION   ZERO, ONE >*/
/*<       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*     .. */
/*     .. Local Scalars .. */
/*<       LOGICAL            LQUERY, WANTBH, WANTQ, WANTS, WANTSP >*/
/*<       INTEGER            IERR, K, KASE, KS, LWMIN, N1, N2, NN >*/
/*<       DOUBLE PRECISION   EST, RNORM, SCALE >*/
/*     .. */
/*     .. Local Arrays .. */
/*<       INTEGER            ISAVE( 3 ) >*/
/*<       DOUBLE PRECISION   RWORK( 1 ) >*/
/*     .. */
/*     .. External Functions .. */
/*<       LOGICAL            LSAME >*/
/*<       DOUBLE PRECISION   ZLANGE >*/
/*<       EXTERNAL           LSAME, ZLANGE >*/
/*     .. */
/*     .. External Subroutines .. */
/*<       EXTERNAL           XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL >*/
/*     .. */
/*     .. Intrinsic Functions .. */
/*<       INTRINSIC          MAX, SQRT >*/
/*     .. */
/*     .. Executable Statements .. */

/*     Decode and test the input parameters. */

/*<       WANTBH = LSAME( JOB, 'B' ) >*/
    /* Parameter adjustments */
    --select;
    t_dim1 = *ldt;
    t_offset = 1 + t_dim1;
    t -= t_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    --w;
    --work;

    /* Function Body */
    wantbh = lsame_(job, "B", (ftnlen)1, (ftnlen)1);
/*<       WANTS = LSAME( JOB, 'E' ) .OR. WANTBH >*/
    wants = lsame_(job, "E", (ftnlen)1, (ftnlen)1) || wantbh;
/*<       WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH >*/
    wantsp = lsame_(job, "V", (ftnlen)1, (ftnlen)1) || wantbh;
/*<       WANTQ = LSAME( COMPQ, 'V' ) >*/
    wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1);

/*     Set M to the number of selected eigenvalues. */

/*<       M = 0 >*/
    *m = 0;
/*<       DO 10 K = 1, N >*/
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
/*<    >*/
        if (select[k]) {
            ++(*m);
        }
/*<    10 CONTINUE >*/
/* L10: */
    }

/*<       N1 = M >*/
    n1 = *m;
/*<       N2 = N - M >*/
    n2 = *n - *m;
/*<       NN = N1*N2 >*/
    nn = n1 * n2;

/*<       INFO = 0 >*/
    *info = 0;
/*<       LQUERY = ( LWORK.EQ.-1 ) >*/
    lquery = *lwork == -1;

/*<       IF( WANTSP ) THEN >*/
    if (wantsp) {
/*<          LWMIN = MAX( 1, 2*NN ) >*/
/* Computing MAX */
        i__1 = 1, i__2 = nn << 1;
        lwmin = max(i__1,i__2);
/*<       ELSE IF( LSAME( JOB, 'N' ) ) THEN >*/
    } else if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
/*<          LWMIN = 1 >*/
        lwmin = 1;
/*<       ELSE IF( LSAME( JOB, 'E' ) ) THEN >*/
    } else if (lsame_(job, "E", (ftnlen)1, (ftnlen)1)) {
/*<          LWMIN = MAX( 1, NN ) >*/
        lwmin = max(1,nn);
/*<       END IF >*/
    }

/*<    >*/
    if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! wants && ! wantsp) {
/*<          INFO = -1 >*/
        *info = -1;
/*<       ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN >*/
    } else if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) {
/*<          INFO = -2 >*/
        *info = -2;
/*<       ELSE IF( N.LT.0 ) THEN >*/
    } else if (*n < 0) {
/*<          INFO = -4 >*/
        *info = -4;
/*<       ELSE IF( LDT.LT.MAX( 1, N ) ) THEN >*/
    } else if (*ldt < max(1,*n)) {
/*<          INFO = -6 >*/
        *info = -6;
/*<       ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN >*/
    } else if (*ldq < 1 || (wantq && *ldq) < *n) {
/*<          INFO = -8 >*/
        *info = -8;
/*<       ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN >*/
    } else if (*lwork < lwmin && ! lquery) {
/*<          INFO = -14 >*/
        *info = -14;
/*<       END IF >*/
    }

/*<       IF( INFO.EQ.0 ) THEN >*/
    if (*info == 0) {
/*<          WORK( 1 ) = LWMIN >*/
        work[1].r = (doublereal) lwmin, work[1].i = 0.;
/*<       END IF >*/
    }

/*<       IF( INFO.NE.0 ) THEN >*/
    if (*info != 0) {
/*<          CALL XERBLA( 'ZTRSEN', -INFO ) >*/
        i__1 = -(*info);
        xerbla_("ZTRSEN", &i__1, (ftnlen)6);
/*<          RETURN >*/
        return 0;
/*<       ELSE IF( LQUERY ) THEN >*/
    } else if (lquery) {
/*<          RETURN >*/
        return 0;
/*<       END IF >*/
    }

/*     Quick return if possible */

/*<       IF( M.EQ.N .OR. M.EQ.0 ) THEN >*/
    if (*m == *n || *m == 0) {
/*<    >*/
        if (wants) {
            *s = 1.;
        }
/*<    >*/
        if (wantsp) {
            *sep = zlange_("1", n, n, &t[t_offset], ldt, rwork, (ftnlen)1);
        }
/*<          GO TO 40 >*/
        goto L40;
/*<       END IF >*/
    }

/*     Collect the selected eigenvalues at the top left corner of T. */

/*<       KS = 0 >*/
    ks = 0;
/*<       DO 20 K = 1, N >*/
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
/*<          IF( SELECT( K ) ) THEN >*/
        if (select[k]) {
/*<             KS = KS + 1 >*/
            ++ks;

/*           Swap the K-th eigenvalue to position KS. */

/*<    >*/
            if (k != ks) {
                ztrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, &
                        ks, &ierr, (ftnlen)1);
            }
/*<          END IF >*/
        }
/*<    20 CONTINUE >*/
/* L20: */
    }

/*<       IF( WANTS ) THEN >*/
    if (wants) {

/*        Solve the Sylvester equation for R: */

/*           T11*R - R*T22 = scale*T12 */

/*<          CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) >*/
        zlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1,
                (ftnlen)1);
/*<    >*/
        ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
                + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr, (ftnlen)1,
                (ftnlen)1);

/*        Estimate the reciprocal of the condition number of the cluster */
/*        of eigenvalues. */

/*<          RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK ) >*/
        rnorm = zlange_("F", &n1, &n2, &work[1], &n1, rwork, (ftnlen)1);
/*<          IF( RNORM.EQ.ZERO ) THEN >*/
        if (rnorm == 0.) {
/*<             S = ONE >*/
            *s = 1.;
/*<          ELSE >*/
        } else {
/*<    >*/
            *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
/*<          END IF >*/
        }
/*<       END IF >*/
    }

/*<       IF( WANTSP ) THEN >*/
    if (wantsp) {

/*        Estimate sep(T11,T22). */

/*<          EST = ZERO >*/
        est = 0.;
/*<          KASE = 0 >*/
        kase = 0;
/*<    30    CONTINUE >*/
L30:
/*<          CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) >*/
        zlacn2_(&nn, &work[nn + 1], &work[1], &est, &kase, isave);
/*<          IF( KASE.NE.0 ) THEN >*/
        if (kase != 0) {
/*<             IF( KASE.EQ.1 ) THEN >*/
            if (kase == 1) {

/*              Solve T11*R - R*T22 = scale*X. */

/*<    >*/
                ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
                        1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
                        ierr, (ftnlen)1, (ftnlen)1);
/*<             ELSE >*/
            } else {

/*              Solve T11'*R - R*T22' = scale*X. */

/*<    >*/
                ztrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
                        1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
                        ierr, (ftnlen)1, (ftnlen)1);
/*<             END IF >*/
            }
/*<             GO TO 30 >*/
            goto L30;
/*<          END IF >*/
        }

/*<          SEP = SCALE / EST >*/
        *sep = scale / est;
/*<       END IF >*/
    }

/*<    40 CONTINUE >*/
L40:

/*     Copy reordered eigenvalues to W. */

/*<       DO 50 K = 1, N >*/
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
/*<          W( K ) = T( K, K ) >*/
        i__2 = k;
        i__3 = k + k * t_dim1;
        w[i__2].r = t[i__3].r, w[i__2].i = t[i__3].i;
/*<    50 CONTINUE >*/
/* L50: */
    }

/*<       WORK( 1 ) = LWMIN >*/
    work[1].r = (doublereal) lwmin, work[1].i = 0.;

/*<       RETURN >*/
    return 0;

/*     End of ZTRSEN */

/*<       END >*/
} /* ztrsen_ */

#ifdef __cplusplus
        }
#endif
