コード例 #1
0
ファイル: linal.c プロジェクト: kcoltin/blackjack
// Computes the condition number of complex N x N matrix A. 
// The condition number is defined as the ratio of the largest to the smallest
// singular values. Uses LAPACK. 
// Note: may need to append _ to name of LAPACK functions.  
double ccondit_num (double complex **A, int N)
{
	double complex *a, *cwork = NULL; 
	double kappa, rcond, anorm; 
	double *rwork = NULL; 
	char NORM = '1'; 
	int info; 

	// Convert A for LAPACK functions
	a = cmat_to_fortran (A, N, N); 

	// Allocate work, rwork for zgecon (work is not used in anorm with NORM='1') 
	cwork = c_allocvector (2 * N); 
	if (cwork == NULL) throwMemErr ("cwork", "ccondit_num"); 
	rwork = allocvector (2 * N); 
	if (rwork == NULL) throwMemErr ("rwork", "ccondit_num"); 

	// Compute 1-norm of A 
	anorm = zlange_ (&NORM, &N, &N, a, &N, rwork); 
	
	// Compute reciprocal of condition number 
	zgecon_ (&NORM, &N, a, &N, &anorm, &rcond, cwork, rwork, &info); 
	kappa = 1. / rcond; 

	if (info != 0) 
		throwErr ("Illegal argument to zgecon", "ccondit_num"); 

	free (a); 
	free (cwork); 
	free (rwork); 

	return kappa; 
}
コード例 #2
0
ファイル: zgees.c プロジェクト: Electrostatics/FETK
/* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n, 
	doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, 
	doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,
	 doublereal *rwork, logical *bwork, integer *info, ftnlen jobvs_len, 
	ftnlen sort_len)
{
    /* 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 i__, k;
    static doublereal s;
    static integer ihi, ilo;
    static doublereal dum[1], eps, sep;
    static integer ibal, maxb;
    static doublereal anrm;
    static integer ierr, itau, iwrk, icond, ieval;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    static logical scalea;
    extern doublereal dlamch_(char *, ftnlen);
    static doublereal cscale;
    extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublecomplex *, integer *, 
	    integer *, ftnlen, ftnlen), zgebal_(char *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, doublereal *, 
	    integer *, ftnlen), xerbla_(char *, integer *, ftnlen);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *, ftnlen);
    static doublereal bignum;
    extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *), zlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
	     integer *, integer *, ftnlen), zlacpy_(char *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, integer *,
	     ftnlen);
    static integer minwrk, maxwrk;
    static doublereal smlnum;
    extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *,
	     ftnlen, ftnlen);
    static integer hswork;
    extern /* Subroutine */ int zunghr_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *);
    static logical wantst, lquery, wantvs;
    extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublereal *, doublereal *, 
	    doublecomplex *, integer *, integer *, ftnlen, ftnlen);


/*  -- LAPACK driver routine (version 3.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     June 30, 1999 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */
/*     .. Function Arguments .. */
/*     .. */

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

/*  ZGEES 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. */
/*  The leading columns of Z then form an orthonormal basis for the */
/*  invariant subspace corresponding to the selected eigenvalues. */

/*  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*16 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. */
/*          The eigenvalue W(j) is selected if SELECT(W(j)) is true. */

/*  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 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*16 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*16 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; if */
/*          JOBVS = 'V', LDVS >= 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. */

/*          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. */

/*  RWORK   (workspace) DOUBLE PRECISION 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 matrix 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. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input arguments */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --w;
    vs_dim1 = *ldvs;
    vs_offset = 1 + vs_dim1;
    vs -= vs_offset;
    --work;
    --rwork;
    --bwork;

    /* Function Body */
    *info = 0;
    lquery = *lwork == -1;
    wantvs = lsame_(jobvs, "V", (ftnlen)1, (ftnlen)1);
    wantst = lsame_(sort, "S", (ftnlen)1, (ftnlen)1);
    if (! wantvs && ! lsame_(jobvs, "N", (ftnlen)1, (ftnlen)1)) {
	*info = -1;
    } else if (! wantst && ! lsame_(sort, "N", (ftnlen)1, (ftnlen)1)) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*lda < max(1,*n)) {
	*info = -6;
    } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
	*info = -10;
    }

/*     Compute workspace */
/*      (Note: Comments in the code beginning "Workspace:" describe the */
/*       minimal amount of workspace needed at that point in the code, */
/*       as well as the preferred amount for good performance. */
/*       CWorkspace refers to complex workspace, and RWorkspace to real */
/*       workspace. NB refers to the optimal block size for the */
/*       immediately following subroutine, as returned by ILAENV. */
/*       HSWORK refers to the workspace preferred by ZHSEQR, as */
/*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/*       the worst case.) */

    minwrk = 1;
    if (*info == 0 && (*lwork >= 1 || lquery)) {
	maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &c__0, (
		ftnlen)6, (ftnlen)1);
/* Computing MAX */
	i__1 = 1, i__2 = *n << 1;
	minwrk = max(i__1,i__2);
	if (! wantvs) {
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", n, &c__1, n, &c_n1, (ftnlen)
		    6, (ftnlen)2);
	    maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
	    i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SN", n, &c__1, n, &
		    c_n1, (ftnlen)6, (ftnlen)2);
	    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, "ZUNGHR", 
		    " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "ZHSEQR", "EN", n, &c__1, n, &c_n1, (ftnlen)
		    6, (ftnlen)2);
	    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, (ftnlen)6, (ftnlen)2);
	    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 = (doublereal) maxwrk, work[1].i = 0.;
    }
    if (*lwork < minwrk && ! lquery) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGEES ", &i__1, (ftnlen)6);
	return 0;
    } else if (lquery) {
	return 0;
    }

/*     Quick return if possible */

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

/*     Get machine constants */

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

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

    anrm = zlange_("M", n, n, &a[a_offset], lda, dum, (ftnlen)1);
    scalea = FALSE_;
    if (anrm > 0. && anrm < smlnum) {
	scalea = TRUE_;
	cscale = smlnum;
    } else if (anrm > bignum) {
	scalea = TRUE_;
	cscale = bignum;
    }
    if (scalea) {
	zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
		ierr, (ftnlen)1);
    }

/*     Permute the matrix to make it more nearly triangular */
/*     (CWorkspace: none) */
/*     (RWorkspace: need N) */

    ibal = 1;
    zgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr, (
	    ftnlen)1);

/*     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;
    zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
	     &ierr);

    if (wantvs) {

/*        Copy Householder vectors to VS */

	zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs, (ftnlen)1)
		;

/*        Generate unitary matrix in VS */
/*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/*        (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	zunghr_(n, &ilo, &ihi, &vs[vs_offset], 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;
    zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
	    vs_offset], ldvs, &work[iwrk], &i__1, &ieval, (ftnlen)1, (ftnlen)
	    1);
    if (ieval > 0) {
	*info = ieval;
    }

/*     Sort eigenvalues if desired */

    if (wantst && *info == 0) {
	if (scalea) {
	    zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
		    ierr, (ftnlen)1);
	}
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    bwork[i__] = (*select)(&w[i__]);
/* L10: */
	}

/*        Reorder eigenvalues and transform Schur vectors */
/*        (CWorkspace: none) */
/*        (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	ztrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], 
		ldvs, &w[1], sdim, &s, &sep, &work[iwrk], &i__1, &icond, (
		ftnlen)1, (ftnlen)1);
    }

    if (wantvs) {

/*        Undo balancing */
/*        (CWorkspace: none) */
/*        (RWorkspace: need N) */

	zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset], 
		ldvs, &ierr, (ftnlen)1, (ftnlen)1);
    }

    if (scalea) {

/*        Undo scaling for the Schur form of A */

	zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
		ierr, (ftnlen)1);
	i__1 = *lda + 1;
	zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
    }

    work[1].r = (doublereal) maxwrk, work[1].i = 0.;
    return 0;

/*     End of ZGEES */

} /* zgees_ */
コード例 #3
0
ファイル: lapack.cpp プロジェクト: the-vk/mathnet-numerics
	DLLEXPORT double z_matrix_norm(char norm, MKL_INT m, MKL_INT n, MKL_Complex16 a[], double work[])
	{
		return zlange_(&norm, &m, &n, a, &m, work);
	}
コード例 #4
0
ファイル: zdrvpb.c プロジェクト: zangel/uquad
/* Subroutine */ int zdrvpb_(logical *dotype, integer *nn, integer *nval, 
	integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax, 
	doublecomplex *a, doublecomplex *afac, doublecomplex *asav, 
	doublecomplex *b, doublecomplex *bsav, doublecomplex *x, 
	doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
	rwork, integer *nout)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };
    static char facts[1*3] = "F" "N" "E";
    static char equeds[1*2] = "N" "Y";

    /* Format strings */
    static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
	    ",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
	    "=\002,g12.5)";
    static char fmt_9997[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
	    " \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
	    " \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
    static char fmt_9998[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
	    " \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
	    ",i1,\002)=\002,g12.5)";

    /* System generated locals */
    address a__1[2];
    integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
    char ch__1[2];

    /* Builtin functions   
       Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
    /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);

    /* Local variables */
    static integer ldab;
    static char fact[1];
    static integer ioff, mode, koff;
    static doublereal amax;
    static char path[3];
    static integer imat, info;
    static char dist[1], uplo[1], type__[1];
    static integer nrun, i__, k, n, ifact, nfail, iseed[4], nfact;
    extern doublereal dget06_(doublereal *, doublereal *);
    static integer kdval[4];
    extern logical lsame_(char *, char *);
    static char equed[1];
    static integer nbmin;
    static doublereal rcond, roldc, scond;
    static integer nimat;
    static doublereal anorm;
    extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
	     integer *, doublecomplex *, integer *, doublereal *, doublereal *
	    );
    static logical equil;
    extern /* Subroutine */ int zpbt01_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *), zpbt02_(char *, integer *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     integer *, doublecomplex *, integer *, doublereal *, doublereal *
	    ), zpbt05_(char *, integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublereal *);
    static integer iuplo, izero, i1, i2, k1, nerrs;
    static logical zerot;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), zpbsv_(char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, integer *,
	     integer *), zswap_(integer *, doublecomplex *, integer *,
	     doublecomplex *, integer *);
    static char xtype[1];
    extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer 
	    *, char *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, char *), aladhd_(integer *, 
	    char *);
    static integer kd, nb, in, kl;
    extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
	    char *, integer *, integer *, integer *, integer *, integer *, 
	    integer *, integer *, integer *, integer *);
    static logical prefac;
    static integer iw, ku, nt;
    static doublereal rcondc;
    static logical nofact;
    static char packit[1];
    static integer iequed;
    extern doublereal zlanhb_(char *, char *, integer *, integer *, 
	    doublecomplex *, integer *, doublereal *), 
	    zlange_(char *, integer *, integer *, doublecomplex *, integer *, 
	    doublereal *);
    extern /* Subroutine */ int zlaqhb_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublereal *, doublereal *, 
	    doublereal *, char *), alasvm_(char *, integer *, 
	    integer *, integer *, integer *);
    static doublereal cndnum;
    extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
	     integer *);
    static doublereal ainvnm;
    extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
	     integer *, integer *, doublecomplex *, integer *, doublecomplex *
	    , integer *), zlarhs_(char *, char *, char *, char *, 
	    integer *, integer *, integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, doublecomplex *, integer *), zpbequ_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *), zpbtrf_(char *, integer *, integer *, doublecomplex *, 
	    integer *, integer *), zlatms_(integer *, integer *, char 
	    *, integer *, char *, doublereal *, integer *, doublereal *, 
	    doublereal *, integer *, integer *, char *, doublecomplex *, 
	    integer *, doublecomplex *, integer *);
    static doublereal result[6];
    extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer 
	    *, doublecomplex *, integer *, doublecomplex *, integer *, 
	    integer *), zpbsvx_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, integer *,
	     char *, doublereal *, doublecomplex *, integer *, doublecomplex *
	    , integer *, doublereal *, doublereal *, doublereal *, 
	    doublecomplex *, doublereal *, integer *),
	     zerrvx_(char *, integer *);
    static integer lda, ikd, nkd;

    /* Fortran I/O blocks */
    static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };



/*  -- LAPACK test routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       June 30, 1999   


    Purpose   
    =======   

    ZDRVPB tests the driver routines ZPBSV and -SVX.   

    Arguments   
    =========   

    DOTYPE  (input) LOGICAL array, dimension (NTYPES)   
            The matrix types to be used for testing.  Matrices of type j   
            (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =   
            .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.   

    NN      (input) INTEGER   
            The number of values of N contained in the vector NVAL.   

    NVAL    (input) INTEGER array, dimension (NN)   
            The values of the matrix dimension N.   

    NRHS    (input) INTEGER   
            The number of right hand side vectors to be generated for   
            each linear system.   

    THRESH  (input) DOUBLE PRECISION   
            The threshold value for the test ratios.  A result is   
            included in the output file if RESULT >= THRESH.  To have   
            every test ratio printed, use THRESH = 0.   

    TSTERR  (input) LOGICAL   
            Flag that indicates whether error exits are to be tested.   

    NMAX    (input) INTEGER   
            The maximum value permitted for N, used in dimensioning the   
            work arrays.   

    A       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)   

    AFAC    (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)   

    ASAV    (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)   

    B       (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)   

    BSAV    (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)   

    X       (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)   

    XACT    (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)   

    S       (workspace) DOUBLE PRECISION array, dimension (NMAX)   

    WORK    (workspace) COMPLEX*16 array, dimension   
                        (NMAX*max(3,NRHS))   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)   

    NOUT    (input) INTEGER   
            The unit number for output.   

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

       Parameter adjustments */
    --rwork;
    --work;
    --s;
    --xact;
    --x;
    --bsav;
    --b;
    --asav;
    --afac;
    --a;
    --nval;
    --dotype;

    /* Function Body   

       Initialize constants and the random number seed. */

    s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
    s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
    nrun = 0;
    nfail = 0;
    nerrs = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
    }

/*     Test the error exits */

    if (*tsterr) {
	zerrvx_(path, nout);
    }
    infoc_1.infot = 0;
    kdval[0] = 0;

/*     Set the block size and minimum block size for testing. */

    nb = 1;
    nbmin = 2;
    xlaenv_(&c__1, &nb);
    xlaenv_(&c__2, &nbmin);

/*     Do for each value of N in NVAL */

    i__1 = *nn;
    for (in = 1; in <= i__1; ++in) {
	n = nval[in];
	lda = max(n,1);
	*(unsigned char *)xtype = 'N';

/*        Set limits on the number of loop iterations.   

   Computing MAX */
	i__2 = 1, i__3 = min(n,4);
	nkd = max(i__2,i__3);
	nimat = 8;
	if (n == 0) {
	    nimat = 1;
	}

	kdval[1] = n + (n + 1) / 4;
	kdval[2] = (n * 3 - 1) / 4;
	kdval[3] = (n + 1) / 4;

	i__2 = nkd;
	for (ikd = 1; ikd <= i__2; ++ikd) {

/*           Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order   
             makes it easier to skip redundant values for small values   
             of N. */

	    kd = kdval[ikd - 1];
	    ldab = kd + 1;

/*           Do first for UPLO = 'U', then for UPLO = 'L' */

	    for (iuplo = 1; iuplo <= 2; ++iuplo) {
		koff = 1;
		if (iuplo == 1) {
		    *(unsigned char *)uplo = 'U';
		    *(unsigned char *)packit = 'Q';
/* Computing MAX */
		    i__3 = 1, i__4 = kd + 2 - n;
		    koff = max(i__3,i__4);
		} else {
		    *(unsigned char *)uplo = 'L';
		    *(unsigned char *)packit = 'B';
		}

		i__3 = nimat;
		for (imat = 1; imat <= i__3; ++imat) {

/*                 Do the tests only if DOTYPE( IMAT ) is true. */

		    if (! dotype[imat]) {
			goto L80;
		    }

/*                 Skip types 2, 3, or 4 if the matrix size is too small. */

		    zerot = imat >= 2 && imat <= 4;
		    if (zerot && n < imat - 1) {
			goto L80;
		    }

		    if (! zerot || ! dotype[1]) {

/*                    Set up parameters with ZLATB4 and generate a test   
                      matrix with ZLATMS. */

			zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
				 &mode, &cndnum, dist);

			s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)
				6);
			zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
				 &cndnum, &anorm, &kd, &kd, packit, &a[koff], 
				&ldab, &work[1], &info);

/*                    Check error code from ZLATMS. */

			if (info != 0) {
			    alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &
				    n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
				    nerrs, nout);
			    goto L80;
			}
		    } else if (izero > 0) {

/*                    Use the same matrix for types 3 and 4 as for type   
                      2 by copying back the zeroed out column, */

			iw = (lda << 1) + 1;
			if (iuplo == 1) {
			    ioff = (izero - 1) * ldab + kd + 1;
			    i__4 = izero - i1;
			    zcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero + 
				    i1], &c__1);
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
			} else {
			    ioff = (i1 - 1) * ldab + 1;
			    i__4 = izero - i1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    zcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero - 
				    i1], &i__5);
			    ioff = (izero - 1) * ldab + 1;
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
			    zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
			}
		    }

/*                 For types 2-4, zero one row and column of the matrix   
                   to test that INFO is returned correctly. */

		    izero = 0;
		    if (zerot) {
			if (imat == 2) {
			    izero = 1;
			} else if (imat == 3) {
			    izero = n;
			} else {
			    izero = n / 2 + 1;
			}

/*                    Save the zeroed out row and column in WORK(*,3) */

			iw = lda << 1;
/* Computing MIN */
			i__5 = (kd << 1) + 1;
			i__4 = min(i__5,n);
			for (i__ = 1; i__ <= i__4; ++i__) {
			    i__5 = iw + i__;
			    work[i__5].r = 0., work[i__5].i = 0.;
/* L20: */
			}
			++iw;
/* Computing MAX */
			i__4 = izero - kd;
			i1 = max(i__4,1);
/* Computing MIN */
			i__4 = izero + kd;
			i2 = min(i__4,n);

			if (iuplo == 1) {
			    ioff = (izero - 1) * ldab + kd + 1;
			    i__4 = izero - i1;
			    zswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
				    iw], &c__1);
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    zswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
			} else {
			    ioff = (i1 - 1) * ldab + 1;
			    i__4 = izero - i1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    zswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
				    iw], &c__1);
			    ioff = (izero - 1) * ldab + 1;
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
			    zswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
			}
		    }

/*                 Set the imaginary part of the diagonals. */

		    if (iuplo == 1) {
			zlaipd_(&n, &a[kd + 1], &ldab, &c__0);
		    } else {
			zlaipd_(&n, &a[1], &ldab, &c__0);
		    }

/*                 Save a copy of the matrix A in ASAV. */

		    i__4 = kd + 1;
		    zlacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);

		    for (iequed = 1; iequed <= 2; ++iequed) {
			*(unsigned char *)equed = *(unsigned char *)&equeds[
				iequed - 1];
			if (iequed == 1) {
			    nfact = 3;
			} else {
			    nfact = 1;
			}

			i__4 = nfact;
			for (ifact = 1; ifact <= i__4; ++ifact) {
			    *(unsigned char *)fact = *(unsigned char *)&facts[
				    ifact - 1];
			    prefac = lsame_(fact, "F");
			    nofact = lsame_(fact, "N");
			    equil = lsame_(fact, "E");

			    if (zerot) {
				if (prefac) {
				    goto L60;
				}
				rcondc = 0.;

			    } else if (! lsame_(fact, "N")) {

/*                          Compute the condition number for comparison   
                            with the value returned by ZPBSVX (FACT =   
                            'N' reuses the condition number from the   
                            previous iteration with FACT = 'F'). */

				i__5 = kd + 1;
				zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &
					afac[1], &ldab);
				if (equil || iequed > 1) {

/*                             Compute row and column scale factors to   
                               equilibrate the matrix A. */

				    zpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
					    s[1], &scond, &amax, &info);
				    if (info == 0 && n > 0) {
					if (iequed > 1) {
					    scond = 0.;
					}

/*                                Equilibrate the matrix. */

					zlaqhb_(uplo, &n, &kd, &afac[1], &
						ldab, &s[1], &scond, &amax, 
						equed);
				    }
				}

/*                          Save the condition number of the   
                            non-equilibrated system for use in ZGET04. */

				if (equil) {
				    roldc = rcondc;
				}

/*                          Compute the 1-norm of A. */

				anorm = zlanhb_("1", uplo, &n, &kd, &afac[1], 
					&ldab, &rwork[1]);

/*                          Factor the matrix A. */

				zpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);

/*                          Form the inverse of A. */

				zlaset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
					 &lda);
				s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)6, (
					ftnlen)6);
				zpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
					a[1], &lda, &info);

/*                          Compute the 1-norm condition number of A. */

				ainvnm = zlange_("1", &n, &n, &a[1], &lda, &
					rwork[1]);
				if (anorm <= 0. || ainvnm <= 0.) {
				    rcondc = 1.;
				} else {
				    rcondc = 1. / anorm / ainvnm;
				}
			    }

/*                       Restore the matrix A. */

			    i__5 = kd + 1;
			    zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
				     &ldab);

/*                       Form an exact solution and set the right hand   
                         side. */

			    s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (
				    ftnlen)6);
			    zlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd, 
				    nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
				     &lda, iseed, &info);
			    *(unsigned char *)xtype = 'C';
			    zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
				    lda);

			    if (nofact) {

/*                          --- Test ZPBSV  ---   

                            Compute the L*L' or U'*U factorization of the   
                            matrix and solve the system. */

				i__5 = kd + 1;
				zlacpy_("Full", &i__5, &n, &a[1], &ldab, &
					afac[1], &ldab);
				zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], 
					&lda);

				s_copy(srnamc_1.srnamt, "ZPBSV ", (ftnlen)6, (
					ftnlen)6);
				zpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
					x[1], &lda, &info);

/*                          Check error code from ZPBSV . */

				if (info != izero) {
				    alaerh_(path, "ZPBSV ", &info, &izero, 
					    uplo, &n, &n, &kd, &kd, nrhs, &
					    imat, &nfail, &nerrs, nout);
				    goto L40;
				} else if (info != 0) {
				    goto L40;
				}

/*                          Reconstruct matrix from factors and compute   
                            residual. */

				zpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
					 &ldab, &rwork[1], result);

/*                          Compute residual of the computed solution. */

				zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
					1], &lda);
				zpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
					1], &lda, &work[1], &lda, &rwork[1], &
					result[1]);

/*                          Check solution from generated exact solution. */

				zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
					 &rcondc, &result[2]);
				nt = 3;

/*                          Print information about the tests that did   
                            not pass the threshold. */

				i__5 = nt;
				for (k = 1; k <= i__5; ++k) {
				    if (result[k - 1] >= *thresh) {
					if (nfail == 0 && nerrs == 0) {
					    aladhd_(nout, path);
					}
					io___57.ciunit = *nout;
					s_wsfe(&io___57);
					do_fio(&c__1, "ZPBSV ", (ftnlen)6);
					do_fio(&c__1, uplo, (ftnlen)1);
					do_fio(&c__1, (char *)&n, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&kd, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&imat, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&k, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&result[k - 1], 
						(ftnlen)sizeof(doublereal));
					e_wsfe();
					++nfail;
				    }
/* L30: */
				}
				nrun += nt;
L40:
				;
			    }

/*                       --- Test ZPBSVX --- */

			    if (! prefac) {
				i__5 = kd + 1;
				zlaset_("Full", &i__5, &n, &c_b47, &c_b47, &
					afac[1], &ldab);
			    }
			    zlaset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
				    lda);
			    if (iequed > 1 && n > 0) {

/*                          Equilibrate the matrix if FACT='F' and   
                            EQUED='Y' */

				zlaqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
					scond, &amax, equed);
			    }

/*                       Solve the system and compute the condition   
                         number and error bounds using ZPBSVX. */

			    s_copy(srnamc_1.srnamt, "ZPBSVX", (ftnlen)6, (
				    ftnlen)6);
			    zpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
				    afac[1], &ldab, equed, &s[1], &b[1], &lda,
				     &x[1], &lda, &rcond, &rwork[1], &rwork[*
				    nrhs + 1], &work[1], &rwork[(*nrhs << 1) 
				    + 1], &info);

/*                       Check the error code from ZPBSVX. */

			    if (info != izero) {
/* Writing concatenation */
				i__7[0] = 1, a__1[0] = fact;
				i__7[1] = 1, a__1[1] = uplo;
				s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
				alaerh_(path, "ZPBSVX", &info, &izero, ch__1, 
					&n, &n, &kd, &kd, nrhs, &imat, &nfail,
					 &nerrs, nout);
				goto L60;
			    }

			    if (info == 0) {
				if (! prefac) {

/*                             Reconstruct matrix from factors and   
                               compute residual. */

				    zpbt01_(uplo, &n, &kd, &a[1], &ldab, &
					    afac[1], &ldab, &rwork[(*nrhs << 
					    1) + 1], result);
				    k1 = 1;
				} else {
				    k1 = 2;
				}

/*                          Compute residual of the computed solution. */

				zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &
					work[1], &lda);
				zpbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab, 
					&x[1], &lda, &work[1], &lda, &rwork[(*
					nrhs << 1) + 1], &result[1]);

/*                          Check solution from generated exact solution. */

				if (nofact || prefac && lsame_(equed, "N")) {
				    zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
					    lda, &rcondc, &result[2]);
				} else {
				    zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
					    lda, &roldc, &result[2]);
				}

/*                          Check the error bounds from iterative   
                            refinement. */

				zpbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab, 
					&b[1], &lda, &x[1], &lda, &xact[1], &
					lda, &rwork[1], &rwork[*nrhs + 1], &
					result[3]);
			    } else {
				k1 = 6;
			    }

/*                       Compare RCOND from ZPBSVX with the computed   
                         value in RCONDC. */

			    result[5] = dget06_(&rcond, &rcondc);

/*                       Print information about the tests that did not   
                         pass the threshold. */

			    for (k = k1; k <= 6; ++k) {
				if (result[k - 1] >= *thresh) {
				    if (nfail == 0 && nerrs == 0) {
					aladhd_(nout, path);
				    }
				    if (prefac) {
					io___60.ciunit = *nout;
					s_wsfe(&io___60);
					do_fio(&c__1, "ZPBSVX", (ftnlen)6);
					do_fio(&c__1, fact, (ftnlen)1);
					do_fio(&c__1, uplo, (ftnlen)1);
					do_fio(&c__1, (char *)&n, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&kd, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, equed, (ftnlen)1);
					do_fio(&c__1, (char *)&imat, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&k, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&result[k - 1], 
						(ftnlen)sizeof(doublereal));
					e_wsfe();
				    } else {
					io___61.ciunit = *nout;
					s_wsfe(&io___61);
					do_fio(&c__1, "ZPBSVX", (ftnlen)6);
					do_fio(&c__1, fact, (ftnlen)1);
					do_fio(&c__1, uplo, (ftnlen)1);
					do_fio(&c__1, (char *)&n, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&kd, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&imat, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&k, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&result[k - 1], 
						(ftnlen)sizeof(doublereal));
					e_wsfe();
				    }
				    ++nfail;
				}
/* L50: */
			    }
			    nrun = nrun + 7 - k1;
L60:
			    ;
			}
/* L70: */
		    }
L80:
		    ;
		}
/* L90: */
	    }
/* L100: */
	}
/* L110: */
    }

/*     Print a summary of the results. */

    alasvm_(path, nout, &nfail, &nrun, &nerrs);

    return 0;

/*     End of ZDRVPB */

} /* zdrvpb_ */
コード例 #5
0
/* Subroutine */ int zdrvrf3_(integer *nout, integer *nn, integer *nval, 
	doublereal *thresh, doublecomplex *a, integer *lda, doublecomplex *
	arf, doublecomplex *b1, doublecomplex *b2, doublereal *
	d_work_zlange__, doublecomplex *z_work_zgeqrf__, doublecomplex *tau)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };
    static char uplos[1*2] = "U" "L";
    static char forms[1*2] = "N" "C";
    static char sides[1*2] = "L" "R";
    static char transs[1*2] = "N" "C";
    static char diags[1*2] = "N" "U";

    /* Format strings */
    static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
	    "ing ZTFSM               ***\002)";
    static char fmt_9997[] = "(1x,\002     Failure in \002,a5,\002, CFORM="
	    "'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
	    "\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
	    "\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
	    "=\002,g12.5)";
    static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
	    "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
	    "\002)";
    static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
	    " of \002,i5,\002 tests failed to pass the threshold\002)";

    /* System generated locals */
    integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1, 
	    i__2, i__3, i__4, i__5, i__6, i__7;
    doublecomplex z__1, z__2;

    /* Local variables */
    integer i__, j, m, n, na, iim, iin;
    doublereal eps;
    char diag[1], side[1];
    integer info;
    char uplo[1];
    integer nrun, idiag;
    doublecomplex alpha;
    integer nfail, iseed[4], iside;
    char cform[1];
    integer iform;
    char trans[1];
    integer iuplo;
    integer ialpha;
    integer itrans;
    doublereal result[1];

    /* Fortran I/O blocks */
    static cilist io___32 = { 0, 0, 0, 0, 0 };
    static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };



/*  -- LAPACK test routine (version 3.2.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2008 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZDRVRF3 tests the LAPACK RFP routines: */
/*      ZTFSM */

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

/*  NOUT          (input) INTEGER */
/*                The unit number for output. */

/*  NN            (input) INTEGER */
/*                The number of values of N contained in the vector NVAL. */

/*  NVAL          (input) INTEGER array, dimension (NN) */
/*                The values of the matrix dimension N. */

/*  THRESH        (input) DOUBLE PRECISION */
/*                The threshold value for the test ratios.  A result is */
/*                included in the output file if RESULT >= THRESH.  To have */
/*                every test ratio printed, use THRESH = 0. */

/*  A             (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */

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

/*  ARF           (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */

/*  B1            (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */

/*  B2            (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */

/*  D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */

/*  Z_WORK_ZGEQRF (workspace) COMPLEX*16 array, dimension (NMAX) */

/*  TAU           (workspace) COMPLEX*16 array, dimension (NMAX) */

/*  ===================================================================== */
/*     .. */
/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --nval;
    b2_dim1 = *lda;
    b2_offset = 1 + b2_dim1;
    b2 -= b2_offset;
    b1_dim1 = *lda;
    b1_offset = 1 + b1_dim1;
    b1 -= b1_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --arf;
    --d_work_zlange__;
    --z_work_zgeqrf__;
    --tau;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Initialize constants and the random number seed. */

    nrun = 0;
    nfail = 0;
    info = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
    }
    eps = dlamch_("Precision");

    i__1 = *nn;
    for (iim = 1; iim <= i__1; ++iim) {

	m = nval[iim];

	i__2 = *nn;
	for (iin = 1; iin <= i__2; ++iin) {

	    n = nval[iin];

	    for (iform = 1; iform <= 2; ++iform) {

		*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];

		for (iuplo = 1; iuplo <= 2; ++iuplo) {

		    *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 
			    1];

		    for (iside = 1; iside <= 2; ++iside) {

			*(unsigned char *)side = *(unsigned char *)&sides[
				iside - 1];

			for (itrans = 1; itrans <= 2; ++itrans) {

			    *(unsigned char *)trans = *(unsigned char *)&
				    transs[itrans - 1];

			    for (idiag = 1; idiag <= 2; ++idiag) {

				*(unsigned char *)diag = *(unsigned char *)&
					diags[idiag - 1];

				for (ialpha = 1; ialpha <= 3; ++ialpha) {

				    if (ialpha == 1) {
					alpha.r = 0., alpha.i = 0.;
				    } else if (ialpha == 1) {
					alpha.r = 1., alpha.i = 0.;
				    } else {
					zlarnd_(&z__1, &c__4, iseed);
					alpha.r = z__1.r, alpha.i = z__1.i;
				    }

/*                             All the parameters are set: */
/*                                CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
/*                                and ALPHA */
/*                             READY TO TEST! */

				    ++nrun;

				    if (iside == 1) {

/*                                The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
/*                                -> A is M-by-M ( B is M-by-N ) */

					na = m;

				    } else {

/*                                The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
/*                                -> A is N-by-N ( B is M-by-N ) */

					na = n;

				    }

/*                             Generate A our NA--by--NA triangular */
/*                             matrix. */
/*                             Our test is based on forward error so we */
/*                             do want A to be well conditionned! To get */
/*                             a well-conditionned triangular matrix, we */
/*                             take the R factor of the QR/LQ factorization */
/*                             of a random matrix. */

				    i__3 = na;
				    for (j = 1; j <= i__3; ++j) {
					i__4 = na;
					for (i__ = 1; i__ <= i__4; ++i__) {
					    i__5 = i__ + j * a_dim1;
					    zlarnd_(&z__1, &c__4, iseed);
					    a[i__5].r = z__1.r, a[i__5].i = 
						    z__1.i;
					}
				    }

				    if (iuplo == 1) {

/*                                The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
/*                                -> QR factorization. */

					s_copy(srnamc_1.srnamt, "ZGEQRF", (
						ftnlen)32, (ftnlen)6);
					zgeqrf_(&na, &na, &a[a_offset], lda, &
						tau[1], &z_work_zgeqrf__[1], 
						lda, &info);
				    } else {

/*                                The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
/*                                -> QL factorization. */

					s_copy(srnamc_1.srnamt, "ZGELQF", (
						ftnlen)32, (ftnlen)6);
					zgelqf_(&na, &na, &a[a_offset], lda, &
						tau[1], &z_work_zgeqrf__[1], 
						lda, &info);
				    }

/*                             After the QR factorization, the diagonal */
/*                             of A is made of real numbers, we multiply */
/*                             by a random complex number of absolute */
/*                             value 1.0E+00. */

				    i__3 = na;
				    for (j = 1; j <= i__3; ++j) {
					i__4 = j + j * a_dim1;
					i__5 = j + j * a_dim1;
					zlarnd_(&z__2, &c__5, iseed);
					z__1.r = a[i__5].r * z__2.r - a[i__5]
						.i * z__2.i, z__1.i = a[i__5]
						.r * z__2.i + a[i__5].i * 
						z__2.r;
					a[i__4].r = z__1.r, a[i__4].i = 
						z__1.i;
				    }

/*                             Store a copy of A in RFP format (in ARF). */

				    s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)
					    32, (ftnlen)6);
				    ztrttf_(cform, uplo, &na, &a[a_offset], 
					    lda, &arf[1], &info);

/*                             Generate B1 our M--by--N right-hand side */
/*                             and store a copy in B2. */

				    i__3 = n;
				    for (j = 1; j <= i__3; ++j) {
					i__4 = m;
					for (i__ = 1; i__ <= i__4; ++i__) {
					    i__5 = i__ + j * b1_dim1;
					    zlarnd_(&z__1, &c__4, iseed);
					    b1[i__5].r = z__1.r, b1[i__5].i = 
						    z__1.i;
					    i__5 = i__ + j * b2_dim1;
					    i__6 = i__ + j * b1_dim1;
					    b2[i__5].r = b1[i__6].r, b2[i__5]
						    .i = b1[i__6].i;
					}
				    }

/*                             Solve op( A ) X = B or X op( A ) = B */
/*                             with ZTRSM */

				    s_copy(srnamc_1.srnamt, "ZTRSM", (ftnlen)
					    32, (ftnlen)5);
				    ztrsm_(side, uplo, trans, diag, &m, &n, &
					    alpha, &a[a_offset], lda, &b1[
					    b1_offset], lda);

/*                             Solve op( A ) X = B or X op( A ) = B */
/*                             with ZTFSM */

				    s_copy(srnamc_1.srnamt, "ZTFSM", (ftnlen)
					    32, (ftnlen)5);
				    ztfsm_(cform, side, uplo, trans, diag, &m, 
					     &n, &alpha, &arf[1], &b2[
					    b2_offset], lda);

/*                             Check that the result agrees. */

				    i__3 = n;
				    for (j = 1; j <= i__3; ++j) {
					i__4 = m;
					for (i__ = 1; i__ <= i__4; ++i__) {
					    i__5 = i__ + j * b1_dim1;
					    i__6 = i__ + j * b2_dim1;
					    i__7 = i__ + j * b1_dim1;
					    z__1.r = b2[i__6].r - b1[i__7].r, 
						    z__1.i = b2[i__6].i - b1[
						    i__7].i;
					    b1[i__5].r = z__1.r, b1[i__5].i = 
						    z__1.i;
					}
				    }

				    result[0] = zlange_("I", &m, &n, &b1[
					    b1_offset], lda, &d_work_zlange__[
					    1]);

/* Computing MAX */
				    i__3 = max(m,n);
				    result[0] = result[0] / sqrt(eps) / max(
					    i__3,1);

				    if (result[0] >= *thresh) {
					if (nfail == 0) {
					    io___32.ciunit = *nout;
					    s_wsle(&io___32);
					    e_wsle();
					    io___33.ciunit = *nout;
					    s_wsfe(&io___33);
					    e_wsfe();
					}
					io___34.ciunit = *nout;
					s_wsfe(&io___34);
					do_fio(&c__1, "ZTFSM", (ftnlen)5);
					do_fio(&c__1, cform, (ftnlen)1);
					do_fio(&c__1, side, (ftnlen)1);
					do_fio(&c__1, uplo, (ftnlen)1);
					do_fio(&c__1, trans, (ftnlen)1);
					do_fio(&c__1, diag, (ftnlen)1);
					do_fio(&c__1, (char *)&m, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&n, (ftnlen)
						sizeof(integer));
					do_fio(&c__1, (char *)&result[0], (
						ftnlen)sizeof(doublereal));
					e_wsfe();
					++nfail;
				    }

/* L100: */
				}
/* L110: */
			    }
/* L120: */
			}
/* L130: */
		    }
/* L140: */
		}
/* L150: */
	    }
/* L160: */
	}
/* L170: */
    }

/*     Print a summary of the results. */

    if (nfail == 0) {
	io___35.ciunit = *nout;
	s_wsfe(&io___35);
	do_fio(&c__1, "ZTFSM", (ftnlen)5);
	do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
	e_wsfe();
    } else {
	io___36.ciunit = *nout;
	s_wsfe(&io___36);
	do_fio(&c__1, "ZTFSM", (ftnlen)5);
	do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
	e_wsfe();
    }


    return 0;

/*     End of ZDRVRF3 */

} /* zdrvrf3_ */
コード例 #6
0
ファイル: zqrt14.c プロジェクト: zangel/uquad
doublereal zqrt14_(char *trans, integer *m, integer *n, integer *nrhs, 
	doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx, 
	doublecomplex *work, integer *lwork)
{
    /* System generated locals */
    integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
    doublereal ret_val, d__1, d__2;
    doublecomplex z__1;

    /* Builtin functions */
    double z_abs(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *);

    /* Local variables */
    static integer info;
    static doublereal anrm;
    static logical tpsd;
    static doublereal xnrm;
    static integer i__, j;
    extern logical lsame_(char *, char *);
    static doublereal rwork[1];
    extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
	     integer *, doublecomplex *, doublecomplex *, integer *), zgeqr2_(
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     doublecomplex *, integer *);
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
	     integer *, integer *);
    static integer ldwork;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublereal err;


#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]


/*  -- LAPACK test routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       February 29, 1992   


    Purpose   
    =======   

    ZQRT14 checks whether X is in the row space of A or A'.  It does so   
    by scaling both X and A such that their norms are in the range   
    [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X]   
    (if TRANS = 'C') or an LQ factorization of [A',X]' (if TRANS = 'N'),   
    and returning the norm of the trailing triangle, scaled by   
    MAX(M,N,NRHS)*eps.   

    Arguments   
    =========   

    TRANS   (input) CHARACTER*1   
            = 'N':  No transpose, check for X in the row space of A   
            = 'C':  Conjugate transpose, check for X in row space of A'.   

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

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

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of columns   
            of X.   

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

    LDA     (input) INTEGER   
            The leading dimension of the array A.   

    X       (input) COMPLEX*16 array, dimension (LDX,NRHS)   
            If TRANS = 'N', the N-by-NRHS matrix X.   
            IF TRANS = 'C', the M-by-NRHS matrix X.   

    LDX     (input) INTEGER   
            The leading dimension of the array X.   

    WORK    (workspace) COMPLEX*16 array dimension (LWORK)   

    LWORK   (input) INTEGER   
            length of workspace array required   
            If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);   
            if TRANS = 'C', LWORK >= (N+NRHS)*(M+2).   

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


       Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1 * 1;
    x -= x_offset;
    --work;

    /* Function Body */
    ret_val = 0.;
    if (lsame_(trans, "N")) {
	ldwork = *m + *nrhs;
	tpsd = FALSE_;
	if (*lwork < (*m + *nrhs) * (*n + 2)) {
	    xerbla_("ZQRT14", &c__10);
	    return ret_val;
	} else if (*n <= 0 || *nrhs <= 0) {
	    return ret_val;
	}
    } else if (lsame_(trans, "C")) {
	ldwork = *m;
	tpsd = TRUE_;
	if (*lwork < (*n + *nrhs) * (*m + 2)) {
	    xerbla_("ZQRT14", &c__10);
	    return ret_val;
	} else if (*m <= 0 || *nrhs <= 0) {
	    return ret_val;
	}
    } else {
	xerbla_("ZQRT14", &c__1);
	return ret_val;
    }

/*     Copy and scale A */

    zlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
    anrm = zlange_("M", m, n, &work[1], &ldwork, rwork);
    if (anrm != 0.) {
	zlascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
		info);
    }

/*     Copy X or X' into the right place and scale it */

    if (tpsd) {

/*        Copy X into columns n+1:n+nrhs of work */

	zlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
		ldwork);
	xnrm = zlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
	if (xnrm != 0.) {
	    zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n * 
		    ldwork + 1], &ldwork, &info);
	}
	i__1 = *n + *nrhs;
	anrm = zlange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);

/*        Compute QR factorization of X */

	i__1 = *n + *nrhs;
/* Computing MIN */
	i__2 = *m, i__3 = *n + *nrhs;
	zgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
		 &work[ldwork * (*n + *nrhs) + min(i__2,i__3) + 1], &info);

/*        Compute largest entry in upper triangle of   
          work(n+1:m,n+1:n+nrhs) */

	err = 0.;
	i__1 = *n + *nrhs;
	for (j = *n + 1; j <= i__1; ++j) {
	    i__2 = min(*m,j);
	    for (i__ = *n + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
		d__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * *m]);
		err = max(d__1,d__2);
/* L10: */
	    }
/* L20: */
	}

    } else {

/*        Copy X' into rows m+1:m+nrhs of work */

	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = *nrhs;
	    for (j = 1; j <= i__2; ++j) {
		i__3 = *m + j + (i__ - 1) * ldwork;
		d_cnjg(&z__1, &x_ref(i__, j));
		work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L30: */
	    }
/* L40: */
	}

	xnrm = zlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
		;
	if (xnrm != 0.) {
	    zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1], 
		    &ldwork, &info);
	}

/*        Compute LQ factorization of work */

	zgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
		ldwork * (*n + 1) + 1], &info);

/*        Compute largest entry in lower triangle in   
          work(m+1:m+nrhs,m+1:n) */

	err = 0.;
	i__1 = *n;
	for (j = *m + 1; j <= i__1; ++j) {
	    i__2 = ldwork;
	    for (i__ = j; i__ <= i__2; ++i__) {
/* Computing MAX */
		d__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * ldwork]);
		err = max(d__1,d__2);
/* L50: */
	    }
/* L60: */
	}

    }

/* Computing MAX */
    i__1 = max(*m,*n);
    ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));

    return ret_val;

/*     End of ZQRT14 */

} /* zqrt14_ */
コード例 #7
0
ファイル: zget51.c プロジェクト: 3deggi/levmar-ndk
/* Subroutine */ int zget51_(integer *itype, integer *n, doublecomplex *a, 
	integer *lda, doublecomplex *b, integer *ldb, doublecomplex *u, 
	integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *work, 
	doublereal *rwork, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, u_dim1, u_offset, v_dim1, 
	    v_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2;
    doublecomplex z__1;

    /* Local variables */
    doublereal ulp;
    integer jcol;
    doublereal unfl;
    integer jrow, jdiag;
    doublereal anorm;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    doublereal wnorm;
    extern doublereal dlamch_(char *), zlange_(char *, integer *, 
	    integer *, doublecomplex *, integer *, doublereal *);
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*       ZGET51  generally checks a decomposition of the form */

/*               A = U B V* */

/*       where * means conjugate transpose and U and V are unitary. */

/*       Specifically, if ITYPE=1 */

/*               RESULT = | A - U B V* | / ( |A| n ulp ) */

/*       If ITYPE=2, then: */

/*               RESULT = | A - B | / ( |A| n ulp ) */

/*       If ITYPE=3, then: */

/*               RESULT = | I - UU* | / ( n ulp ) */

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

/*  ITYPE   (input) INTEGER */
/*          Specifies the type of tests to be performed. */
/*          =1: RESULT = | A - U B V* | / ( |A| n ulp ) */
/*          =2: RESULT = | A - B | / ( |A| n ulp ) */
/*          =3: RESULT = | I - UU* | / ( n ulp ) */

/*  N       (input) INTEGER */
/*          The size of the matrix.  If it is zero, ZGET51 does nothing. */
/*          It must be at least zero. */

/*  A       (input) COMPLEX*16 array, dimension (LDA, N) */
/*          The original (unfactored) matrix. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A.  It must be at least 1 */
/*          and at least N. */

/*  B       (input) COMPLEX*16 array, dimension (LDB, N) */
/*          The factored matrix. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of B.  It must be at least 1 */
/*          and at least N. */

/*  U       (input) COMPLEX*16 array, dimension (LDU, N) */
/*          The unitary matrix on the left-hand side in the */
/*          decomposition. */
/*          Not referenced if ITYPE=2 */

/*  LDU     (input) INTEGER */
/*          The leading dimension of U.  LDU must be at least N and */
/*          at least 1. */

/*  V       (input) COMPLEX*16 array, dimension (LDV, N) */
/*          The unitary matrix on the left-hand side in the */
/*          decomposition. */
/*          Not referenced if ITYPE=2 */

/*  LDV     (input) INTEGER */
/*          The leading dimension of V.  LDV must be at least N and */
/*          at least 1. */

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

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

/*  RESULT  (output) DOUBLE PRECISION */
/*          The values computed by the test specified by ITYPE.  The */
/*          value is currently limited to 1/ulp, to avoid overflow. */
/*          Errors are flagged by RESULT=10/ulp. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    v_dim1 = *ldv;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    --work;
    --rwork;

    /* Function Body */
    *result = 0.;
    if (*n <= 0) {
	return 0;
    }

/*     Constants */

    unfl = dlamch_("Safe minimum");
    ulp = dlamch_("Epsilon") * dlamch_("Base");

/*     Some Error Checks */

    if (*itype < 1 || *itype > 3) {
	*result = 10. / ulp;
	return 0;
    }

    if (*itype <= 2) {

/*        Tests scaled by the norm(A) */

/* Computing MAX */
	d__1 = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
	anorm = max(d__1,unfl);

	if (*itype == 1) {

/*           ITYPE=1: Compute W = A - UBV' */

	    zlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
/* Computing 2nd power */
	    i__1 = *n;
	    zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &b[b_offset], 
		    ldb, &c_b1, &work[i__1 * i__1 + 1], n);

	    z__1.r = -1., z__1.i = -0.;
/* Computing 2nd power */
	    i__1 = *n;
	    zgemm_("N", "C", n, n, n, &z__1, &work[i__1 * i__1 + 1], n, &v[
		    v_offset], ldv, &c_b2, &work[1], n);

	} else {

/*           ITYPE=2: Compute W = A - B */

	    zlacpy_(" ", n, n, &b[b_offset], ldb, &work[1], n);

	    i__1 = *n;
	    for (jcol = 1; jcol <= i__1; ++jcol) {
		i__2 = *n;
		for (jrow = 1; jrow <= i__2; ++jrow) {
		    i__3 = jrow + *n * (jcol - 1);
		    i__4 = jrow + *n * (jcol - 1);
		    i__5 = jrow + jcol * a_dim1;
		    z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i 
			    - a[i__5].i;
		    work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L10: */
		}
/* L20: */
	    }
	}

/*        Compute norm(W)/ ( ulp*norm(A) ) */

	wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);

	if (anorm > wnorm) {
	    *result = wnorm / anorm / (*n * ulp);
	} else {
	    if (anorm < 1.) {
/* Computing MIN */
		d__1 = wnorm, d__2 = *n * anorm;
		*result = min(d__1,d__2) / anorm / (*n * ulp);
	    } else {
/* Computing MIN */
		d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
		*result = min(d__1,d__2) / (*n * ulp);
	    }
	}

    } else {

/*        Tests not scaled by norm(A) */

/*        ITYPE=3: Compute  UU' - I */

	zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, 
		 &c_b1, &work[1], n);

	i__1 = *n;
	for (jdiag = 1; jdiag <= i__1; ++jdiag) {
	    i__2 = (*n + 1) * (jdiag - 1) + 1;
	    i__3 = (*n + 1) * (jdiag - 1) + 1;
	    z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
	    work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
	}

/* Computing MIN */
	d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
		doublereal) (*n);
	*result = min(d__1,d__2) / (*n * ulp);
    }

    return 0;

/*     End of ZGET51 */

} /* zget51_ */
コード例 #8
0
ファイル: ztrsen.c プロジェクト: Electrostatics/FETK
/* 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 */
    static integer k, n1, n2, nn, ks;
    static doublereal est;
    static integer kase, ierr;
    static doublereal scale;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    static integer lwmin;
    static logical wantq, wants;
    static doublereal rnorm, rwork[1];
    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
                              integer *, doublereal *, ftnlen);
    static logical wantbh;
    extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
                                        doublecomplex *, doublereal *, integer *), zlacpy_(char *,
                                                integer *, integer *, doublecomplex *, integer *, doublecomplex *,
                                                integer *, ftnlen);
    static logical wantsp;
    extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
                                        integer *, doublecomplex *, integer *, integer *, integer *,
                                        integer *, ftnlen);
    static logical lquery;
    extern /* Subroutine */ int ztrsyl_(char *, char *, integer *, integer *,
                                        integer *, doublecomplex *, integer *, doublecomplex *, integer *,
                                        doublecomplex *, integer *, doublereal *, integer *, ftnlen,
                                        ftnlen);


    /*  -- LAPACK routine (version 3.0) -- */
    /*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
    /*     Courant Institute, Argonne National Lab, and Rice University */
    /*     June 30, 1999 */

    /*     .. Scalar Arguments .. */
    /*     .. */
    /*     .. Array Arguments .. */
    /*     .. */

    /*  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 (LWORK) */
    /*          If JOB = 'N', WORK is not referenced.  Otherwise, */
    /*          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 = M*(N-M); */
    /*          if JOB = 'V' or 'B', LWORK >= 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 .. */
    /*     .. */
    /*     .. Local Scalars .. */
    /*     .. */
    /*     .. Local Arrays .. */
    /*     .. */
    /*     .. External Functions .. */
    /*     .. */
    /*     .. External Subroutines .. */
    /*     .. */
    /*     .. Intrinsic Functions .. */
    /*     .. */
    /*     .. Executable Statements .. */

    /*     Decode and test the input parameters. */

    /* 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", (ftnlen)1, (ftnlen)1) || wantbh;
    wantsp = lsame_(job, "V", (ftnlen)1, (ftnlen)1) || wantbh;
    wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1);

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

    *m = 0;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
        if (select[k]) {
            ++(*m);
        }
        /* L10: */
    }

    n1 = *m;
    n2 = *n - *m;
    nn = n1 * n2;

    *info = 0;
    lquery = *lwork == -1;

    if (wantsp) {
        /* Computing MAX */
        i__1 = 1, i__2 = nn << 1;
        lwmin = max(i__1,i__2);
    } else if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
        lwmin = 1;
    } else if (lsame_(job, "E", (ftnlen)1, (ftnlen)1)) {
        lwmin = max(1,nn);
    }

    if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! wants && ! wantsp) {
        *info = -1;
    } else if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) {
        *info = -2;
    } else if (*n < 0) {
        *info = -4;
    } else if (*ldt < max(1,*n)) {
        *info = -6;
    } else if (*ldq < 1 || wantq && *ldq < *n) {
        *info = -8;
    } else if (*lwork < lwmin && ! lquery) {
        *info = -14;
    }

    if (*info == 0) {
        work[1].r = (doublereal) lwmin, work[1].i = 0.;
    }

    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("ZTRSEN", &i__1, (ftnlen)6);
        return 0;
    } else if (lquery) {
        return 0;
    }

    /*     Quick return if possible */

    if (*m == *n || *m == 0) {
        if (wants) {
            *s = 1.;
        }
        if (wantsp) {
            *sep = zlange_("1", n, n, &t[t_offset], ldt, rwork, (ftnlen)1);
        }
        goto L40;
    }

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

    ks = 0;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
        if (select[k]) {
            ++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);
            }
        }
        /* L20: */
    }

    if (wants) {

        /*        Solve the Sylvester equation for R: */

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

        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[1], &n1, rwork, (ftnlen)1);
        if (rnorm == 0.) {
            *s = 1.;
        } else {
            *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
        }
    }

    if (wantsp) {

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

        est = 0.;
        kase = 0;
L30:
        zlacon_(&nn, &work[nn + 1], &work[1], &est, &kase);
        if (kase != 0) {
            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 {

                /*              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);
            }
            goto L30;
        }

        *sep = scale / est;
    }

L40:

    /*     Copy reordered eigenvalues to W. */

    i__1 = *n;
    for (k = 1; k <= i__1; ++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;
        /* L50: */
    }

    work[1].r = (doublereal) lwmin, work[1].i = 0.;

    return 0;

    /*     End of ZTRSEN */

} /* ztrsen_ */
コード例 #9
0
ファイル: zgrqts.c プロジェクト: zangel/uquad
/* Subroutine */ int zgrqts_(integer *m, integer *p, integer *n,
                             doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
                             r__, integer *lda, doublecomplex *taua, doublecomplex *b,
                             doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
                             doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
                             work, integer *lwork, doublereal *rwork, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
            bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
            r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
    doublereal d__1;
    doublecomplex z__1;

    /* Local variables */
    static integer info;
    static doublereal unfl, resid, anorm, bnorm;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
                                       integer *, doublecomplex *, doublecomplex *, integer *,
                                       doublecomplex *, integer *, doublecomplex *, doublecomplex *,
                                       integer *), zherk_(char *, char *, integer *,
                                               integer *, doublereal *, doublecomplex *, integer *, doublereal *,
                                               doublecomplex *, integer *);
    extern doublereal dlamch_(char *), zlange_(char *, integer *,
            integer *, doublecomplex *, integer *, doublereal *),
                    zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
                            doublereal *);
    extern /* Subroutine */ int zggrqf_(integer *, integer *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, doublecomplex *,
                                        integer *, doublecomplex *, doublecomplex *, integer *, integer *)
    , zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
              , doublecomplex *, integer *), zlaset_(char *, integer *,
                      integer *, doublecomplex *, doublecomplex *, doublecomplex *,
                      integer *), zungqr_(integer *, integer *, integer *,
                                          doublecomplex *, integer *, doublecomplex *, doublecomplex *,
                                          integer *, integer *), zungrq_(integer *, integer *, integer *,
                                                  doublecomplex *, integer *, doublecomplex *, doublecomplex *,
                                                  integer *, integer *);
    static doublereal ulp;


#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1
#define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
#define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1
#define bf_ref(a_1,a_2) bf[bf_subscr(a_1,a_2)]


    /*  -- LAPACK test routine (version 3.0) --
           Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
           Courant Institute, Argonne National Lab, and Rice University
           September 30, 1994


        Purpose
        =======

        ZGRQTS tests ZGGRQF, which computes the GRQ factorization of an
        M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.

        Arguments
        =========

        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) COMPLEX*16 array, dimension (LDA,N)
                The M-by-N matrix A.

        AF      (output) COMPLEX*16 array, dimension (LDA,N)
                Details of the GRQ factorization of A and B, as returned
                by ZGGRQF, see CGGRQF for further details.

        Q       (output) COMPLEX*16 array, dimension (LDA,N)
                The N-by-N unitary matrix Q.

        R       (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N))

        LDA     (input) INTEGER
                The leading dimension of the arrays A, AF, R and Q.
                LDA >= max(M,N).

        TAUA    (output) COMPLEX*16 array, dimension (min(M,N))
                The scalar factors of the elementary reflectors, as returned
                by DGGQRC.

        B       (input) COMPLEX*16 array, dimension (LDB,N)
                On entry, the P-by-N matrix A.

        BF      (output) COMPLEX*16 array, dimension (LDB,N)
                Details of the GQR factorization of A and B, as returned
                by ZGGRQF, see CGGRQF for further details.

        Z       (output) DOUBLE PRECISION array, dimension (LDB,P)
                The P-by-P unitary matrix Z.

        T       (workspace) COMPLEX*16 array, dimension (LDB,max(P,N))

        BWK     (workspace) COMPLEX*16 array, dimension (LDB,N)

        LDB     (input) INTEGER
                The leading dimension of the arrays B, BF, Z and T.
                LDB >= max(P,N).

        TAUB    (output) COMPLEX*16 array, dimension (min(P,N))
                The scalar factors of the elementary reflectors, as returned
                by DGGRQF.

        WORK    (workspace) COMPLEX*16 array, dimension (LWORK)

        LWORK   (input) INTEGER
                The dimension of the array WORK, LWORK >= max(M,P,N)**2.

        RWORK   (workspace) DOUBLE PRECISION array, dimension (M)

        RESULT  (output) DOUBLE PRECISION array, dimension (4)
                The test ratios:
                  RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
                  RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
                  RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
                  RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )

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


           Parameter adjustments */
    r_dim1 = *lda;
    r_offset = 1 + r_dim1 * 1;
    r__ -= r_offset;
    q_dim1 = *lda;
    q_offset = 1 + q_dim1 * 1;
    q -= q_offset;
    af_dim1 = *lda;
    af_offset = 1 + af_dim1 * 1;
    af -= af_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --taua;
    bwk_dim1 = *ldb;
    bwk_offset = 1 + bwk_dim1 * 1;
    bwk -= bwk_offset;
    t_dim1 = *ldb;
    t_offset = 1 + t_dim1 * 1;
    t -= t_offset;
    z_dim1 = *ldb;
    z_offset = 1 + z_dim1 * 1;
    z__ -= z_offset;
    bf_dim1 = *ldb;
    bf_offset = 1 + bf_dim1 * 1;
    bf -= bf_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --taub;
    --work;
    --rwork;
    --result;

    /* Function Body */
    ulp = dlamch_("Precision");
    unfl = dlamch_("Safe minimum");

    /*     Copy the matrix A to the array AF. */

    zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
    zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);

    /* Computing MAX */
    d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
    anorm = max(d__1,unfl);
    /* Computing MAX */
    d__1 = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
    bnorm = max(d__1,unfl);

    /*     Factorize the matrices A and B in the arrays AF and BF. */

    zggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
            taub[1], &work[1], lwork, &info);

    /*     Generate the N-by-N matrix Q */

    zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
    if (*m <= *n) {
        if (*m > 0 && *m < *n) {
            i__1 = *n - *m;
            zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q_ref(*n - *m + 1,
                    1), lda);
        }
        if (*m > 1) {
            i__1 = *m - 1;
            i__2 = *m - 1;
            zlacpy_("Lower", &i__1, &i__2, &af_ref(2, *n - *m + 1), lda, &
                    q_ref(*n - *m + 2, *n - *m + 1), lda);
        }
    } else {
        if (*n > 1) {
            i__1 = *n - 1;
            i__2 = *n - 1;
            zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, &
                    q_ref(2, 1), lda);
        }
    }
    i__1 = min(*m,*n);
    zungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);

    /*     Generate the P-by-P matrix Z */

    zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
    if (*p > 1) {
        i__1 = *p - 1;
        zlacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb);
    }
    i__1 = min(*p,*n);
    zungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
            info);

    /*     Copy R */

    zlaset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
    if (*m <= *n) {
        zlacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n -
                *m + 1), lda);
    } else {
        i__1 = *m - *n;
        zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
        zlacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n
                + 1, 1), lda);
    }

    /*     Copy T */

    zlaset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
    zlacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);

    /*     Compute R - A*Q' */

    z__1.r = -1., z__1.i = 0.;
    zgemm_("No transpose", "Conjugate transpose", m, n, n, &z__1, &a[a_offset]
           , lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);

    /*     Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */

    resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
    if (anorm > 0.) {
        /* Computing MAX */
        i__1 = max(1,*m);
        result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
    } else {
        result[1] = 0.;
    }

    /*     Compute T*Q - Z'*B */

    zgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
               z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
    z__1.r = -1., z__1.i = 0.;
    zgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
           &q[q_offset], lda, &z__1, &bwk[bwk_offset], ldb);

    /*     Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */

    resid = zlange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
    if (bnorm > 0.) {
        /* Computing MAX */
        i__1 = max(1,*p);
        result[2] = resid / (doublereal) max(i__1,*m) / bnorm / ulp;
    } else {
        result[2] = 0.;
    }

    /*     Compute I - Q*Q' */

    zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
    zherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
           r__[r_offset], lda);

    /*     Compute norm( I - Q'*Q ) / ( N * ULP ) . */

    resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
    result[3] = resid / (doublereal) max(1,*n) / ulp;

    /*     Compute I - Z'*Z */

    zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
    zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
           &c_b35, &t[t_offset], ldb);

    /*     Compute norm( I - Z'*Z ) / ( P*ULP ) . */

    resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
    result[4] = resid / (doublereal) max(1,*p) / ulp;

    return 0;

    /*     End of ZGRQTS */

} /* zgrqts_ */
コード例 #10
0
ファイル: zrqt01.c プロジェクト: kstraube/hysim
/* Subroutine */ int zrqt01_(integer *m, integer *n, doublecomplex *a, 
	doublecomplex *af, doublecomplex *q, doublecomplex *r__, integer *lda, 
	 doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
	rwork, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1, 
	    r_offset, i__1, i__2;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    doublereal eps;
    integer info;
    doublereal resid, anorm;
    integer minmn;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zherk_(char *, char *, integer *, 
	    integer *, doublereal *, doublecomplex *, integer *, doublereal *, 
	     doublecomplex *, integer *);
    extern doublereal dlamch_(char *), zlange_(char *, integer *, 
	    integer *, doublecomplex *, integer *, doublereal *);
    extern /* Subroutine */ int zgerqf_(integer *, integer *, doublecomplex *, 
	     integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlacpy_(char *, integer *, integer *, doublecomplex *, integer 
	    *, doublecomplex *, integer *), zlaset_(char *, integer *, 
	     integer *, doublecomplex *, doublecomplex *, doublecomplex *, 
	    integer *);
    extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zungrq_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZRQT01 tests ZGERQF, which computes the RQ factorization of an m-by-n */
/*  matrix A, and partially tests ZUNGRQ which forms the n-by-n */
/*  orthogonal matrix Q. */

/*  ZRQT01 compares R with A*Q', and checks that Q is orthogonal. */

/*  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) COMPLEX*16 array, dimension (LDA,N) */
/*          The m-by-n matrix A. */

/*  AF      (output) COMPLEX*16 array, dimension (LDA,N) */
/*          Details of the RQ factorization of A, as returned by ZGERQF. */
/*          See ZGERQF for further details. */

/*  Q       (output) COMPLEX*16 array, dimension (LDA,N) */
/*          The n-by-n orthogonal matrix Q. */

/*  R       (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the arrays A, AF, Q and L. */
/*          LDA >= max(M,N). */

/*  TAU     (output) COMPLEX*16 array, dimension (min(M,N)) */
/*          The scalar factors of the elementary reflectors, as returned */
/*          by ZGERQF. */

/*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. */

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

/*  RESULT  (output) DOUBLE PRECISION array, dimension (2) */
/*          The test ratios: */
/*          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/*          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    r_dim1 = *lda;
    r_offset = 1 + r_dim1;
    r__ -= r_offset;
    q_dim1 = *lda;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    af_dim1 = *lda;
    af_offset = 1 + af_dim1;
    af -= af_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --tau;
    --work;
    --rwork;
    --result;

    /* Function Body */
    minmn = min(*m,*n);
    eps = dlamch_("Epsilon");

/*     Copy the matrix A to the array AF. */

    zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);

/*     Factorize the matrix A in the array AF. */

    s_copy(srnamc_1.srnamt, "ZGERQF", (ftnlen)6, (ftnlen)6);
    zgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);

/*     Copy details of Q */

    zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
    if (*m <= *n) {
	if (*m > 0 && *m < *n) {
	    i__1 = *n - *m;
	    zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 + 
		    q_dim1], lda);
	}
	if (*m > 1) {
	    i__1 = *m - 1;
	    i__2 = *m - 1;
	    zlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2], 
		    lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
	}
    } else {
	if (*n > 1) {
	    i__1 = *n - 1;
	    i__2 = *n - 1;
	    zlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
		    q[q_dim1 + 2], lda);
	}
    }

/*     Generate the n-by-n matrix Q */

    s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6);
    zungrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);

/*     Copy R */

    zlaset_("Full", m, n, &c_b12, &c_b12, &r__[r_offset], lda);
    if (*m <= *n) {
	if (*m > 0) {
	    zlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
		    r__[(*n - *m + 1) * r_dim1 + 1], lda);
	}
    } else {
	if (*m > *n && *n > 0) {
	    i__1 = *m - *n;
	    zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], 
		    lda);
	}
	if (*n > 0) {
	    zlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - 
		    *n + 1 + r_dim1], lda);
	}
    }

/*     Compute R - A*Q' */

    zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b19, &a[
	    a_offset], lda, &q[q_offset], lda, &c_b20, &r__[r_offset], lda);

/*     Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */

    anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
    resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
    if (anorm > 0.) {
	result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
    } else {
	result[1] = 0.;
    }

/*     Compute I - Q*Q' */

    zlaset_("Full", n, n, &c_b12, &c_b20, &r__[r_offset], lda);
    zherk_("Upper", "No transpose", n, n, &c_b28, &q[q_offset], lda, &c_b29, &
	    r__[r_offset], lda);

/*     Compute norm( I - Q*Q' ) / ( N * EPS ) . */

    resid = zlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);

    result[2] = resid / (doublereal) max(1,*n) / eps;

    return 0;

/*     End of ZRQT01 */

} /* zrqt01_ */
コード例 #11
0
ファイル: zbdt02.c プロジェクト: 3deggi/levmar-ndk
/* Subroutine */ int zbdt02_(integer *m, integer *n, doublecomplex *b, 
	integer *ldb, doublecomplex *c__, integer *ldc, doublecomplex *u, 
	integer *ldu, doublecomplex *work, doublereal *rwork, doublereal *
	resid)
{
    /* System generated locals */
    integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1;
    doublereal d__1, d__2;

    /* Local variables */
    integer j;
    doublereal eps, bnorm;
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *), 
	    zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, 
	    integer *);
    extern doublereal dlamch_(char *);
    doublereal realmn;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *), dzasum_(integer *, 
	    doublecomplex *, integer *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZBDT02 tests the change of basis C = U' * B by computing the residual */

/*     RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */

/*  where B and C are M by N matrices, U is an M by M orthogonal matrix, */
/*  and EPS is the machine precision. */

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

/*  M       (input) INTEGER */
/*          The number of rows of the matrices B and C and the order of */
/*          the matrix Q. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrices B and C. */

/*  B       (input) COMPLEX*16 array, dimension (LDB,N) */
/*          The m by n matrix B. */

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

/*  C       (input) COMPLEX*16 array, dimension (LDC,N) */
/*          The m by n matrix C, assumed to contain U' * B. */

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

/*  U       (input) COMPLEX*16 array, dimension (LDU,M) */
/*          The m by m orthogonal matrix U. */

/*  LDU     (input) INTEGER */
/*          The leading dimension of the array U.  LDU >= max(1,M). */

/*  WORK    (workspace) COMPLEX*16 array, dimension (M) */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (M) */

/*  RESID   (output) DOUBLE PRECISION */
/*          RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick return if possible */

    /* Parameter adjustments */
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    c_dim1 = *ldc;
    c_offset = 1 + c_dim1;
    c__ -= c_offset;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    --work;
    --rwork;

    /* Function Body */
    *resid = 0.;
    if (*m <= 0 || *n <= 0) {
	return 0;
    }
    realmn = (doublereal) max(*m,*n);
    eps = dlamch_("Precision");

/*     Compute norm( B - U * C ) */

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	zcopy_(m, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
	zgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c__[j * 
		c_dim1 + 1], &c__1, &c_b10, &work[1], &c__1);
/* Computing MAX */
	d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
	*resid = max(d__1,d__2);
/* L10: */
    }

/*     Compute norm of B. */

    bnorm = zlange_("1", m, n, &b[b_offset], ldb, &rwork[1]);

    if (bnorm <= 0.) {
	if (*resid != 0.) {
	    *resid = 1. / eps;
	}
    } else {
	if (bnorm >= *resid) {
	    *resid = *resid / bnorm / (realmn * eps);
	} else {
	    if (bnorm < 1.) {
/* Computing MIN */
		d__1 = *resid, d__2 = realmn * bnorm;
		*resid = min(d__1,d__2) / bnorm / (realmn * eps);
	    } else {
/* Computing MIN */
		d__1 = *resid / bnorm;
		*resid = min(d__1,realmn) / (realmn * eps);
	    }
	}
    }
    return 0;

/*     End of ZBDT02 */

} /* zbdt02_ */
コード例 #12
0
ファイル: zgeevx.c プロジェクト: flame/libflame
/* 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)
{
    /* System generated locals */
    integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
    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 */
    integer i__, k;
    char job[1];
    doublereal scl, dum[1], eps;
    doublecomplex tmp;
    char side[1];
    doublereal anrm;
    integer ierr, itau, iwrk, nout, icond;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */
    int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
    logical scalea;
    extern doublereal dlamch_(char *);
    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 *);
    logical select[1];
    extern /* Subroutine */
    int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
    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 *);
    integer minwrk, maxwrk;
    logical wantvl, wntsnb;
    integer hswork;
    logical wntsne;
    doublereal smlnum;
    extern /* Subroutine */
    int zhseqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    logical lquery, 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 *);
    logical wntsnn, wntsnv;
    /* -- LAPACK driver routine (version 3.4.0) -- */
    /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
    /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
    /* November 2011 */
    /* .. Scalar Arguments .. */
    /* .. */
    /* .. Array Arguments .. */
    /* .. */
    /* ===================================================================== */
    /* .. Parameters .. */
    /* .. */
    /* .. Local Scalars .. */
    /* .. */
    /* .. Local Arrays .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Test the input arguments */
    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --w;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --scale;
    --rconde;
    --rcondv;
    --work;
    --rwork;
    /* Function Body */
    *info = 0;
    lquery = *lwork == -1;
    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.) */
    if (*info == 0)
    {
        if (*n == 0)
        {
            minwrk = 1;
            maxwrk = 1;
        }
        else
        {
            maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, & c__0);
            if (wantvl)
            {
                zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[1], &c_n1, info);
            }
            else if (wantvr)
            {
                zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[1], &c_n1, info);
            }
            else
            {
                if (wntsnn)
                {
                    zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & vr[vr_offset], ldvr, &work[1], &c_n1, info);
                }
                else
                {
                    zhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & vr[vr_offset], ldvr, &work[1], &c_n1, info);
                }
            }
            hswork = (integer) work[1].r;
            if (! wantvl && ! wantvr)
            {
                minwrk = *n << 1;
                if (! (wntsnn || wntsne))
                {
                    /* Computing MAX */
                    i__1 = minwrk;
                    i__2 = *n * *n + (*n << 1); // , expr subst
                    minwrk = max(i__1,i__2);
                }
                maxwrk = max(maxwrk,hswork);
                if (! (wntsnn || wntsne))
                {
                    /* Computing MAX */
                    i__1 = maxwrk;
                    i__2 = *n * *n + (*n << 1); // , expr subst
                    maxwrk = max(i__1,i__2);
                }
            }
            else
            {
                minwrk = *n << 1;
                if (! (wntsnn || wntsne))
                {
                    /* Computing MAX */
                    i__1 = minwrk;
                    i__2 = *n * *n + (*n << 1); // , expr subst
                    minwrk = max(i__1,i__2);
                }
                maxwrk = max(maxwrk,hswork);
                /* Computing MAX */
                i__1 = maxwrk;
                i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", " ", n, &c__1, n, &c_n1); // , expr subst
                maxwrk = max(i__1,i__2);
                if (! (wntsnn || wntsne))
                {
                    /* Computing MAX */
                    i__1 = maxwrk;
                    i__2 = *n * *n + (*n << 1); // , expr subst
                    maxwrk = max(i__1,i__2);
                }
                /* Computing MAX */
                i__1 = maxwrk;
                i__2 = *n << 1; // , expr subst
                maxwrk = max(i__1,i__2);
            }
            maxwrk = max(maxwrk,minwrk);
        }
        work[1].r = (doublereal) maxwrk;
        work[1].i = 0.; // , expr subst
        if (*lwork < minwrk && ! lquery)
        {
            *info = -20;
        }
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("ZGEEVX", &i__1);
        return 0;
    }
    else if (lquery)
    {
        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[a_offset], 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[a_offset], lda, & ierr);
    }
    /* Balance the matrix and compute ABNRM */
    zgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
    *abnrm = zlange_("1", n, n, &a[a_offset], 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[a_offset], lda, &work[itau], &work[iwrk], &i__1, & ierr);
    if (wantvl)
    {
        /* Want left eigenvectors */
        /* Copy Householder vectors to VL */
        *(unsigned char *)side = 'L';
        zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) ;
        /* Generate unitary matrix in VL */
        /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
        /* (RWorkspace: none) */
        i__1 = *lwork - iwrk + 1;
        zunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & i__1, &ierr);
        /* Perform QR iteration, accumulating Schur vectors in VL */
        /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
        /* (RWorkspace: none) */
        iwrk = itau;
        i__1 = *lwork - iwrk + 1;
        zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[iwrk], &i__1, info);
        if (wantvr)
        {
            /* Want left and right eigenvectors */
            /* Copy Schur vectors to VR */
            *(unsigned char *)side = 'B';
            zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
        }
    }
    else if (wantvr)
    {
        /* Want right eigenvectors */
        /* Copy Householder vectors to VR */
        *(unsigned char *)side = 'R';
        zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) ;
        /* Generate unitary matrix in VR */
        /* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
        /* (RWorkspace: none) */
        i__1 = *lwork - iwrk + 1;
        zunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & i__1, &ierr);
        /* Perform QR iteration, accumulating Schur vectors in VR */
        /* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
        /* (RWorkspace: none) */
        iwrk = itau;
        i__1 = *lwork - iwrk + 1;
        zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info);
    }
    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[a_offset], lda, &w[1], &vr[ vr_offset], 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[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], 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[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], 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[vl_offset], ldvl, &ierr);
        /* Normalize left eigenvectors and make largest component real */
        i__1 = *n;
        for (i__ = 1;
                i__ <= i__1;
                ++i__)
        {
            scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
            zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
            i__2 = *n;
            for (k = 1;
                    k <= i__2;
                    ++k)
            {
                i__3 = k + i__ * vl_dim1;
                /* Computing 2nd power */
                d__1 = vl[i__3].r;
                /* Computing 2nd power */
                d__2 = d_imag(&vl[k + i__ * vl_dim1]);
                rwork[k] = d__1 * d__1 + d__2 * d__2;
                /* L10: */
            }
            k = idamax_(n, &rwork[1], &c__1);
            d_cnjg(&z__2, &vl[k + i__ * vl_dim1]);
            d__1 = sqrt(rwork[k]);
            z__1.r = z__2.r / d__1;
            z__1.i = z__2.i / d__1; // , expr subst
            tmp.r = z__1.r;
            tmp.i = z__1.i; // , expr subst
            zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
            i__2 = k + i__ * vl_dim1;
            i__3 = k + i__ * vl_dim1;
            d__1 = vl[i__3].r;
            z__1.r = d__1;
            z__1.i = 0.; // , expr subst
            vl[i__2].r = z__1.r;
            vl[i__2].i = z__1.i; // , expr subst
            /* L20: */
        }
    }
    if (wantvr)
    {
        /* Undo balancing of right eigenvectors */
        zgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, &ierr);
        /* Normalize right eigenvectors and make largest component real */
        i__1 = *n;
        for (i__ = 1;
                i__ <= i__1;
                ++i__)
        {
            scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
            zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
            i__2 = *n;
            for (k = 1;
                    k <= i__2;
                    ++k)
            {
                i__3 = k + i__ * vr_dim1;
                /* Computing 2nd power */
                d__1 = vr[i__3].r;
                /* Computing 2nd power */
                d__2 = d_imag(&vr[k + i__ * vr_dim1]);
                rwork[k] = d__1 * d__1 + d__2 * d__2;
                /* L30: */
            }
            k = idamax_(n, &rwork[1], &c__1);
            d_cnjg(&z__2, &vr[k + i__ * vr_dim1]);
            d__1 = sqrt(rwork[k]);
            z__1.r = z__2.r / d__1;
            z__1.i = z__2.i / d__1; // , expr subst
            tmp.r = z__1.r;
            tmp.i = z__1.i; // , expr subst
            zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
            i__2 = k + i__ * vr_dim1;
            i__3 = k + i__ * vr_dim1;
            d__1 = vr[i__3].r;
            z__1.r = d__1;
            z__1.i = 0.; // , expr subst
            vr[i__2].r = z__1.r;
            vr[i__2].i = z__1.i; // , expr subst
            /* 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.; // , expr subst
    return 0;
    /* End of ZGEEVX */
}
コード例 #13
0
ファイル: zchkgb.c プロジェクト: kstraube/hysim
/* Subroutine */ int zchkgb_(logical *dotype, integer *nm, integer *mval,
                             integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
                             nns, integer *nsval, doublereal *thresh, logical *tsterr,
                             doublecomplex *a, integer *la, doublecomplex *afac, integer *lafac,
                             doublecomplex *b, doublecomplex *x, doublecomplex *xact,
                             doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };
    static char transs[1*3] = "N" "T" "C";

    /* Format strings */
    static char fmt_9999[] = "(\002 *** In ZCHKGB, LA=\002,i5,\002 is too sm"
                             "all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
                             ",i4,/\002 ==> Increase LA to at least \002,i5)";
    static char fmt_9998[] = "(\002 *** In ZCHKGB, LAFAC=\002,i5,\002 is too"
                             " small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
                             "=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
    static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
                             "\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
                             ",\002, test(\002,i1,\002)=\002,g12.5)";
    static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
                             "KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
                             "1,\002, test(\002,i1,\002)=\002,g12.5)";
    static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
                             "KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
                             ", test(\002,i1,\002)=\002,g12.5)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
            i__11;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
            nkl, iku, nku, ioff, mode, koff, imat, info;
    char path[3], dist[1];
    integer irhs, nrhs;
    char norm[1], type__[1];
    integer nrun;
    extern /* Subroutine */ int alahd_(integer *, char *);
    integer nfail, iseed[4];
    extern doublereal dget06_(doublereal *, doublereal *);
    doublereal rcond;
    extern /* Subroutine */ int zgbt01_(integer *, integer *, integer *,
                                        integer *, doublecomplex *, integer *, doublecomplex *, integer *,
                                        integer *, doublecomplex *, doublereal *);
    integer nimat, klval[4];
    extern /* Subroutine */ int zgbt02_(char *, integer *, integer *, integer
                                        *, integer *, integer *, doublecomplex *, integer *,
                                        doublecomplex *, integer *, doublecomplex *, integer *,
                                        doublereal *), zgbt05_(char *, integer *, integer *,
                                                integer *, integer *, doublecomplex *, integer *, doublecomplex *,
                                                integer *, doublecomplex *, integer *, doublecomplex *, integer *
                                                , doublereal *, doublereal *, doublereal *);
    doublereal anorm;
    integer itran;
    extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
                                        integer *, doublecomplex *, integer *, doublereal *, doublereal *
                                       );
    integer kuval[4];
    char trans[1];
    integer izero, nerrs;
    logical zerot;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
                                       doublecomplex *, integer *);
    char xtype[1];
    extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
                                        *, char *, integer *, integer *, doublereal *, integer *,
                                        doublereal *, char *);
    integer ldafac;
    extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
                                        char *, integer *, integer *, integer *, integer *, integer *,
                                        integer *, integer *, integer *, integer *);
    doublereal rcondc;
    extern doublereal zlangb_(char *, integer *, integer *, integer *,
                              doublecomplex *, integer *, doublereal *);
    doublereal rcondi;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
                              integer *, doublereal *);
    extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
                                        *, integer *);
    doublereal cndnum, anormi, rcondo;
    extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
                                        *, doublecomplex *, integer *, integer *, doublereal *,
                                        doublereal *, doublecomplex *, doublereal *, integer *);
    doublereal ainvnm;
    logical trfcon;
    doublereal anormo;
    extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrge_(char *,
            integer *), zgbrfs_(char *, integer *, integer *,
                                integer *, integer *, doublecomplex *, integer *, doublecomplex *,
                                integer *, integer *, doublecomplex *, integer *, doublecomplex *
                                , integer *, doublereal *, doublereal *, doublecomplex *,
                                doublereal *, integer *), zgbtrf_(integer *, integer *,
                                        integer *, integer *, doublecomplex *, integer *, integer *,
                                        integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
                                                integer *, doublecomplex *, integer *), zlarhs_(char *,
                                                        char *, char *, char *, integer *, integer *, integer *, integer *
                                                        , integer *, doublecomplex *, integer *, doublecomplex *, integer
                                                        *, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
                                                                doublecomplex *, doublecomplex *, doublecomplex *, integer *), zgbtrs_(char *, integer *, integer *, integer *, integer
                                                                        *, doublecomplex *, integer *, integer *, doublecomplex *,
                                                                        integer *, integer *), zlatms_(integer *, integer *, char
                                                                                *, integer *, char *, doublereal *, integer *, doublereal *,
                                                                                doublereal *, integer *, integer *, char *, doublecomplex *,
                                                                                integer *, doublecomplex *, integer *);
    doublereal result[7];

    /* Fortran I/O blocks */
    static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };



    /*  -- LAPACK test routine (version 3.1) -- */
    /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
    /*     November 2006 */

    /*     .. Scalar Arguments .. */
    /*     .. */
    /*     .. Array Arguments .. */
    /*     .. */

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

    /*  ZCHKGB tests ZGBTRF, -TRS, -RFS, and -CON */

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

    /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
    /*          The matrix types to be used for testing.  Matrices of type j */
    /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
    /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */

    /*  NM      (input) INTEGER */
    /*          The number of values of M contained in the vector MVAL. */

    /*  MVAL    (input) INTEGER array, dimension (NM) */
    /*          The values of the matrix row dimension M. */

    /*  NN      (input) INTEGER */
    /*          The number of values of N contained in the vector NVAL. */

    /*  NVAL    (input) INTEGER array, dimension (NN) */
    /*          The values of the matrix column dimension N. */

    /*  NNB     (input) INTEGER */
    /*          The number of values of NB contained in the vector NBVAL. */

    /*  NBVAL   (input) INTEGER array, dimension (NBVAL) */
    /*          The values of the blocksize NB. */

    /*  NNS     (input) INTEGER */
    /*          The number of values of NRHS contained in the vector NSVAL. */

    /*  NSVAL   (input) INTEGER array, dimension (NNS) */
    /*          The values of the number of right hand sides NRHS. */

    /*  THRESH  (input) DOUBLE PRECISION */
    /*          The threshold value for the test ratios.  A result is */
    /*          included in the output file if RESULT >= THRESH.  To have */
    /*          every test ratio printed, use THRESH = 0. */

    /*  TSTERR  (input) LOGICAL */
    /*          Flag that indicates whether error exits are to be tested. */

    /*  A       (workspace) COMPLEX*16 array, dimension (LA) */

    /*  LA      (input) INTEGER */
    /*          The length of the array A.  LA >= (KLMAX+KUMAX+1)*NMAX */
    /*          where KLMAX is the largest entry in the local array KLVAL, */
    /*                KUMAX is the largest entry in the local array KUVAL and */
    /*                NMAX is the largest entry in the input array NVAL. */

    /*  AFAC    (workspace) COMPLEX*16 array, dimension (LAFAC) */

    /*  LAFAC   (input) INTEGER */
    /*          The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
    /*          where KLMAX is the largest entry in the local array KLVAL, */
    /*                KUMAX is the largest entry in the local array KUVAL and */
    /*                NMAX is the largest entry in the input array NVAL. */

    /*  B       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */

    /*  X       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */

    /*  XACT    (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */

    /*  WORK    (workspace) COMPLEX*16 array, dimension */
    /*                      (NMAX*max(3,NSMAX,NMAX)) */

    /*  RWORK   (workspace) DOUBLE PRECISION array, dimension */
    /*                      (max(NMAX,2*NSMAX)) */

    /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */

    /*  NOUT    (input) INTEGER */
    /*          The unit number for output. */

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

    /*     .. Parameters .. */
    /*     .. */
    /*     .. Local Scalars .. */
    /*     .. */
    /*     .. Local Arrays .. */
    /*     .. */
    /*     .. External Functions .. */
    /*     .. */
    /*     .. External Subroutines .. */
    /*     .. */
    /*     .. Intrinsic Functions .. */
    /*     .. */
    /*     .. Scalars in Common .. */
    /*     .. */
    /*     .. Common blocks .. */
    /*     .. */
    /*     .. Data statements .. */
    /* Parameter adjustments */
    --iwork;
    --rwork;
    --work;
    --xact;
    --x;
    --b;
    --afac;
    --a;
    --nsval;
    --nbval;
    --nval;
    --mval;
    --dotype;

    /* Function Body */
    /*     .. */
    /*     .. Executable Statements .. */

    /*     Initialize constants and the random number seed. */

    s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
    s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
    nrun = 0;
    nfail = 0;
    nerrs = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
        iseed[i__ - 1] = iseedy[i__ - 1];
        /* L10: */
    }

    /*     Test the error exits */

    if (*tsterr) {
        zerrge_(path, nout);
    }
    infoc_1.infot = 0;

    /*     Initialize the first value for the lower and upper bandwidths. */

    klval[0] = 0;
    kuval[0] = 0;

    /*     Do for each value of M in MVAL */

    i__1 = *nm;
    for (im = 1; im <= i__1; ++im) {
        m = mval[im];

        /*        Set values to use for the lower bandwidth. */

        klval[1] = m + (m + 1) / 4;

        /*        KLVAL( 2 ) = MAX( M-1, 0 ) */

        klval[2] = (m * 3 - 1) / 4;
        klval[3] = (m + 1) / 4;

        /*        Do for each value of N in NVAL */

        i__2 = *nn;
        for (in = 1; in <= i__2; ++in) {
            n = nval[in];
            *(unsigned char *)xtype = 'N';

            /*           Set values to use for the upper bandwidth. */

            kuval[1] = n + (n + 1) / 4;

            /*           KUVAL( 2 ) = MAX( N-1, 0 ) */

            kuval[2] = (n * 3 - 1) / 4;
            kuval[3] = (n + 1) / 4;

            /*           Set limits on the number of loop iterations. */

            /* Computing MIN */
            i__3 = m + 1;
            nkl = min(i__3,4);
            if (n == 0) {
                nkl = 2;
            }
            /* Computing MIN */
            i__3 = n + 1;
            nku = min(i__3,4);
            if (m == 0) {
                nku = 2;
            }
            nimat = 8;
            if (m <= 0 || n <= 0) {
                nimat = 1;
            }

            i__3 = nkl;
            for (ikl = 1; ikl <= i__3; ++ikl) {

                /*              Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
                /*              order makes it easier to skip redundant values for small */
                /*              values of M. */

                kl = klval[ikl - 1];
                i__4 = nku;
                for (iku = 1; iku <= i__4; ++iku) {

                    /*                 Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
                    /*                 order makes it easier to skip redundant values for */
                    /*                 small values of N. */

                    ku = kuval[iku - 1];

                    /*                 Check that A and AFAC are big enough to generate this */
                    /*                 matrix. */

                    lda = kl + ku + 1;
                    ldafac = (kl << 1) + ku + 1;
                    if (lda * n > *la || ldafac * n > *lafac) {
                        if (nfail == 0 && nerrs == 0) {
                            alahd_(nout, path);
                        }
                        if (n * (kl + ku + 1) > *la) {
                            io___25.ciunit = *nout;
                            s_wsfe(&io___25);
                            do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
                                       integer));
                            do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
                            ;
                            do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
                            ;
                            do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
                                  );
                            do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
                                  );
                            i__5 = n * (kl + ku + 1);
                            do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
                                       integer));
                            e_wsfe();
                            ++nerrs;
                        }
                        if (n * ((kl << 1) + ku + 1) > *lafac) {
                            io___26.ciunit = *nout;
                            s_wsfe(&io___26);
                            do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
                                       integer));
                            do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
                            ;
                            do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
                            ;
                            do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
                                  );
                            do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
                                  );
                            i__5 = n * ((kl << 1) + ku + 1);
                            do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
                                       integer));
                            e_wsfe();
                            ++nerrs;
                        }
                        goto L130;
                    }

                    i__5 = nimat;
                    for (imat = 1; imat <= i__5; ++imat) {

                        /*                    Do the tests only if DOTYPE( IMAT ) is true. */

                        if (! dotype[imat]) {
                            goto L120;
                        }

                        /*                    Skip types 2, 3, or 4 if the matrix size is too */
                        /*                    small. */

                        zerot = imat >= 2 && imat <= 4;
                        if (zerot && n < imat - 1) {
                            goto L120;
                        }

                        if (! zerot || ! dotype[1]) {

                            /*                       Set up parameters with ZLATB4 and generate a */
                            /*                       test matrix with ZLATMS. */

                            zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
                                    anorm, &mode, &cndnum, dist);

                            /* Computing MAX */
                            i__6 = 1, i__7 = ku + 2 - n;
                            koff = max(i__6,i__7);
                            i__6 = koff - 1;
                            for (i__ = 1; i__ <= i__6; ++i__) {
                                i__7 = i__;
                                a[i__7].r = 0., a[i__7].i = 0.;
                                /* L20: */
                            }
                            s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (
                                       ftnlen)6);
                            zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &
                                    mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
                                        koff], &lda, &work[1], &info);

                            /*                       Check the error code from ZLATMS. */

                            if (info != 0) {
                                alaerh_(path, "ZLATMS", &info, &c__0, " ", &m,
                                        &n, &kl, &ku, &c_n1, &imat, &nfail, &
                                        nerrs, nout);
                                goto L120;
                            }
                        } else if (izero > 0) {

                            /*                       Use the same matrix for types 3 and 4 as for */
                            /*                       type 2 by copying back the zeroed out column. */

                            i__6 = i2 - i1 + 1;
                            zcopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
                        }

                        /*                    For types 2, 3, and 4, zero one or more columns of */
                        /*                    the matrix to test that INFO is returned correctly. */

                        izero = 0;
                        if (zerot) {
                            if (imat == 2) {
                                izero = 1;
                            } else if (imat == 3) {
                                izero = min(m,n);
                            } else {
                                izero = min(m,n) / 2 + 1;
                            }
                            ioff = (izero - 1) * lda;
                            if (imat < 4) {

                                /*                          Store the column to be zeroed out in B. */

                                /* Computing MAX */
                                i__6 = 1, i__7 = ku + 2 - izero;
                                i1 = max(i__6,i__7);
                                /* Computing MIN */
                                i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
                                                                     izero);
                                i2 = min(i__6,i__7);
                                i__6 = i2 - i1 + 1;
                                zcopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
                                       c__1);

                                i__6 = i2;
                                for (i__ = i1; i__ <= i__6; ++i__) {
                                    i__7 = ioff + i__;
                                    a[i__7].r = 0., a[i__7].i = 0.;
                                    /* L30: */
                                }
                            } else {
                                i__6 = n;
                                for (j = izero; j <= i__6; ++j) {
                                    /* Computing MAX */
                                    i__7 = 1, i__8 = ku + 2 - j;
                                    /* Computing MIN */
                                    i__10 = kl + ku + 1, i__11 = ku + 1 + (m
                                                                           - j);
                                    i__9 = min(i__10,i__11);
                                    for (i__ = max(i__7,i__8); i__ <= i__9;
                                            ++i__) {
                                        i__7 = ioff + i__;
                                        a[i__7].r = 0., a[i__7].i = 0.;
                                        /* L40: */
                                    }
                                    ioff += lda;
                                    /* L50: */
                                }
                            }
                        }

                        /*                    These lines, if used in place of the calls in the */
                        /*                    loop over INB, cause the code to bomb on a Sun */
                        /*                    SPARCstation. */

                        /*                     ANORMO = ZLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
                        /*                     ANORMI = ZLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */

                        /*                    Do for each blocksize in NBVAL */

                        i__6 = *nnb;
                        for (inb = 1; inb <= i__6; ++inb) {
                            nb = nbval[inb];
                            xlaenv_(&c__1, &nb);

                            /*                       Compute the LU factorization of the band matrix. */

                            if (m > 0 && n > 0) {
                                i__9 = kl + ku + 1;
                                zlacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
                                            kl + 1], &ldafac);
                            }
                            s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)6, (
                                       ftnlen)6);
                            zgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
                                    iwork[1], &info);

                            /*                       Check error code from ZGBTRF. */

                            if (info != izero) {
                                alaerh_(path, "ZGBTRF", &info, &izero, " ", &
                                        m, &n, &kl, &ku, &nb, &imat, &nfail, &
                                        nerrs, nout);
                            }
                            trfcon = FALSE_;

                            /* +    TEST 1 */
                            /*                       Reconstruct matrix from factors and compute */
                            /*                       residual. */

                            zgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
                                    ldafac, &iwork[1], &work[1], result);

                            /*                       Print information about the tests so far that */
                            /*                       did not pass the threshold. */

                            if (result[0] >= *thresh) {
                                if (nfail == 0 && nerrs == 0) {
                                    alahd_(nout, path);
                                }
                                io___45.ciunit = *nout;
                                s_wsfe(&io___45);
                                do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
                                           integer));
                                do_fio(&c__1, (char *)&result[0], (ftnlen)
                                       sizeof(doublereal));
                                e_wsfe();
                                ++nfail;
                            }
                            ++nrun;

                            /*                       Skip the remaining tests if this is not the */
                            /*                       first block size or if M .ne. N. */

                            if (inb > 1 || m != n) {
                                goto L110;
                            }

                            anormo = zlangb_("O", &n, &kl, &ku, &a[1], &lda, &
                                             rwork[1]);
                            anormi = zlangb_("I", &n, &kl, &ku, &a[1], &lda, &
                                             rwork[1]);

                            if (info == 0) {

                                /*                          Form the inverse of A so we can get a good */
                                /*                          estimate of CNDNUM = norm(A) * norm(inv(A)). */

                                ldb = max(1,n);
                                zlaset_("Full", &n, &n, &c_b61, &c_b62, &work[
                                            1], &ldb);
                                s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)6, (
                                           ftnlen)6);
                                zgbtrs_("No transpose", &n, &kl, &ku, &n, &
                                        afac[1], &ldafac, &iwork[1], &work[1],
                                        &ldb, &info);

                                /*                          Compute the 1-norm condition number of A. */

                                ainvnm = zlange_("O", &n, &n, &work[1], &ldb,
                                                 &rwork[1]);
                                if (anormo <= 0. || ainvnm <= 0.) {
                                    rcondo = 1.;
                                } else {
                                    rcondo = 1. / anormo / ainvnm;
                                }

                                /*                          Compute the infinity-norm condition number of */
                                /*                          A. */

                                ainvnm = zlange_("I", &n, &n, &work[1], &ldb,
                                                 &rwork[1]);
                                if (anormi <= 0. || ainvnm <= 0.) {
                                    rcondi = 1.;
                                } else {
                                    rcondi = 1. / anormi / ainvnm;
                                }
                            } else {

                                /*                          Do only the condition estimate if INFO.NE.0. */

                                trfcon = TRUE_;
                                rcondo = 0.;
                                rcondi = 0.;
                            }

                            /*                       Skip the solve tests if the matrix is singular. */

                            if (trfcon) {
                                goto L90;
                            }

                            i__9 = *nns;
                            for (irhs = 1; irhs <= i__9; ++irhs) {
                                nrhs = nsval[irhs];
                                *(unsigned char *)xtype = 'N';

                                for (itran = 1; itran <= 3; ++itran) {
                                    *(unsigned char *)trans = *(unsigned char
                                                                *)&transs[itran - 1];
                                    if (itran == 1) {
                                        rcondc = rcondo;
                                        *(unsigned char *)norm = 'O';
                                    } else {
                                        rcondc = rcondi;
                                        *(unsigned char *)norm = 'I';
                                    }

                                    /* +    TEST 2: */
                                    /*                             Solve and compute residual for A * X = B. */

                                    s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)
                                           6, (ftnlen)6);
                                    zlarhs_(path, xtype, " ", trans, &n, &n, &
                                            kl, &ku, &nrhs, &a[1], &lda, &
                                            xact[1], &ldb, &b[1], &ldb, iseed,
                                            &info);
                                    *(unsigned char *)xtype = 'C';
                                    zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
                                            x[1], &ldb);

                                    s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)
                                           6, (ftnlen)6);
                                    zgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
                                                1], &ldafac, &iwork[1], &x[1], &
                                            ldb, &info);

                                    /*                             Check error code from ZGBTRS. */

                                    if (info != 0) {
                                        alaerh_(path, "ZGBTRS", &info, &c__0,
                                                trans, &n, &n, &kl, &ku, &
                                                c_n1, &imat, &nfail, &nerrs,
                                                nout);
                                    }

                                    zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
                                            work[1], &ldb);
                                    zgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
                                            a[1], &lda, &x[1], &ldb, &work[1],
                                            &ldb, &result[1]);

                                    /* +    TEST 3: */
                                    /*                             Check solution from generated exact */
                                    /*                             solution. */

                                    zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
                                            &ldb, &rcondc, &result[2]);

                                    /* +    TESTS 4, 5, 6: */
                                    /*                             Use iterative refinement to improve the */
                                    /*                             solution. */

                                    s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)
                                           6, (ftnlen)6);
                                    zgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
                                            &lda, &afac[1], &ldafac, &iwork[
                                                1], &b[1], &ldb, &x[1], &ldb, &
                                            rwork[1], &rwork[nrhs + 1], &work[
                                                1], &rwork[(nrhs << 1) + 1], &
                                            info);

                                    /*                             Check error code from ZGBRFS. */

                                    if (info != 0) {
                                        alaerh_(path, "ZGBRFS", &info, &c__0,
                                                trans, &n, &n, &kl, &ku, &
                                                nrhs, &imat, &nfail, &nerrs,
                                                nout);
                                    }

                                    zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
                                            &ldb, &rcondc, &result[3]);
                                    zgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
                                            &lda, &b[1], &ldb, &x[1], &ldb, &
                                            xact[1], &ldb, &rwork[1], &rwork[
                                                nrhs + 1], &result[4]);

                                    /*                             Print information about the tests that did */
                                    /*                             not pass the threshold. */

                                    for (k = 2; k <= 6; ++k) {
                                        if (result[k - 1] >= *thresh) {
                                            if (nfail == 0 && nerrs == 0) {
                                                alahd_(nout, path);
                                            }
                                            io___59.ciunit = *nout;
                                            s_wsfe(&io___59);
                                            do_fio(&c__1, trans, (ftnlen)1);
                                            do_fio(&c__1, (char *)&n, (ftnlen)
                                                   sizeof(integer));
                                            do_fio(&c__1, (char *)&kl, (
                                                       ftnlen)sizeof(integer));
                                            do_fio(&c__1, (char *)&ku, (
                                                       ftnlen)sizeof(integer));
                                            do_fio(&c__1, (char *)&nrhs, (
                                                       ftnlen)sizeof(integer));
                                            do_fio(&c__1, (char *)&imat, (
                                                       ftnlen)sizeof(integer));
                                            do_fio(&c__1, (char *)&k, (ftnlen)
                                                   sizeof(integer));
                                            do_fio(&c__1, (char *)&result[k -
                                                                          1], (ftnlen)sizeof(
                                                       doublereal));
                                            e_wsfe();
                                            ++nfail;
                                        }
                                        /* L60: */
                                    }
                                    nrun += 5;
                                    /* L70: */
                                }
                                /* L80: */
                            }

                            /* +    TEST 7: */
                            /*                          Get an estimate of RCOND = 1/CNDNUM. */

L90:
                            for (itran = 1; itran <= 2; ++itran) {
                                if (itran == 1) {
                                    anorm = anormo;
                                    rcondc = rcondo;
                                    *(unsigned char *)norm = 'O';
                                } else {
                                    anorm = anormi;
                                    rcondc = rcondi;
                                    *(unsigned char *)norm = 'I';
                                }
                                s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)6, (
                                           ftnlen)6);
                                zgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
                                        &iwork[1], &anorm, &rcond, &work[1],
                                        &rwork[1], &info);

                                /*                             Check error code from ZGBCON. */

                                if (info != 0) {
                                    alaerh_(path, "ZGBCON", &info, &c__0,
                                            norm, &n, &n, &kl, &ku, &c_n1, &
                                            imat, &nfail, &nerrs, nout);
                                }

                                result[6] = dget06_(&rcond, &rcondc);

                                /*                          Print information about the tests that did */
                                /*                          not pass the threshold. */

                                if (result[6] >= *thresh) {
                                    if (nfail == 0 && nerrs == 0) {
                                        alahd_(nout, path);
                                    }
                                    io___61.ciunit = *nout;
                                    s_wsfe(&io___61);
                                    do_fio(&c__1, norm, (ftnlen)1);
                                    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
                                               integer));
                                    do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
                                               integer));
                                    do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
                                               integer));
                                    do_fio(&c__1, (char *)&imat, (ftnlen)
                                           sizeof(integer));
                                    do_fio(&c__1, (char *)&c__7, (ftnlen)
                                           sizeof(integer));
                                    do_fio(&c__1, (char *)&result[6], (ftnlen)
                                           sizeof(doublereal));
                                    e_wsfe();
                                    ++nfail;
                                }
                                ++nrun;
                                /* L100: */
                            }
L110:
                            ;
                        }
L120:
                        ;
                    }
L130:
                    ;
                }
                /* L140: */
            }
            /* L150: */
        }
        /* L160: */
    }

    /*     Print a summary of the results. */

    alasum_(path, nout, &nfail, &nrun, &nerrs);


    return 0;

    /*     End of ZCHKGB */

} /* zchkgb_ */
コード例 #14
0
ファイル: zlatme.c プロジェクト: DarkOfTheMoon/HONEI
/* Subroutine */ int zlatme_(integer *n, char *dist, integer *iseed,
        doublecomplex *d, integer *mode, doublereal *cond, doublecomplex *
        dmax__, char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
         integer *modes, doublereal *conds, integer *kl, integer *ku,
        doublereal *anorm, doublecomplex *a, integer *lda, doublecomplex *
        work, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    doublereal d__1, d__2;
    doublecomplex z__1, z__2;

    /* Builtin functions */
    double z_abs(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *);

    /* Local variables */
    static logical bads;
    static integer isim;
    static doublereal temp;
    static integer i, j;
    static doublecomplex alpha;
    extern logical lsame_(char *, char *);
    static integer iinfo;
    static doublereal tempa[1];
    static integer icols;
    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
            doublecomplex *, integer *, doublecomplex *, integer *,
            doublecomplex *, integer *);
    static integer idist;
    extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
            doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
            doublecomplex *, doublecomplex *, integer *, doublecomplex *,
            integer *, doublecomplex *, doublecomplex *, integer *);
    static integer irows;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
            doublecomplex *, integer *), dlatm1_(integer *, doublereal *,
            integer *, integer *, integer *, doublereal *, integer *, integer
            *), zlatm1_(integer *, doublereal *, integer *, integer *,
            integer *, doublecomplex *, integer *, integer *);
    static integer ic, jc, ir;
    static doublereal ralpha;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
            integer *, doublereal *);
    extern /* Subroutine */ int zdscal_(integer *, doublereal *,
            doublecomplex *, integer *), zlarge_(integer *, doublecomplex *,
            integer *, integer *, doublecomplex *, integer *), zlarfg_(
            integer *, doublecomplex *, doublecomplex *, integer *,
            doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
    extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
            integer *);
    static integer irsign;
    extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
            doublecomplex *, doublecomplex *, doublecomplex *, integer *);
    static integer iupper;
    extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
            doublecomplex *);
    static doublecomplex xnorms;
    static integer jcr;
    static doublecomplex tau;


/*  -- LAPACK test 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
    =======

       ZLATME generates random non-symmetric square matrices with
       specified eigenvalues for testing LAPACK programs.

       ZLATME operates by applying the following sequence of
       operations:

       1. Set the diagonal to D, where D may be input or
            computed according to MODE, COND, DMAX, and RSIGN
            as described below.

       2. If UPPER='T', the upper triangle of A is set to random values
            out of distribution DIST.

       3. If SIM='T', A is multiplied on the left by a random matrix
            X, whose singular values are specified by DS, MODES, and
            CONDS, and on the right by X inverse.

       4. If KL < N-1, the lower bandwidth is reduced to KL using
            Householder transformations.  If KU < N-1, the upper
            bandwidth is reduced to KU.

       5. If ANORM is not negative, the matrix is scaled to have
            maximum-element-norm ANORM.

       (Note: since the matrix cannot be reduced beyond Hessenberg form,

        no packing options are available.)

    Arguments
    =========

    N      - INTEGER
             The number of columns (or rows) of A. Not modified.

    DIST   - CHARACTER*1
             On entry, DIST specifies the type of distribution to be used

             to generate the random eigen-/singular values, and on the
             upper triangle (see UPPER).
             'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )
             'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
             'N' => NORMAL( 0, 1 )   ( 'N' for normal )
             'D' => uniform on the complex disc |z| < 1.
             Not modified.

    ISEED  - INTEGER array, dimension ( 4 )
             On entry ISEED specifies the seed of the random number
             generator. They should lie between 0 and 4095 inclusive,
             and ISEED(4) should be odd. The random number generator
             uses a linear congruential sequence limited to small
             integers, and so should produce machine independent
             random numbers. The values of ISEED are changed on
             exit, and can be used in the next call to ZLATME
             to continue the same random number sequence.
             Changed on exit.

    D      - COMPLEX*16 array, dimension ( N )
             This array is used to specify the eigenvalues of A.  If
             MODE=0, then D is assumed to contain the eigenvalues
             otherwise they will be computed according to MODE, COND,
             DMAX, and RSIGN and placed in D.
             Modified if MODE is nonzero.

    MODE   - INTEGER
             On entry this describes how the eigenvalues are to
             be specified:
             MODE = 0 means use D as input
             MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
             MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
             MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
             MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
             MODE = 5 sets D to random numbers in the range
                      ( 1/COND , 1 ) such that their logarithms
                      are uniformly distributed.
             MODE = 6 set D to random numbers from same distribution
                      as the rest of the matrix.
             MODE < 0 has the same meaning as ABS(MODE), except that
                the order of the elements of D is reversed.
             Thus if MODE is between 1 and 4, D has entries ranging
                from 1 to 1/COND, if between -1 and -4, D has entries
                ranging from 1/COND to 1,
             Not modified.

    COND   - DOUBLE PRECISION
             On entry, this is used as described under MODE above.
             If used, it must be >= 1. Not modified.

    DMAX   - COMPLEX*16
             If MODE is neither -6, 0 nor 6, the contents of D, as
             computed according to MODE and COND, will be scaled by
             DMAX / max(abs(D(i))).  Note that DMAX need not be
             positive or real: if DMAX is negative or complex (or zero),

             D will be scaled by a negative or complex number (or zero).

             If RSIGN='F' then the largest (absolute) eigenvalue will be

             equal to DMAX.
             Not modified.

    EI     - CHARACTER*1 (ignored)
             Not modified.

    RSIGN  - CHARACTER*1
             If MODE is not 0, 6, or -6, and RSIGN='T', then the
             elements of D, as computed according to MODE and COND, will

             be multiplied by a random complex number from the unit
             circle |z| = 1.  If RSIGN='F', they will not be.  RSIGN may

             only have the values 'T' or 'F'.
             Not modified.

    UPPER  - CHARACTER*1
             If UPPER='T', then the elements of A above the diagonal
             will be set to random numbers out of DIST.  If UPPER='F',
             they will not.  UPPER may only have the values 'T' or 'F'.
             Not modified.

    SIM    - CHARACTER*1
             If SIM='T', then A will be operated on by a "similarity
             transform", i.e., multiplied on the left by a matrix X and
             on the right by X inverse.  X = U S V, where U and V are
             random unitary matrices and S is a (diagonal) matrix of
             singular values specified by DS, MODES, and CONDS.  If
             SIM='F', then A will not be transformed.
             Not modified.

    DS     - DOUBLE PRECISION array, dimension ( N )
             This array is used to specify the singular values of X,
             in the same way that D specifies the eigenvalues of A.
             If MODE=0, the DS contains the singular values, which
             may not be zero.
             Modified if MODE is nonzero.

    MODES  - INTEGER
    CONDS  - DOUBLE PRECISION
             Similar to MODE and COND, but for specifying the diagonal
             of S.  MODES=-6 and +6 are not allowed (since they would
             result in randomly ill-conditioned eigenvalues.)

    KL     - INTEGER
             This specifies the lower bandwidth of the  matrix.  KL=1
             specifies upper Hessenberg form.  If KL is at least N-1,
             then A will have full lower bandwidth.
             Not modified.

    KU     - INTEGER
             This specifies the upper bandwidth of the  matrix.  KU=1
             specifies lower Hessenberg form.  If KU is at least N-1,
             then A will have full upper bandwidth; if KU and KL
             are both at least N-1, then A will be dense.  Only one of
             KU and KL may be less than N-1.
             Not modified.

    ANORM  - DOUBLE PRECISION
             If ANORM is not negative, then A will be scaled by a non-
             negative real number to make the maximum-element-norm of A
             to be ANORM.
             Not modified.

    A      - COMPLEX*16 array, dimension ( LDA, N )
             On exit A is the desired test matrix.
             Modified.

    LDA    - INTEGER
             LDA specifies the first dimension of A as declared in the
             calling program.  LDA must be at least M.
             Not modified.

    WORK   - COMPLEX*16 array, dimension ( 3*N )
             Workspace.
             Modified.

    INFO   - INTEGER
             Error code.  On exit, INFO will be set to one of the
             following values:
               0 => normal return
              -1 => N negative
              -2 => DIST illegal string
              -5 => MODE not in range -6 to 6
              -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
              -9 => RSIGN is not 'T' or 'F'
             -10 => UPPER is not 'T' or 'F'
             -11 => SIM   is not 'T' or 'F'
             -12 => MODES=0 and DS has a zero singular value.
             -13 => MODES is not in the range -5 to 5.
             -14 => MODES is nonzero and CONDS is less than 1.
             -15 => KL is less than 1.
             -16 => KU is less than 1, or KL and KU are both less than
                    N-1.
             -19 => LDA is less than M.
              1  => Error return from ZLATM1 (computing D)
              2  => Cannot scale to DMAX (max. eigenvalue is 0)
              3  => Error return from DLATM1 (computing DS)
              4  => Error return from ZLARGE
              5  => Zero singular value from DLATM1.

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



       1)      Decode and Test the input parameters.
               Initialize flags & seed.

       Parameter adjustments */
    --iseed;
    --d;
    --ds;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --work;

    /* Function Body */
    *info = 0;

/*     Quick return if possible */

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

/*     Decode DIST */

    if (lsame_(dist, "U")) {
        idist = 1;
    } else if (lsame_(dist, "S")) {
        idist = 2;
    } else if (lsame_(dist, "N")) {
        idist = 3;
    } else if (lsame_(dist, "D")) {
        idist = 4;
    } else {
        idist = -1;
    }

/*     Decode RSIGN */

    if (lsame_(rsign, "T")) {
        irsign = 1;
    } else if (lsame_(rsign, "F")) {
        irsign = 0;
    } else {
        irsign = -1;
    }

/*     Decode UPPER */

    if (lsame_(upper, "T")) {
        iupper = 1;
    } else if (lsame_(upper, "F")) {
        iupper = 0;
    } else {
        iupper = -1;
    }

/*     Decode SIM */

    if (lsame_(sim, "T")) {
        isim = 1;
    } else if (lsame_(sim, "F")) {
        isim = 0;
    } else {
        isim = -1;
    }

/*     Check DS, if MODES=0 and ISIM=1 */

    bads = FALSE_;
    if (*modes == 0 && isim == 1) {
        i__1 = *n;
        for (j = 1; j <= i__1; ++j) {
            if (ds[j] == 0.) {
                bads = TRUE_;
            }
/* L10: */
        }
    }

/*     Set INFO if an error */

    if (*n < 0) {
        *info = -1;
    } else if (idist == -1) {
        *info = -2;
    } else if (abs(*mode) > 6) {
        *info = -5;
    } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
        *info = -6;
    } else if (irsign == -1) {
        *info = -9;
    } else if (iupper == -1) {
        *info = -10;
    } else if (isim == -1) {
        *info = -11;
    } else if (bads) {
        *info = -12;
    } else if (isim == 1 && abs(*modes) > 5) {
        *info = -13;
    } else if (isim == 1 && *modes != 0 && *conds < 1.) {
        *info = -14;
    } else if (*kl < 1) {
        *info = -15;
    } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
        *info = -16;
    } else if (*lda < max(1,*n)) {
        *info = -19;
    }

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

/*     Initialize random number generator */

    for (i = 1; i <= 4; ++i) {
        iseed[i] = (i__1 = iseed[i], abs(i__1)) % 4096;
/* L20: */
    }

    if (iseed[4] % 2 != 1) {
        ++iseed[4];
    }

/*     2)      Set up diagonal of A

               Compute D according to COND and MODE */

    zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d[1], n, &iinfo);
    if (iinfo != 0) {
        *info = 1;
        return 0;
    }
    if (*mode != 0 && abs(*mode) != 6) {

/*        Scale by DMAX */

        temp = z_abs(&d[1]);
        i__1 = *n;
        for (i = 2; i <= i__1; ++i) {
/* Computing MAX */
            d__1 = temp, d__2 = z_abs(&d[i]);
            temp = max(d__1,d__2);
/* L30: */
        }

        if (temp > 0.) {
            z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp;
            alpha.r = z__1.r, alpha.i = z__1.i;
        } else {
            *info = 2;
            return 0;
        }

        zscal_(n, &alpha, &d[1], &c__1);

    }

    zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
    i__1 = *lda + 1;
    zcopy_(n, &d[1], &c__1, &a[a_offset], &i__1);

/*     3)      If UPPER='T', set upper triangle of A to random numbers. */

    if (iupper != 0) {
        i__1 = *n;
        for (jc = 2; jc <= i__1; ++jc) {
            i__2 = jc - 1;
            zlarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]);
/* L40: */
        }
    }

/*     4)      If SIM='T', apply similarity transformation.

                                  -1
               Transform is  X A X  , where X = U S V, thus

               it is  U S V A V' (1/S) U' */

    if (isim != 0) {

/*        Compute S (singular values of the eigenvector matrix)
          according to CONDS and MODES */

        dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
        if (iinfo != 0) {
            *info = 3;
            return 0;
        }

/*        Multiply by V and V' */

        zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
        if (iinfo != 0) {
            *info = 4;
            return 0;
        }

/*        Multiply by S and (1/S) */

        i__1 = *n;
        for (j = 1; j <= i__1; ++j) {
            zdscal_(n, &ds[j], &a[j + a_dim1], lda);
            if (ds[j] != 0.) {
                d__1 = 1. / ds[j];
                zdscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
            } else {
                *info = 5;
                return 0;
            }
/* L50: */
        }

/*        Multiply by U and U' */

        zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
        if (iinfo != 0) {
            *info = 4;
            return 0;
        }
    }

/*     5)      Reduce the bandwidth. */

    if (*kl < *n - 1) {

/*        Reduce bandwidth -- kill column */

        i__1 = *n - 1;
        for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
            ic = jcr - *kl;
            irows = *n + 1 - jcr;
            icols = *n + *kl - jcr;

            zcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
            xnorms.r = work[1].r, xnorms.i = work[1].i;
            zlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
            d_cnjg(&z__1, &tau);
            tau.r = z__1.r, tau.i = z__1.i;
            work[1].r = 1., work[1].i = 0.;
            zlarnd_(&z__1, &c__5, &iseed[1]);
            alpha.r = z__1.r, alpha.i = z__1.i;

            zgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1],
                    lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1);
            z__1.r = -tau.r, z__1.i = -tau.i;
            zgerc_(&irows, &icols, &z__1, &work[1], &c__1, &work[irows + 1], &
                    c__1, &a[jcr + (ic + 1) * a_dim1], lda);

            zgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1],
                     &c__1, &c_b1, &work[irows + 1], &c__1);
            d_cnjg(&z__2, &tau);
            z__1.r = -z__2.r, z__1.i = -z__2.i;
            zgerc_(n, &irows, &z__1, &work[irows + 1], &c__1, &work[1], &c__1,
                     &a[jcr * a_dim1 + 1], lda);

            i__2 = jcr + ic * a_dim1;
            a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
            i__2 = irows - 1;
            zlaset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic *
                    a_dim1], lda);

            i__2 = icols + 1;
            zscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda);
            d_cnjg(&z__1, &alpha);
            zscal_(n, &z__1, &a[jcr * a_dim1 + 1], &c__1);
/* L60: */
        }
    } else if (*ku < *n - 1) {

/*        Reduce upper bandwidth -- kill a row at a time. */

        i__1 = *n - 1;
        for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
            ir = jcr - *ku;
            irows = *n + *ku - jcr;
            icols = *n + 1 - jcr;

            zcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
            xnorms.r = work[1].r, xnorms.i = work[1].i;
            zlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
            d_cnjg(&z__1, &tau);
            tau.r = z__1.r, tau.i = z__1.i;
            work[1].r = 1., work[1].i = 0.;
            i__2 = icols - 1;
            zlacgv_(&i__2, &work[2], &c__1);
            zlarnd_(&z__1, &c__5, &iseed[1]);
            alpha.r = z__1.r, alpha.i = z__1.i;

            zgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda,
                     &work[1], &c__1, &c_b1, &work[icols + 1], &c__1);
            z__1.r = -tau.r, z__1.i = -tau.i;
            zgerc_(&irows, &icols, &z__1, &work[icols + 1], &c__1, &work[1], &
                    c__1, &a[ir + 1 + jcr * a_dim1], lda);

            zgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], &
                    c__1, &c_b1, &work[icols + 1], &c__1);
            d_cnjg(&z__2, &tau);
            z__1.r = -z__2.r, z__1.i = -z__2.i;
            zgerc_(&icols, n, &z__1, &work[1], &c__1, &work[icols + 1], &c__1,
                     &a[jcr + a_dim1], lda);

            i__2 = ir + jcr * a_dim1;
            a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
            i__2 = icols - 1;
            zlaset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) *
                    a_dim1], lda);

            i__2 = irows + 1;
            zscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1);
            d_cnjg(&z__1, &alpha);
            zscal_(n, &z__1, &a[jcr + a_dim1], lda);
/* L70: */
        }
    }

/*     Scale the matrix to have norm ANORM */

    if (*anorm >= 0.) {
        temp = zlange_("M", n, n, &a[a_offset], lda, tempa);
        if (temp > 0.) {
            ralpha = *anorm / temp;
            i__1 = *n;
            for (j = 1; j <= i__1; ++j) {
                zdscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1);
/* L80: */
            }
        }
    }

    return 0;

/*     End of ZLATME */

} /* zlatme_ */
コード例 #15
0
ファイル: zget54.c プロジェクト: kstraube/hysim
/* Subroutine */ int zget54_(integer *n, doublecomplex *a, integer *lda, 
	doublecomplex *b, integer *ldb, doublecomplex *s, integer *lds, 
	doublecomplex *t, integer *ldt, doublecomplex *u, integer *ldu, 
	doublecomplex *v, integer *ldv, doublecomplex *work, doublereal *
	result)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, s_dim1, s_offset, t_dim1, 
	    t_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
    doublereal d__1, d__2;
    doublecomplex z__1;

    /* Local variables */
    doublereal dum[1], ulp, unfl;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    doublereal wnorm;
    extern doublereal dlamch_(char *);
    doublereal abnorm;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZGET54 checks a generalized decomposition of the form */

/*           A = U*S*V'  and B = U*T* V' */

/*  where ' means conjugate transpose and U and V are unitary. */

/*  Specifically, */

/*    RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp ) */

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

/*  N       (input) INTEGER */
/*          The size of the matrix.  If it is zero, DGET54 does nothing. */
/*          It must be at least zero. */

/*  A       (input) COMPLEX*16 array, dimension (LDA, N) */
/*          The original (unfactored) matrix A. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A.  It must be at least 1 */
/*          and at least N. */

/*  B       (input) COMPLEX*16 array, dimension (LDB, N) */
/*          The original (unfactored) matrix B. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of B.  It must be at least 1 */
/*          and at least N. */

/*  S       (input) COMPLEX*16 array, dimension (LDS, N) */
/*          The factored matrix S. */

/*  LDS     (input) INTEGER */
/*          The leading dimension of S.  It must be at least 1 */
/*          and at least N. */

/*  T       (input) COMPLEX*16 array, dimension (LDT, N) */
/*          The factored matrix T. */

/*  LDT     (input) INTEGER */
/*          The leading dimension of T.  It must be at least 1 */
/*          and at least N. */

/*  U       (input) COMPLEX*16 array, dimension (LDU, N) */
/*          The orthogonal matrix on the left-hand side in the */
/*          decomposition. */

/*  LDU     (input) INTEGER */
/*          The leading dimension of U.  LDU must be at least N and */
/*          at least 1. */

/*  V       (input) COMPLEX*16 array, dimension (LDV, N) */
/*          The orthogonal matrix on the left-hand side in the */
/*          decomposition. */

/*  LDV     (input) INTEGER */
/*          The leading dimension of V.  LDV must be at least N and */
/*          at least 1. */

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

/*  RESULT  (output) DOUBLE PRECISION */
/*          The value RESULT, It is currently limited to 1/ulp, to */
/*          avoid overflow. Errors are flagged by RESULT=10/ulp. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    s_dim1 = *lds;
    s_offset = 1 + s_dim1;
    s -= s_offset;
    t_dim1 = *ldt;
    t_offset = 1 + t_dim1;
    t -= t_offset;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    v_dim1 = *ldv;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    --work;

    /* Function Body */
    *result = 0.;
    if (*n <= 0) {
	return 0;
    }

/*     Constants */

    unfl = dlamch_("Safe minimum");
    ulp = dlamch_("Epsilon") * dlamch_("Base");

/*     compute the norm of (A,B) */

    zlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
    zlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n)
	    ;
/* Computing MAX */
    i__1 = *n << 1;
    d__1 = zlange_("1", n, &i__1, &work[1], n, dum);
    abnorm = max(d__1,unfl);

/*     Compute W1 = A - U*S*V', and put in the array WORK(1:N*N) */

    zlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
    zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &s[s_offset], lds, &
	    c_b1, &work[*n * *n + 1], n);

    z__1.r = -1., z__1.i = -0.;
    zgemm_("N", "C", n, n, n, &z__1, &work[*n * *n + 1], n, &v[v_offset], ldv, 
	     &c_b2, &work[1], n);

/*     Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N) */

    zlacpy_(" ", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
    zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &t[t_offset], ldt, &
	    c_b1, &work[(*n << 1) * *n + 1], n);

    z__1.r = -1., z__1.i = -0.;
    zgemm_("N", "C", n, n, n, &z__1, &work[(*n << 1) * *n + 1], n, &v[
	    v_offset], ldv, &c_b2, &work[*n * *n + 1], n);

/*     Compute norm(W)/ ( ulp*norm((A,B)) ) */

    i__1 = *n << 1;
    wnorm = zlange_("1", n, &i__1, &work[1], n, dum);

    if (abnorm > wnorm) {
	*result = wnorm / abnorm / ((*n << 1) * ulp);
    } else {
	if (abnorm < 1.) {
/* Computing MIN */
	    d__1 = wnorm, d__2 = (*n << 1) * abnorm;
	    *result = min(d__1,d__2) / abnorm / ((*n << 1) * ulp);
	} else {
/* Computing MIN */
	    d__1 = wnorm / abnorm, d__2 = (doublereal) (*n << 1);
	    *result = min(d__1,d__2) / ((*n << 1) * ulp);
	}
    }

    return 0;

/*     End of ZGET54 */

} /* zget54_ */
コード例 #16
0
ファイル: zdrgvx.c プロジェクト: kstraube/hysim
/* Subroutine */ int zdrgvx_(integer *nsize, doublereal *thresh, integer *nin, 
	 integer *nout, doublecomplex *a, integer *lda, doublecomplex *b, 
	doublecomplex *ai, doublecomplex *bi, doublecomplex *alpha, 
	doublecomplex *beta, doublecomplex *vl, doublecomplex *vr, integer *
	ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal 
	*s, doublereal *dtru, doublereal *dif, doublereal *diftru, 
	doublecomplex *work, integer *lwork, doublereal *rwork, integer *
	iwork, integer *liwork, doublereal *result, logical *bwork, integer *
	info)
{
    /* Format strings */
    static char fmt_9999[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
    static char fmt_9998[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
	    " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
	    "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
	    "i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
	    "WY=\002,i5)";
    static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
	    "or\002,\002 problem driver\002)";
    static char fmt_9995[] = "(\002 Matrix types: \002,/)";
    static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
	    " \002,/\002     A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
	    "\002     YH and X are left and right eigenvectors. \002,/)";
    static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
	    "tity, \002,/\002     A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
	    " \002,/\002     YH and X are left and right eigenvectors. \002,/)"
	    ;
    static char fmt_9992[] = "(/\002 Tests performed:  \002,/4x,\002 a is al"
	    "pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
	    "ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
	    " max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
	    " ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
	    "Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
	    "DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
	    "ors\002,/)";
    static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
	    ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
	    "ult \002,i2,\002 is\002,0p,f8.2)";
    static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
	    ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
	    "ult \002,i2,\002 is\002,1p,d10.3)";
    static char fmt_9987[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
	    ")\002)";
    static char fmt_9986[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
	    " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
	    "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
	    "le #\002,i2,\002)\002)";
    static char fmt_9996[] = "(\002Input Example\002)";
    static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
	    "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
    static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
	    "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";

    /* System generated locals */
    integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1, 
	    bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;

    /* Builtin functions */
    double sqrt(doublereal);
    void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
	     s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
	    e_rsle(void);

    /* Local variables */
    integer i__, j, n, iwa, iwb;
    doublereal ulp;
    integer iwx, iwy, nmax, linfo;
    doublereal anorm, bnorm;
    extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *, 
	     integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *, 
	     doublereal *);
    integer nerrs;
    doublereal ratio1, ratio2, thrsh2;
    extern /* Subroutine */ int zlatm6_(integer *, integer *, doublecomplex *, 
	     integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    doublereal abnorm;
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 
	    *, integer *);
    doublecomplex weight[5];
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    integer minwrk, maxwrk, iptype;
    extern /* Subroutine */ int zggevx_(char *, char *, char *, char *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, integer *, 
	     doublecomplex *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublecomplex *, integer *, doublereal *, integer *, 
	     logical *, integer *);
    doublereal ulpinv;
    integer nptknt, ntestt;

    /* Fortran I/O blocks */
    static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
    static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
    static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
    static cilist io___35 = { 0, 0, 1, 0, 0 };
    static cilist io___36 = { 0, 0, 0, 0, 0 };
    static cilist io___37 = { 0, 0, 0, 0, 0 };
    static cilist io___38 = { 0, 0, 0, 0, 0 };
    static cilist io___39 = { 0, 0, 0, 0, 0 };
    static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
    static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
    static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZDRGVX checks the nonsymmetric generalized eigenvalue problem */
/*  expert driver ZGGEVX. */

/*  ZGGEVX computes the generalized eigenvalues, (optionally) the left */
/*  and/or right eigenvectors, (optionally) computes a balancing */
/*  transformation to improve the conditioning, and (optionally) */
/*  reciprocal condition numbers for the eigenvalues and eigenvectors. */

/*  When ZDRGVX is called with NSIZE > 0, two types of test matrix pairs */
/*  are generated by the subroutine DLATM6 and test the driver ZGGEVX. */
/*  The test matrices have the known exact condition numbers for */
/*  eigenvalues. For the condition numbers of the eigenvectors */
/*  corresponding the first and last eigenvalues are also know */
/*  ``exactly'' (see ZLATM6). */
/*  For each matrix pair, the following tests will be performed and */
/*  compared with the threshhold THRESH. */

/*  (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */

/*     | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */

/*      where l**H is the conjugate tranpose of l. */

/*  (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */

/*        | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */

/*  (3) The condition number S(i) of eigenvalues computed by ZGGEVX */
/*      differs less than a factor THRESH from the exact S(i) (see */
/*      ZLATM6). */

/*  (4) DIF(i) computed by ZTGSNA differs less than a factor 10*THRESH */
/*      from the exact value (for the 1st and 5th vectors only). */

/*  Test Matrices */
/*  ============= */

/*  Two kinds of test matrix pairs */
/*           (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/*  are used in the tests: */

/*  1: Da = 1+a   0    0    0    0    Db = 1   0   0   0   0 */
/*           0   2+a   0    0    0         0   1   0   0   0 */
/*           0    0   3+a   0    0         0   0   1   0   0 */
/*           0    0    0   4+a   0         0   0   0   1   0 */
/*           0    0    0    0   5+a ,      0   0   0   0   1 , and */

/*  2: Da =  1   -1    0    0    0    Db = 1   0   0   0   0 */
/*           1    1    0    0    0         0   1   0   0   0 */
/*           0    0    1    0    0         0   0   1   0   0 */
/*           0    0    0   1+a  1+b        0   0   0   1   0 */
/*           0    0    0  -1-b  1+a ,      0   0   0   0   1 . */

/*  In both cases the same inverse(YH) and inverse(X) are used to compute */
/*  (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */

/*  YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x */
/*          0    1   -y    y   -y         0   1   x  -x  -x */
/*          0    0    1    0    0         0   0   1   0   0 */
/*          0    0    0    1    0         0   0   0   1   0 */
/*          0    0    0    0    1,        0   0   0   0   1 , where */

/*  a, b, x and y will have all values independently of each other from */
/*  { sqrt(sqrt(ULP)),  0.1,  1,  10,  1/sqrt(sqrt(ULP)) }. */

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

/*  NSIZE   (input) INTEGER */
/*          The number of sizes of matrices to use.  NSIZE must be at */
/*          least zero. If it is zero, no randomly generated matrices */
/*          are tested, but any test matrices read from NIN will be */
/*          tested.  If it is not zero, then N = 5. */

/*  THRESH  (input) DOUBLE PRECISION */
/*          A test will count as "failed" if the "error", computed as */
/*          described above, exceeds THRESH.  Note that the error */
/*          is scaled to be O(1), so THRESH should be a reasonably */
/*          small multiple of 1, e.g., 10 or 100.  In particular, */
/*          it should not depend on the precision (single vs. double) */
/*          or the size of the matrix.  It must be at least zero. */

/*  NIN     (input) INTEGER */
/*          The FORTRAN unit number for reading in the data file of */
/*          problems to solve. */

/*  NOUT    (input) INTEGER */
/*          The FORTRAN unit number for printing out error messages */
/*          (e.g., if a routine returns IINFO not equal to 0.) */

/*  A       (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/*          Used to hold the matrix whose eigenvalues are to be */
/*          computed.  On exit, A contains the last matrix actually used. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A, B, AI, BI, Ao, and Bo. */
/*          It must be at least 1 and at least NSIZE. */

/*  B       (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/*          Used to hold the matrix whose eigenvalues are to be */
/*          computed.  On exit, B contains the last matrix actually used. */

/*  AI      (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/*          Copy of A, modified by ZGGEVX. */

/*  BI      (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/*          Copy of B, modified by ZGGEVX. */

/*  ALPHA   (workspace) COMPLEX*16 array, dimension (NSIZE) */
/*  BETA    (workspace) COMPLEX*16 array, dimension (NSIZE) */
/*          On exit, ALPHA/BETA are the eigenvalues. */

/*  VL      (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/*          VL holds the left eigenvectors computed by ZGGEVX. */

/*  VR      (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/*          VR holds the right eigenvectors computed by ZGGEVX. */

/*  ILO     (output/workspace) INTEGER */

/*  IHI     (output/workspace) INTEGER */

/*  LSCALE  (output/workspace) DOUBLE PRECISION array, dimension (N) */

/*  RSCALE  (output/workspace) DOUBLE PRECISION array, dimension (N) */

/*  S       (output/workspace) DOUBLE PRECISION array, dimension (N) */

/*  DTRU    (output/workspace) DOUBLE PRECISION array, dimension (N) */

/*  DIF     (output/workspace) DOUBLE PRECISION array, dimension (N) */

/*  DIFTRU  (output/workspace) DOUBLE PRECISION array, dimension (N) */

/*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          Leading dimension of WORK.  LWORK >= 2*N*N + 2*N */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (6*N) */

/*  IWORK   (workspace) INTEGER array, dimension (LIWORK) */

/*  LIWORK  (input) INTEGER */
/*          Leading dimension of IWORK.  LIWORK >= N+2. */

/*  RESULT  (output/workspace) DOUBLE PRECISION array, dimension (4) */

/*  BWORK   (workspace) LOGICAL array, dimension (N) */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
/*          > 0:  A routine returned an error code. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Check for errors */

    /* Parameter adjustments */
    vr_dim1 = *lda;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    vl_dim1 = *lda;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    bi_dim1 = *lda;
    bi_offset = 1 + bi_dim1;
    bi -= bi_offset;
    ai_dim1 = *lda;
    ai_offset = 1 + ai_dim1;
    ai -= ai_offset;
    b_dim1 = *lda;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --alpha;
    --beta;
    --lscale;
    --rscale;
    --s;
    --dtru;
    --dif;
    --diftru;
    --work;
    --rwork;
    --iwork;
    --result;
    --bwork;

    /* Function Body */
    *info = 0;

    nmax = 5;

    if (*nsize < 0) {
	*info = -1;
    } else if (*thresh < 0.) {
	*info = -2;
    } else if (*nin <= 0) {
	*info = -3;
    } else if (*nout <= 0) {
	*info = -4;
    } else if (*lda < 1 || *lda < nmax) {
	*info = -6;
    } else if (*liwork < nmax + 2) {
	*info = -26;
    }

/*     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. */
/*       NB refers to the optimal block size for the immediately */
/*       following subroutine, as returned by ILAENV.) */

    minwrk = 1;
    if (*info == 0 && *lwork >= 1) {
	minwrk = (nmax << 1) * (nmax + 1);
	maxwrk = nmax * (ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &c__1, &nmax, &
		c__0) + 1);
/* Computing MAX */
	i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
	maxwrk = max(i__1,i__2);
	work[1].r = (doublereal) maxwrk, work[1].i = 0.;
    }

    if (*lwork < minwrk) {
	*info = -23;
    }

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

    n = 5;
    ulp = dlamch_("P");
    ulpinv = 1. / ulp;
    thrsh2 = *thresh * 10.;
    nerrs = 0;
    nptknt = 0;
    ntestt = 0;

    if (*nsize == 0) {
	goto L90;
    }

/*     Parameters used for generating test matrices. */

    d__1 = sqrt(sqrt(ulp));
    z__1.r = d__1, z__1.i = 0.;
    weight[0].r = z__1.r, weight[0].i = z__1.i;
    weight[1].r = .1, weight[1].i = 0.;
    weight[2].r = 1., weight[2].i = 0.;
    z_div(&z__1, &c_b11, &weight[1]);
    weight[3].r = z__1.r, weight[3].i = z__1.i;
    z_div(&z__1, &c_b11, weight);
    weight[4].r = z__1.r, weight[4].i = z__1.i;

    for (iptype = 1; iptype <= 2; ++iptype) {
	for (iwa = 1; iwa <= 5; ++iwa) {
	    for (iwb = 1; iwb <= 5; ++iwb) {
		for (iwx = 1; iwx <= 5; ++iwx) {
		    for (iwy = 1; iwy <= 5; ++iwy) {

/*                    generated a pair of test matrix */

			zlatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
				b_offset], &vr[vr_offset], lda, &vl[vl_offset]
, lda, &weight[iwa - 1], &weight[iwb - 1], &
				weight[iwx - 1], &weight[iwy - 1], &dtru[1], &
				diftru[1]);

/*                    Compute eigenvalues/eigenvectors of (A, B). */
/*                    Compute eigenvalue/eigenvector condition numbers */
/*                    using computed eigenvectors. */

			zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
, lda);
			zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
, lda);

			zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
				bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
				vl_offset], lda, &vr[vr_offset], lda, ilo, 
				ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
				s[1], &dif[1], &work[1], lwork, &rwork[1], &
				iwork[1], &bwork[1], &linfo);
			if (linfo != 0) {
			    io___20.ciunit = *nout;
			    s_wsfe(&io___20);
			    do_fio(&c__1, "ZGGEVX", (ftnlen)6);
			    do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
				    integer));
			    e_wsfe();
			    goto L30;
			}

/*                    Compute the norm(A, B) */

			zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], 
				 &n);
			zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
				 n + 1], &n);
			i__1 = n << 1;
			abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &
				rwork[1]);

/*                    Tests (1) and (2) */

			result[1] = 0.;
			zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], 
				lda, &vl[vl_offset], lda, &alpha[1], &beta[1], 
				 &work[1], &rwork[1], &result[1]);
			if (result[2] > *thresh) {
			    io___22.ciunit = *nout;
			    s_wsfe(&io___22);
			    do_fio(&c__1, "Left", (ftnlen)4);
			    do_fio(&c__1, "ZGGEVX", (ftnlen)6);
			    do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
				    doublereal));
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
				    integer));
			    e_wsfe();
			}

			result[2] = 0.;
			zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], 
				 lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
, &work[1], &rwork[1], &result[2]);
			if (result[3] > *thresh) {
			    io___23.ciunit = *nout;
			    s_wsfe(&io___23);
			    do_fio(&c__1, "Right", (ftnlen)5);
			    do_fio(&c__1, "ZGGEVX", (ftnlen)6);
			    do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
				    doublereal));
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
				    integer));
			    e_wsfe();
			}

/*                    Test (3) */

			result[3] = 0.;
			i__1 = n;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    if (s[i__] == 0.) {
				if (dtru[i__] > abnorm * ulp) {
				    result[3] = ulpinv;
				}
			    } else if (dtru[i__] == 0.) {
				if (s[i__] > abnorm * ulp) {
				    result[3] = ulpinv;
				}
			    } else {
/* Computing MAX */
				d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)),
					 d__4 = (d__2 = s[i__] / dtru[i__], 
					abs(d__2));
				rwork[i__] = max(d__3,d__4);
/* Computing MAX */
				d__1 = result[3], d__2 = rwork[i__];
				result[3] = max(d__1,d__2);
			    }
/* L10: */
			}

/*                    Test (4) */

			result[4] = 0.;
			if (dif[1] == 0.) {
			    if (diftru[1] > abnorm * ulp) {
				result[4] = ulpinv;
			    }
			} else if (diftru[1] == 0.) {
			    if (dif[1] > abnorm * ulp) {
				result[4] = ulpinv;
			    }
			} else if (dif[5] == 0.) {
			    if (diftru[5] > abnorm * ulp) {
				result[4] = ulpinv;
			    }
			} else if (diftru[5] == 0.) {
			    if (dif[5] > abnorm * ulp) {
				result[4] = ulpinv;
			    }
			} else {
/* Computing MAX */
			    d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), 
				    d__4 = (d__2 = dif[1] / diftru[1], abs(
				    d__2));
			    ratio1 = max(d__3,d__4);
/* Computing MAX */
			    d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), 
				    d__4 = (d__2 = dif[5] / diftru[5], abs(
				    d__2));
			    ratio2 = max(d__3,d__4);
			    result[4] = max(ratio1,ratio2);
			}

			ntestt += 4;

/*                    Print out tests which fail. */

			for (j = 1; j <= 4; ++j) {
			    if (result[j] >= thrsh2 && j >= 4 || result[j] >= 
				    *thresh && j <= 3) {

/*                       If this is the first test to fail, */
/*                       print a header to the data file. */

				if (nerrs == 0) {
				    io___28.ciunit = *nout;
				    s_wsfe(&io___28);
				    do_fio(&c__1, "ZXV", (ftnlen)3);
				    e_wsfe();

/*                          Print out messages for built-in examples */

/*                          Matrix types */

				    io___29.ciunit = *nout;
				    s_wsfe(&io___29);
				    e_wsfe();
				    io___30.ciunit = *nout;
				    s_wsfe(&io___30);
				    e_wsfe();
				    io___31.ciunit = *nout;
				    s_wsfe(&io___31);
				    e_wsfe();

/*                          Tests performed */

				    io___32.ciunit = *nout;
				    s_wsfe(&io___32);
				    do_fio(&c__1, "'", (ftnlen)1);
				    do_fio(&c__1, "transpose", (ftnlen)9);
				    do_fio(&c__1, "'", (ftnlen)1);
				    e_wsfe();

				}
				++nerrs;
				if (result[j] < 1e4) {
				    io___33.ciunit = *nout;
				    s_wsfe(&io___33);
				    do_fio(&c__1, (char *)&iptype, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwa, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwb, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwx, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwy, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
					    integer));
				    do_fio(&c__1, (char *)&result[j], (ftnlen)
					    sizeof(doublereal));
				    e_wsfe();
				} else {
				    io___34.ciunit = *nout;
				    s_wsfe(&io___34);
				    do_fio(&c__1, (char *)&iptype, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwa, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwb, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwx, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&iwy, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
					    integer));
				    do_fio(&c__1, (char *)&result[j], (ftnlen)
					    sizeof(doublereal));
				    e_wsfe();
				}
			    }
/* L20: */
			}

L30:

/* L40: */
			;
		    }
/* L50: */
		}
/* L60: */
	    }
/* L70: */
	}
/* L80: */
    }

    goto L150;

L90:

/*     Read in data from file to check accuracy of condition estimation */
/*     Read input data until N=0 */

    io___35.ciunit = *nin;
    i__1 = s_rsle(&io___35);
    if (i__1 != 0) {
	goto L150;
    }
    i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
    if (i__1 != 0) {
	goto L150;
    }
    i__1 = e_rsle();
    if (i__1 != 0) {
	goto L150;
    }
    if (n == 0) {
	goto L150;
    }
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___36.ciunit = *nin;
	s_rsle(&io___36);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
		    doublecomplex));
	}
	e_rsle();
/* L100: */
    }
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___37.ciunit = *nin;
	s_rsle(&io___37);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
		    doublecomplex));
	}
	e_rsle();
/* L110: */
    }
    io___38.ciunit = *nin;
    s_rsle(&io___38);
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	do_lio(&c__5, &c__1, (char *)&dtru[i__], (ftnlen)sizeof(doublereal));
    }
    e_rsle();
    io___39.ciunit = *nin;
    s_rsle(&io___39);
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	do_lio(&c__5, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(doublereal))
		;
    }
    e_rsle();

    ++nptknt;

/*     Compute eigenvalues/eigenvectors of (A, B). */
/*     Compute eigenvalue/eigenvector condition numbers */
/*     using computed eigenvectors. */

    zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
    zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);

    zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda, 
	    &alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda, 
	    ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1], 
	    &work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);

    if (linfo != 0) {
	io___40.ciunit = *nout;
	s_wsfe(&io___40);
	do_fio(&c__1, "ZGGEVX", (ftnlen)6);
	do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
	e_wsfe();
	goto L140;
    }

/*     Compute the norm(A, B) */

    zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
    zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
    i__1 = n << 1;
    abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);

/*     Tests (1) and (2) */

    result[1] = 0.;
    zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset], 
	     lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
    if (result[2] > *thresh) {
	io___41.ciunit = *nout;
	s_wsfe(&io___41);
	do_fio(&c__1, "Left", (ftnlen)4);
	do_fio(&c__1, "ZGGEVX", (ftnlen)6);
	do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
	e_wsfe();
    }

    result[2] = 0.;
    zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
    if (result[3] > *thresh) {
	io___42.ciunit = *nout;
	s_wsfe(&io___42);
	do_fio(&c__1, "Right", (ftnlen)5);
	do_fio(&c__1, "ZGGEVX", (ftnlen)6);
	do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
	e_wsfe();
    }

/*     Test (3) */

    result[3] = 0.;
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (s[i__] == 0.) {
	    if (dtru[i__] > abnorm * ulp) {
		result[3] = ulpinv;
	    }
	} else if (dtru[i__] == 0.) {
	    if (s[i__] > abnorm * ulp) {
		result[3] = ulpinv;
	    }
	} else {
/* Computing MAX */
	    d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)), d__4 = (d__2 = s[
		    i__] / dtru[i__], abs(d__2));
	    rwork[i__] = max(d__3,d__4);
/* Computing MAX */
	    d__1 = result[3], d__2 = rwork[i__];
	    result[3] = max(d__1,d__2);
	}
/* L120: */
    }

/*     Test (4) */

    result[4] = 0.;
    if (dif[1] == 0.) {
	if (diftru[1] > abnorm * ulp) {
	    result[4] = ulpinv;
	}
    } else if (diftru[1] == 0.) {
	if (dif[1] > abnorm * ulp) {
	    result[4] = ulpinv;
	}
    } else if (dif[5] == 0.) {
	if (diftru[5] > abnorm * ulp) {
	    result[4] = ulpinv;
	}
    } else if (diftru[5] == 0.) {
	if (dif[5] > abnorm * ulp) {
	    result[4] = ulpinv;
	}
    } else {
/* Computing MAX */
	d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), d__4 = (d__2 = dif[1] /
		 diftru[1], abs(d__2));
	ratio1 = max(d__3,d__4);
/* Computing MAX */
	d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), d__4 = (d__2 = dif[5] /
		 diftru[5], abs(d__2));
	ratio2 = max(d__3,d__4);
	result[4] = max(ratio1,ratio2);
    }

    ntestt += 4;

/*     Print out tests which fail. */

    for (j = 1; j <= 4; ++j) {
	if (result[j] >= thrsh2) {

/*           If this is the first test to fail, */
/*           print a header to the data file. */

	    if (nerrs == 0) {
		io___43.ciunit = *nout;
		s_wsfe(&io___43);
		do_fio(&c__1, "ZXV", (ftnlen)3);
		e_wsfe();

/*              Print out messages for built-in examples */

/*              Matrix types */

		io___44.ciunit = *nout;
		s_wsfe(&io___44);
		e_wsfe();

/*              Tests performed */

		io___45.ciunit = *nout;
		s_wsfe(&io___45);
		do_fio(&c__1, "'", (ftnlen)1);
		do_fio(&c__1, "transpose", (ftnlen)9);
		do_fio(&c__1, "'", (ftnlen)1);
		e_wsfe();

	    }
	    ++nerrs;
	    if (result[j] < 1e4) {
		io___46.ciunit = *nout;
		s_wsfe(&io___46);
		do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
		e_wsfe();
	    } else {
		io___47.ciunit = *nout;
		s_wsfe(&io___47);
		do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
		e_wsfe();
	    }
	}
/* L130: */
    }

L140:

    goto L90;
L150:

/*     Summary */

    alasvm_("ZXV", nout, &nerrs, &ntestt, &c__0);

    work[1].r = (doublereal) maxwrk, work[1].i = 0.;

    return 0;















/*     End of ZDRGVX */

} /* zdrgvx_ */
コード例 #17
0
/* Subroutine */ int zggevx_(char *balanc, char *jobvl, char *jobvr, char *
	sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, 
	integer *ldb, doublecomplex *alpha, doublecomplex *beta, 
	doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, 
	integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, 
	doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
	rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, 
	integer *iwork, logical *bwork, integer *info)
{
    /* 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;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;

    /* Local variables */
    integer i__, j, m, jc, in, jr;
    doublereal eps;
    logical ilv;
    doublereal anrm, bnrm;
    integer ierr, itau;
    doublereal temp;
    logical ilvl, ilvr;
    integer iwrk, iwrk1;
    integer icols;
    logical noscl;
    integer irows;
    logical ilascl, ilbscl;
    logical ldumma[1];
    char chtemp[1];
    doublereal bignum;
    integer ijobvl;
    integer ijobvr;
    logical wantsb;
    doublereal anrmto;
    logical wantse;
    doublereal bnrmto;
    integer minwrk;
    integer maxwrk;
    logical wantsn;
    doublereal smlnum;
    logical lquery, wantsv;

/*  -- LAPACK driver routine (version 3.2) -- */
/*     November 2006 */

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

/*  ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices */
/*  (A,B) the generalized eigenvalues, and optionally, the left and/or */
/*  right generalized eigenvectors. */

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

/*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
/*  lambda or a ratio alpha/beta = lambda, such that A - lambda*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. */

/*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
/*  of (A,B) satisfies */
/*                   A * v(j) = lambda(j) * B * v(j) . */
/*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
/*  of (A,B) satisfies */
/*                   u(j)**H * A  = lambda(j) * u(j)**H * B. */
/*  where u(j)**H is the conjugate-transpose of u(j). */

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

/*  BALANC  (input) CHARACTER*1 */
/*          Specifies the balance option to be performed: */
/*          = 'N':  do not diagonally scale or permute; */
/*          = 'P':  permute only; */
/*          = 'S':  scale only; */
/*          = 'B':  both permute and scale. */
/*          Computed reciprocal condition numbers will be for the */
/*          matrices after permuting and/or balancing. Permuting does */
/*          not change condition numbers (in exact arithmetic), but */
/*          balancing does. */

/*  JOBVL   (input) CHARACTER*1 */
/*          = 'N':  do not compute the left generalized eigenvectors; */
/*          = 'V':  compute the left generalized eigenvectors. */

/*  JOBVR   (input) CHARACTER*1 */
/*          = 'N':  do not compute the right generalized eigenvectors; */
/*          = 'V':  compute the right generalized eigenvectors. */

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

/*  N       (input) INTEGER */
/*          The order of the matrices A, B, VL, and VR.  N >= 0. */

/*  A       (input/output) COMPLEX*16 array, dimension (LDA, N) */
/*          On entry, the matrix A in the pair (A,B). */
/*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
/*          or both, then A contains the first part of the complex Schur */
/*          form of the "balanced" versions of the input A and B. */

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

/*  B       (input/output) COMPLEX*16 array, dimension (LDB, N) */
/*          On entry, the matrix B in the pair (A,B). */
/*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
/*          or both, then B contains the second part of the complex */
/*          Schur form of the "balanced" versions of the input A and 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) */
/*          eigenvalues. */

/*          Note: the quotient 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). */

/*  VL      (output) COMPLEX*16 array, dimension (LDVL,N) */
/*          If JOBVL = 'V', the left generalized eigenvectors u(j) are */
/*          stored one after another in the columns of VL, in the same */
/*          order as their eigenvalues. */
/*          Each eigenvector will be scaled so the largest component */
/*          will have abs(real part) + abs(imag. part) = 1. */
/*          Not referenced if JOBVL = 'N'. */

/*  LDVL    (input) INTEGER */
/*          The leading dimension of the matrix VL. LDVL >= 1, and */
/*          if JOBVL = 'V', LDVL >= N. */

/*  VR      (output) COMPLEX*16 array, dimension (LDVR,N) */
/*          If JOBVR = 'V', the right generalized eigenvectors v(j) are */
/*          stored one after another in the columns of VR, in the same */
/*          order as their eigenvalues. */
/*          Each eigenvector will be scaled so the largest component */
/*          will have abs(real part) + abs(imag. part) = 1. */
/*          Not referenced if JOBVR = 'N'. */

/*  LDVR    (input) INTEGER */
/*          The leading dimension of the matrix VR. LDVR >= 1, and */
/*          if JOBVR = 'V', LDVR >= N. */

/*  ILO     (output) INTEGER */
/*  IHI     (output) INTEGER */
/*          ILO and IHI are integer values such that on exit */
/*          A(i,j) = 0 and B(i,j) = 0 if i > j and */
/*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */

/*  LSCALE  (output) DOUBLE PRECISION array, dimension (N) */
/*          Details of the permutations and scaling factors applied */
/*          to the left side of A and B.  If PL(j) is the index of the */
/*          row interchanged with row j, and DL(j) is the scaling */
/*          factor applied to row j, then */
/*          The order in which the interchanges are made is N to IHI+1, */
/*          then 1 to ILO-1. */

/*  RSCALE  (output) DOUBLE PRECISION array, dimension (N) */
/*          Details of the permutations and scaling factors applied */
/*          to the right side of A and B.  If PR(j) is the index of the */
/*          column interchanged with column j, and DR(j) is the scaling */
/*          factor applied to column j, then */
/*          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 A. */

/*  BBNRM   (output) DOUBLE PRECISION */
/*          The one-norm of the balanced matrix B. */

/*  RCONDE  (output) DOUBLE PRECISION array, dimension (N) */
/*          If SENSE = 'E' or 'B', the reciprocal condition numbers of */
/*          the eigenvalues, stored in consecutive elements of the array. */
/*          If SENSE = 'N' or 'V', RCONDE is not referenced. */

/*  RCONDV  (output) DOUBLE PRECISION array, dimension (N) */
/*          If JOB = 'V' or 'B', the estimated reciprocal condition */
/*          numbers of the eigenvectors, stored in consecutive elements */
/*          of the array. If the eigenvalues cannot be reordered to */
/*          compute RCONDV(j), RCONDV(j) is set to 0; this can only occur */
/*          when the true value would be very small anyway. */
/*          If SENSE = 'N' or 'E', RCONDV 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. LWORK >= max(1,2*N). */
/*          If SENSE = 'E', LWORK >= max(1,4*N). */
/*          If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N). */

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

/*  RWORK   (workspace) REAL array, dimension (lrwork) */
/*          lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B', */
/*          and at least max(1,2*N) otherwise. */
/*          Real workspace. */

/*  IWORK   (workspace) INTEGER array, dimension (N+2) */
/*          If SENSE = 'E', IWORK is not referenced. */

/*  BWORK   (workspace) LOGICAL array, dimension (N) */
/*          If SENSE = 'N', BWORK is not referenced. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
/*                The QZ iteration failed.  No eigenvectors have been */
/*                calculated, but ALPHA(j) and BETA(j) should be correct */
/*          > N:  =N+1: other than QZ iteration failed in ZHGEQZ. */
/*                =N+2: error return from ZTGEVC. */

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

/*  Balancing a matrix pair (A,B) includes, first, permuting rows and */
/*  columns to isolate eigenvalues, second, applying diagonal similarity */
/*  transformation to the rows and columns to make the rows and columns */
/*  as close in norm as possible. 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.11.1.2 of LAPACK Users' Guide. */

/*  An approximate error bound on the chordal distance between the i-th */
/*  computed generalized eigenvalue w and the corresponding exact */
/*  eigenvalue lambda is */

/*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */

/*  An approximate error bound for the angle between the i-th computed */
/*  eigenvector VL(i) or VR(i) is given by */

/*       EPS * norm(ABNRM, BBNRM) / DIF(i). */

/*  For further explanation of the reciprocal condition numbers RCONDE */
/*  and RCONDV, see section 4.11 of LAPACK User's Guide. */

/*     Decode the input arguments */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --alpha;
    --beta;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --lscale;
    --rscale;
    --rconde;
    --rcondv;
    --work;
    --rwork;
    --iwork;
    --bwork;

    /* Function Body */
    if (lsame_(jobvl, "N")) {
	ijobvl = 1;
	ilvl = FALSE_;
    } else if (lsame_(jobvl, "V")) {
	ijobvl = 2;
	ilvl = TRUE_;
    } else {
	ijobvl = -1;
	ilvl = FALSE_;
    }

    if (lsame_(jobvr, "N")) {
	ijobvr = 1;
	ilvr = FALSE_;
    } else if (lsame_(jobvr, "V")) {
	ijobvr = 2;
	ilvr = TRUE_;
    } else {
	ijobvr = -1;
	ilvr = FALSE_;
    }
    ilv = ilvl || ilvr;

    noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
    wantsn = lsame_(sense, "N");
    wantse = lsame_(sense, "E");
    wantsv = lsame_(sense, "V");
    wantsb = lsame_(sense, "B");

/*     Test the input arguments */

    *info = 0;
    lquery = *lwork == -1;
    if (! (noscl || lsame_(balanc, "S") || lsame_(
	    balanc, "B"))) {
	*info = -1;
    } else if (ijobvl <= 0) {
	*info = -2;
    } else if (ijobvr <= 0) {
	*info = -3;
    } else if (! (wantsn || wantse || wantsb || wantsv)) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < max(1,*n)) {
	*info = -7;
    } else if (*ldb < max(1,*n)) {
	*info = -9;
    } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
	*info = -13;
    } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
	*info = -15;
    }

/*     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. */
/*       NB refers to the optimal block size for the immediately */
/*       following subroutine, as returned by ILAENV. The workspace is */
/*       computed assuming ILO = 1 and IHI = N, the worst case.) */

    if (*info == 0) {
	if (*n == 0) {
	    minwrk = 1;
	    maxwrk = 1;
	} else {
	    minwrk = *n << 1;
	    if (wantse) {
		minwrk = *n << 2;
	    } else if (wantsv || wantsb) {
		minwrk = (*n << 1) * (*n + 1);
	    }
	    maxwrk = minwrk;
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &
		    c__1, n, &c__0);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
		    c__1, n, &c__0);
	    maxwrk = max(i__1,i__2);
	    if (ilvl) {
/* Computing MAX */
		i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR", 
			" ", n, &c__1, n, &c__0);
		maxwrk = max(i__1,i__2);
	    }
	}
	work[1].r = (doublereal) maxwrk, work[1].i = 0.;

	if (*lwork < minwrk && ! lquery) {
	    *info = -25;
	}
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGGEVX", &i__1);
	return 0;
    } else if (lquery) {
	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] */

    anrm = zlange_("M", n, n, &a[a_offset], 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__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
		ierr);
    }

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

    bnrm = zlange_("M", n, n, &b[b_offset], 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__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
		ierr);
    }

/*     Permute and/or balance the matrix pair (A,B) */
/*     (Real Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */

    zggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
	    lscale[1], &rscale[1], &rwork[1], &ierr);

/*     Compute ABNRM and BBNRM */

    *abnrm = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
    if (ilascl) {
	rwork[1] = *abnrm;
	dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &rwork[1], &
		c__1, &ierr);
	*abnrm = rwork[1];
    }

    *bbnrm = zlange_("1", n, n, &b[b_offset], ldb, &rwork[1]);
    if (ilbscl) {
	rwork[1] = *bbnrm;
	dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &rwork[1], &
		c__1, &ierr);
	*bbnrm = rwork[1];
    }

/*     Reduce B to triangular form (QR decomposition of B) */
/*     (Complex Workspace: need N, prefer N*NB ) */

    irows = *ihi + 1 - *ilo;
    if (ilv || ! wantsn) {
	icols = *n + 1 - *ilo;
    } else {
	icols = irows;
    }
    itau = 1;
    iwrk = itau + irows;
    i__1 = *lwork + 1 - iwrk;
    zgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
	    iwrk], &i__1, &ierr);

/*     Apply the unitary transformation to A */
/*     (Complex Workspace: need N, prefer N*NB) */

    i__1 = *lwork + 1 - iwrk;
    zunmqr_("L", "C", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
	    work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
	    ierr);

/*     Initialize VL and/or VR */
/*     (Workspace: need N, prefer N*NB) */

    if (ilvl) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
	if (irows > 1) {
	    i__1 = irows - 1;
	    i__2 = irows - 1;
	    zlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
		    *ilo + 1 + *ilo * vl_dim1], ldvl);
	}
	i__1 = *lwork + 1 - iwrk;
	zungqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
		work[itau], &work[iwrk], &i__1, &ierr);
    }

    if (ilvr) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
    }

/*     Reduce to generalized Hessenberg form */
/*     (Workspace: none needed) */

    if (ilv || ! wantsn) {

/*        Eigenvectors requested -- work on whole matrix. */

	zgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], 
		ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
    } else {
	zgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1], 
		lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
		vr_offset], ldvr, &ierr);
    }

/*     Perform QZ algorithm (Compute eigenvalues, and optionally, the */
/*     Schur forms and Schur vectors) */
/*     (Complex Workspace: need N) */
/*     (Real Workspace: need N) */

    iwrk = itau;
    if (ilv || ! wantsn) {
	*(unsigned char *)chtemp = 'S';
    } else {
	*(unsigned char *)chtemp = 'E';
    }

    i__1 = *lwork + 1 - iwrk;
    zhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
, ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[vr_offset], 
	    ldvr, &work[iwrk], &i__1, &rwork[1], &ierr);
    if (ierr != 0) {
	if (ierr > 0 && ierr <= *n) {
	    *info = ierr;
	} else if (ierr > *n && ierr <= *n << 1) {
	    *info = ierr - *n;
	} else {
	    *info = *n + 1;
	}
	goto L90;
    }

/*     Compute Eigenvectors and estimate condition numbers if desired */
/*     ZTGEVC: (Complex Workspace: need 2*N ) */
/*             (Real Workspace:    need 2*N ) */
/*     ZTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B') */
/*             (Integer Workspace: need N+2 ) */

    if (ilv || ! wantsn) {
	if (ilv) {
	    if (ilvl) {
		if (ilvr) {
		    *(unsigned char *)chtemp = 'B';
		} else {
		    *(unsigned char *)chtemp = 'L';
		}
	    } else {
		*(unsigned char *)chtemp = 'R';
	    }

	    ztgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], 
		    ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
		    work[iwrk], &rwork[1], &ierr);
	    if (ierr != 0) {
		*info = *n + 2;
		goto L90;
	    }
	}

	if (! wantsn) {

/*           compute eigenvectors (DTGEVC) and estimate condition */
/*           numbers (DTGSNA). Note that the definition of the condition */
/*           number is not invariant under transformation (u,v) to */
/*           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
/*           Schur form (S,T), Q and Z are orthogonal matrices. In order */
/*           to avoid using extra 2*N*N workspace, we have to */
/*           re-calculate eigenvectors and estimate the condition numbers */
/*           one at a time. */

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

		i__2 = *n;
		for (j = 1; j <= i__2; ++j) {
		    bwork[j] = FALSE_;
		}
		bwork[i__] = TRUE_;

		iwrk = *n + 1;
		iwrk1 = iwrk + *n;

		if (wantse || wantsb) {
		    ztgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
			    b_offset], ldb, &work[1], n, &work[iwrk], n, &
			    c__1, &m, &work[iwrk1], &rwork[1], &ierr);
		    if (ierr != 0) {
			*info = *n + 2;
			goto L90;
		    }
		}

		i__2 = *lwork - iwrk1 + 1;
		ztgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
			b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
			i__], &rcondv[i__], &c__1, &m, &work[iwrk1], &i__2, &
			iwork[1], &ierr);

	    }
	}
    }

/*     Undo balancing on VL and VR and normalization */
/*     (Workspace: none needed) */

    if (ilvl) {
	zggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
		vl_offset], ldvl, &ierr);

	i__1 = *n;
	for (jc = 1; jc <= i__1; ++jc) {
	    temp = 0.;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		i__3 = jr + jc * vl_dim1;
		d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&vl[jr + jc * vl_dim1]), abs(d__2));
		temp = max(d__3,d__4);
	    }
	    if (temp < smlnum) {
		goto L50;
	    }
	    temp = 1. / temp;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
		i__3 = jr + jc * vl_dim1;
		i__4 = jr + jc * vl_dim1;
		z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i;
		vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
	    }
L50:
	    ;
	}
    }

    if (ilvr) {
	zggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
		vr_offset], ldvr, &ierr);
	i__1 = *n;
	for (jc = 1; jc <= i__1; ++jc) {
	    temp = 0.;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		i__3 = jr + jc * vr_dim1;
		d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&vr[jr + jc * vr_dim1]), abs(d__2));
		temp = max(d__3,d__4);
	    }
	    if (temp < smlnum) {
		goto L80;
	    }
	    temp = 1. / temp;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
		i__3 = jr + jc * vr_dim1;
		i__4 = jr + jc * vr_dim1;
		z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i;
		vr[i__3].r = z__1.r, vr[i__3].i = z__1.i;
	    }
L80:
	    ;
	}
    }

/*     Undo scaling if necessary */

    if (ilascl) {
	zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
		ierr);
    }

    if (ilbscl) {
	zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
		ierr);
    }

L90:
    work[1].r = (doublereal) maxwrk, work[1].i = 0.;

    return 0;

/*     End of ZGGEVX */

} /* zggevx_ */
コード例 #18
0
/* Subroutine */ int zrqt02_(integer *m, integer *n, integer *k, 
	doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
	r__, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
	lwork, doublereal *rwork, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1, 
	    r_offset, i__1, i__2;

    /* Local variables */
    doublereal eps;
    integer info;
    doublereal resid, anorm;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZRQT02 tests ZUNGRQ, which generates an m-by-n matrix Q with */
/*  orthonornmal rows that is defined as the product of k elementary */
/*  reflectors. */

/*  Given the RQ factorization of an m-by-n matrix A, ZRQT02 generates */
/*  the orthogonal matrix Q defined by the factorization of the last k */
/*  rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/*  A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/*  orthonormal. */

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

/*  M       (input) INTEGER */
/*          The number of rows of the matrix Q to be generated.  M >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix Q to be generated. */
/*          N >= M >= 0. */

/*  K       (input) INTEGER */
/*          The number of elementary reflectors whose product defines the */
/*          matrix Q. M >= K >= 0. */

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The m-by-n matrix A which was factorized by ZRQT01. */

/*  AF      (input) COMPLEX*16 array, dimension (LDA,N) */
/*          Details of the RQ factorization of A, as returned by ZGERQF. */
/*          See ZGERQF for further details. */

/*  Q       (workspace) COMPLEX*16 array, dimension (LDA,N) */

/*  R       (workspace) COMPLEX*16 array, dimension (LDA,M) */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the arrays A, AF, Q and L. LDA >= N. */

/*  TAU     (input) COMPLEX*16 array, dimension (M) */
/*          The scalar factors of the elementary reflectors corresponding */
/*          to the RQ factorization in AF. */

/*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (M) */

/*  RESULT  (output) DOUBLE PRECISION array, dimension (2) */
/*          The test ratios: */
/*          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/*          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick return if possible */

    /* Parameter adjustments */
    r_dim1 = *lda;
    r_offset = 1 + r_dim1;
    r__ -= r_offset;
    q_dim1 = *lda;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    af_dim1 = *lda;
    af_offset = 1 + af_dim1;
    af -= af_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --tau;
    --work;
    --rwork;
    --result;

    /* Function Body */
    if (*m == 0 || *n == 0 || *k == 0) {
	result[1] = 0.;
	result[2] = 0.;
	return 0;
    }

    eps = dlamch_("Epsilon");

/*     Copy the last k rows of the factorization to the array Q */

    zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
    if (*k < *n) {
	i__1 = *n - *k;
	zlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k 
		+ 1 + q_dim1], lda);
    }
    if (*k > 1) {
	i__1 = *k - 1;
	i__2 = *k - 1;
	zlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) * 
		af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
    }

/*     Generate the last n rows of the matrix Q */

    s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
    zungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
	    info);

/*     Copy R(m-k+1:m,n-m+1:n) */

    zlaset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) * 
	    r_dim1], lda);
    zlacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
	    r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);

/*     Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */

    zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k 
	    + 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 + 
	    (*n - *m + 1) * r_dim1], lda);

/*     Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */

    anorm = zlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
    resid = zlange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1], 
	    lda, &rwork[1]);
    if (anorm > 0.) {
	result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
    } else {
	result[1] = 0.;
    }

/*     Compute I - Q*Q' */

    zlaset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
    zherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
	    r__[r_offset], lda);

/*     Compute norm( I - Q*Q' ) / ( N * EPS ) . */

    resid = zlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);

    result[2] = resid / (doublereal) max(1,*n) / eps;

    return 0;

/*     End of ZRQT02 */

} /* zrqt02_ */
コード例 #19
0
ファイル: zgeesx.c プロジェクト: MichaelH13/sdkpub
/* Subroutine */ int zgeesx_(char *jobvs, char *sort, L_fp select, char *
	sense, integer *n, doublecomplex *a, integer *lda, integer *sdim, 
	doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal *
	rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, 
	doublereal *rwork, logical *bwork, integer *info)
{
/*  -- LAPACK driver routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       June 30, 1999   


    Purpose   
    =======   

    ZGEESX 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*16 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*16 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*16 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*16 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) DOUBLE PRECISION   
            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) DOUBLE PRECISION   
            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*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).   
            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) DOUBLE PRECISION 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 */
    /* 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 doublereal anrm;
    static integer ierr, itau, iwrk, i__, k, icond, ieval;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    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 *), xerbla_(char *, 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 zgehrd_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *), zlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
	     integer *, integer *);
    static logical wantsb, wantse;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static integer minwrk, maxwrk;
    static logical wantsn;
    static doublereal smlnum;
    extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static integer hswork;
    extern /* Subroutine */ int zunghr_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *);
    static logical wantst, wantsv, wantvs;
    extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublereal *, doublereal *, 
	    doublecomplex *, integer *, integer *);
    static integer ihi, ilo;
    static doublereal dum[1], eps;


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --w;
    vs_dim1 = *ldvs;
    vs_offset = 1 + vs_dim1 * 1;
    vs -= vs_offset;
    --work;
    --rwork;
    --bwork;

    /* Function Body */
    *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 ZHSEQR, 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 ZTRSEN later   
         in the code.) */

    minwrk = 1;
    if (*info == 0 && *lwork >= 1) {
	maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &c__0, (
		ftnlen)6, (ftnlen)1);
/* Computing MAX */
	i__1 = 1, i__2 = *n << 1;
	minwrk = max(i__1,i__2);
	if (! wantvs) {
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", n, &c__1, n, &c_n1, (ftnlen)
		    6, (ftnlen)2);
	    maxb = max(i__1,2);
/* Computing MIN   
   Computing MAX */
	    i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SN", n, &c__1, n, &
		    c_n1, (ftnlen)6, (ftnlen)2);
	    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, "ZUNGHR", 
		    " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "ZHSEQR", "SV", n, &c__1, n, &c_n1, (ftnlen)
		    6, (ftnlen)2);
	    maxb = max(i__1,2);
/* Computing MIN   
   Computing MAX */
	    i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SV", n, &c__1, n, &
		    c_n1, (ftnlen)6, (ftnlen)2);
	    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 = (doublereal) maxwrk, work[1].i = 0.;
    }
    if (*lwork < minwrk) {
	*info = -15;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGEESX", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	*sdim = 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] */

    anrm = zlange_("M", n, n, &a[a_offset], 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[a_offset], lda, &
		ierr);
    }


/*     Permute the matrix to make it more nearly triangular   
       (CWorkspace: none)   
       (RWorkspace: need N) */

    ibal = 1;
    zgebal_("P", n, &a[a_offset], 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;
    zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
	     &ierr);

    if (wantvs) {

/*        Copy Householder vectors to VS */

	zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
		;

/*        Generate unitary matrix in VS   
          (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)   
          (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	zunghr_(n, &ilo, &ihi, &vs[vs_offset], 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;
    zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
	    vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
    if (ieval > 0) {
	*info = ieval;
    }

/*     Sort eigenvalues if desired */

    if (wantst && *info == 0) {
	if (scalea) {
	    zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
		    ierr);
	}
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++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;
	ztrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
		 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) */

	zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset], 
		ldvs, &ierr);
    }

    if (scalea) {

/*        Undo scaling for the Schur form of A */

	zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
		ierr);
	i__1 = *lda + 1;
	zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
	if ((wantsv || wantsb) && *info == 0) {
	    dum[0] = *rcondv;
	    dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
		    c__1, &ierr);
	    *rcondv = dum[0];
	}
    }

    work[1].r = (doublereal) maxwrk, work[1].i = 0.;
    return 0;

/*     End of ZGEESX */

} /* zgeesx_ */
コード例 #20
0
ファイル: zgges.c プロジェクト: GuillaumeFuchs/Ensimag
 int zgges_(char *jobvsl, char *jobvsr, char *sort, L_fp 
	selctg, int *n, doublecomplex *a, int *lda, doublecomplex *b, 
	int *ldb, int *sdim, doublecomplex *alpha, doublecomplex *
	beta, doublecomplex *vsl, int *ldvsl, doublecomplex *vsr, int 
	*ldvsr, doublecomplex *work, int *lwork, double *rwork, 
	int *bwork, int *info)
{
    /* System generated locals */
    int a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, 
	    vsr_dim1, vsr_offset, i__1, i__2;

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

    /* Local variables */
    int i__;
    double dif[2];
    int ihi, ilo;
    double eps, anrm, bnrm;
    int idum[1], ierr, itau, iwrk;
    double pvsl, pvsr;
    extern int lsame_(char *, char *);
    int ileft, icols;
    int cursl, ilvsl, ilvsr;
    int irwrk, irows;
    extern  int dlabad_(double *, double *);
    extern double dlamch_(char *);
    extern  int zggbak_(char *, char *, int *, int *, 
	    int *, double *, double *, int *, doublecomplex *, 
	     int *, int *), zggbal_(char *, int *, 
	     doublecomplex *, int *, doublecomplex *, int *, int *
, int *, double *, double *, double *, int *);
    int ilascl, ilbscl;
    extern  int xerbla_(char *, int *);
    extern int ilaenv_(int *, char *, char *, int *, int *, 
	    int *, int *);
    extern double zlange_(char *, int *, int *, doublecomplex *, 
	    int *, double *);
    double bignum;
    int ijobvl, iright;
    extern  int zgghrd_(char *, char *, int *, int *, 
	    int *, doublecomplex *, int *, doublecomplex *, int *, 
	     doublecomplex *, int *, doublecomplex *, int *, int *
), zlascl_(char *, int *, int *, 
	    double *, double *, int *, int *, doublecomplex *, 
	     int *, int *);
    int ijobvr;
    extern  int zgeqrf_(int *, int *, doublecomplex *, 
	     int *, doublecomplex *, doublecomplex *, int *, int *
);
    double anrmto;
    int lwkmin;
    int lastsl;
    double bnrmto;
    extern  int zlacpy_(char *, int *, int *, 
	    doublecomplex *, int *, doublecomplex *, int *), 
	    zlaset_(char *, int *, int *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, int *), zhgeqz_(
	    char *, char *, char *, int *, int *, int *, 
	    doublecomplex *, int *, doublecomplex *, int *, 
	    doublecomplex *, doublecomplex *, doublecomplex *, int *, 
	    doublecomplex *, int *, doublecomplex *, int *, 
	    double *, int *), ztgsen_(int 
	    *, int *, int *, int *, int *, doublecomplex *, 
	    int *, doublecomplex *, int *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, int *, doublecomplex *, 
	    int *, int *, double *, double *, double *, 
	    doublecomplex *, int *, int *, int *, int *);
    double smlnum;
    int wantst, lquery;
    int lwkopt;
    extern  int zungqr_(int *, int *, int *, 
	    doublecomplex *, int *, doublecomplex *, doublecomplex *, 
	    int *, int *), zunmqr_(char *, char *, int *, int 
	    *, int *, doublecomplex *, int *, doublecomplex *, 
	    doublecomplex *, int *, doublecomplex *, int *, int *);


/*  -- LAPACK driver routine (version 3.2) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */
/*     .. Function Arguments .. */
/*     .. */

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

/*  ZGGES computes for a pair of N-by-N complex nonsymmetric matrices */
/*  (A,B), the generalized eigenvalues, the generalized complex Schur */
/*  form (S, T), and optionally left and/or right Schur vectors (VSL */
/*  and VSR). This gives the generalized Schur factorization */

/*          (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) */

/*  where (VSR)**H is the conjugate-transpose of VSR. */

/*  Optionally, it also orders the eigenvalues so that a selected cluster */
/*  of eigenvalues appears in the leading diagonal blocks of the upper */
/*  triangular matrix S and the upper triangular matrix T. The leading */
/*  columns of VSL and VSR then form an unitary basis for the */
/*  corresponding left and right eigenspaces (deflating subspaces). */

/*  (If only the generalized eigenvalues are needed, use the driver */
/*  ZGGEV instead, which is faster.) */

/*  A generalized eigenvalue for a pair of matrices (A,B) is 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 pair of matrices (S,T) is in generalized complex Schur form if S */
/*  and T are upper triangular and, in addition, the diagonal elements */
/*  of T are non-negative float numbers. */

/*  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. */

/*  SORT    (input) CHARACTER*1 */
/*          Specifies whether or not to order the eigenvalues on the */
/*          diagonal of the generalized Schur form. */
/*          = 'N':  Eigenvalues are not ordered; */
/*          = 'S':  Eigenvalues are ordered (see SELCTG). */

/*  SELCTG  (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments */
/*          SELCTG must be declared EXTERNAL in the calling subroutine. */
/*          If SORT = 'N', SELCTG is not referenced. */
/*          If SORT = 'S', SELCTG is used to select eigenvalues to sort */
/*          to the top left of the Schur form. */
/*          An eigenvalue ALPHA(j)/BETA(j) is selected if */
/*          SELCTG(ALPHA(j),BETA(j)) is true. */

/*          Note that a selected complex eigenvalue may no longer satisfy */
/*          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since */
/*          ordering may change the value of complex eigenvalues */
/*          (especially if the eigenvalue is ill-conditioned), in this */
/*          case INFO is set to N+2 (See INFO below). */

/*  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. */
/*          On exit, A has been overwritten by its generalized Schur */
/*          form S. */

/*  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. */
/*          On exit, B has been overwritten by its generalized Schur */
/*          form T. */

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

/*  SDIM    (output) INTEGER */
/*          If SORT = 'N', SDIM = 0. */
/*          If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/*          for which SELCTG is true. */

/*  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 ZGGES. The  BETA(j) will be non-negative float. */

/*          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. */
/*          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. */
/*          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 (MAX(1,LWORK)) */
/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK.  LWORK >= MAX(1,2*N). */
/*          For good performance, LWORK must 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. */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (8*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. */
/*          =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:  =N+1: other than QZ iteration failed in ZHGEQZ */
/*                =N+2: after reordering, roundoff changed values of */
/*                      some complex eigenvalues so that leading */
/*                      eigenvalues in the Generalized Schur form no */
/*                      longer satisfy SELCTG=.TRUE.  This could also */
/*                      be caused due to scaling. */
/*                =N+3: reordering falied in ZTGSEN. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Decode the input arguments */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --alpha;
    --beta;
    vsl_dim1 = *ldvsl;
    vsl_offset = 1 + vsl_dim1;
    vsl -= vsl_offset;
    vsr_dim1 = *ldvsr;
    vsr_offset = 1 + vsr_dim1;
    vsr -= vsr_offset;
    --work;
    --rwork;
    --bwork;

    /* Function Body */
    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;
    }

    wantst = lsame_(sort, "S");

/*     Test the input arguments */

    *info = 0;
    lquery = *lwork == -1;
    if (ijobvl <= 0) {
	*info = -1;
    } else if (ijobvr <= 0) {
	*info = -2;
    } else if (! wantst && ! lsame_(sort, "N")) {
	*info = -3;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < MAX(1,*n)) {
	*info = -7;
    } else if (*ldb < MAX(1,*n)) {
	*info = -9;
    } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
	*info = -14;
    } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
	*info = -16;
    }

/*     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. */
/*       NB refers to the optimal block size for the immediately */
/*       following subroutine, as returned by ILAENV.) */

    if (*info == 0) {
/* Computing MAX */
	i__1 = 1, i__2 = *n << 1;
	lwkmin = MAX(i__1,i__2);
/* Computing MAX */
	i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &c__1, n, 
		&c__0);
	lwkopt = MAX(i__1,i__2);
/* Computing MAX */
	i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
		c__1, n, &c_n1);
	lwkopt = MAX(i__1,i__2);
	if (ilvsl) {
/* Computing MAX */
	    i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", n, &
		    c__1, n, &c_n1);
	    lwkopt = MAX(i__1,i__2);
	}
	work[1].r = (double) lwkopt, work[1].i = 0.;

	if (*lwork < lwkmin && ! lquery) {
	    *info = -18;
	}
    }

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

/*     Quick return if possible */

    if (*n == 0) {
	*sdim = 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] */

    anrm = zlange_("M", n, n, &a[a_offset], 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__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
		ierr);
    }

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

    bnrm = zlange_("M", n, n, &b[b_offset], 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__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
		ierr);
    }

/*     Permute the matrix to make it more nearly triangular */
/*     (Real Workspace: need 6*N) */

    ileft = 1;
    iright = *n + 1;
    irwrk = iright + *n;
    zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
	    ileft], &rwork[iright], &rwork[irwrk], &ierr);

/*     Reduce B to triangular form (QR decomposition of B) */
/*     (Complex Workspace: need N, prefer N*NB) */

    irows = ihi + 1 - ilo;
    icols = *n + 1 - ilo;
    itau = 1;
    iwrk = itau + irows;
    i__1 = *lwork + 1 - iwrk;
    zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
	    iwrk], &i__1, &ierr);

/*     Apply the orthogonal transformation to matrix A */
/*     (Complex Workspace: need N, prefer N*NB) */

    i__1 = *lwork + 1 - iwrk;
    zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
	    work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
	    ierr);

/*     Initialize VSL */
/*     (Complex Workspace: need N, prefer N*NB) */

    if (ilvsl) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
	if (irows > 1) {
	    i__1 = irows - 1;
	    i__2 = irows - 1;
	    zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
		    ilo + 1 + ilo * vsl_dim1], ldvsl);
	}
	i__1 = *lwork + 1 - iwrk;
	zungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
		work[itau], &work[iwrk], &i__1, &ierr);
    }

/*     Initialize VSR */

    if (ilvsr) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
    }

/*     Reduce to generalized Hessenberg form */
/*     (Workspace: none needed) */

    zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], 
	    ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);

    *sdim = 0;

/*     Perform QZ algorithm, computing Schur vectors if desired */
/*     (Complex Workspace: need N) */
/*     (Real Workspace: need N) */

    iwrk = itau;
    i__1 = *lwork + 1 - iwrk;
    zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
	    b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
	    vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
    if (ierr != 0) {
	if (ierr > 0 && ierr <= *n) {
	    *info = ierr;
	} else if (ierr > *n && ierr <= *n << 1) {
	    *info = ierr - *n;
	} else {
	    *info = *n + 1;
	}
	goto L30;
    }

/*     Sort eigenvalues ALPHA/BETA if desired */
/*     (Workspace: none needed) */

    if (wantst) {

/*        Undo scaling on eigenvalues before selecting */

	if (ilascl) {
	    zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, &c__1, &alpha[1], n, 
		     &ierr);
	}
	if (ilbscl) {
	    zlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, &c__1, &beta[1], n, 
		    &ierr);
	}

/*        Select eigenvalues */

	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
/* L10: */
	}

	i__1 = *lwork - iwrk + 1;
	ztgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
		b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, 
		&vsr[vsr_offset], ldvsr, sdim, &pvsl, &pvsr, dif, &work[iwrk], 
		 &i__1, idum, &c__1, &ierr);
	if (ierr == 1) {
	    *info = *n + 3;
	}

    }

/*     Apply back-permutation to VSL and VSR */
/*     (Workspace: none needed) */

    if (ilvsl) {
	zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
		vsl[vsl_offset], ldvsl, &ierr);
    }
    if (ilvsr) {
	zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
		vsr[vsr_offset], ldvsr, &ierr);
    }

/*     Undo scaling */

    if (ilascl) {
	zlascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
		ierr);
	zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
		ierr);
    }

    if (ilbscl) {
	zlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
		ierr);
	zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
		ierr);
    }

    if (wantst) {

/*        Check if reordering is correct */

	lastsl = TRUE;
	*sdim = 0;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    cursl = (*selctg)(&alpha[i__], &beta[i__]);
	    if (cursl) {
		++(*sdim);
	    }
	    if (cursl && ! lastsl) {
		*info = *n + 2;
	    }
	    lastsl = cursl;
/* L20: */
	}

    }

L30:

    work[1].r = (double) lwkopt, work[1].i = 0.;

    return 0;

/*     End of ZGGES */

} /* zgges_ */
コード例 #21
0
ファイル: zdrvrf4.c プロジェクト: 3deggi/levmar-ndk
/* Subroutine */ int zdrvrf4_(integer *nout, integer *nn, integer *nval, 
	doublereal *thresh, doublecomplex *c1, doublecomplex *c2, integer *
	ldc, doublecomplex *crf, doublecomplex *a, integer *lda, doublereal *
	d_work_zlange__)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };
    static char uplos[1*2] = "U" "L";
    static char forms[1*2] = "N" "C";
    static char transs[1*2] = "N" "C";

    /* Format strings */
    static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
	    "ing ZHFRK               ***\002)";
    static char fmt_9997[] = "(1x,\002     Failure in \002,a5,\002, CFORM="
	    "'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
	    "'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
	    "=\002,g12.5)";
    static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
	    "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
	    "\002)";
    static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
	    " of \002,i5,\002 tests failed to pass the threshold\002)";

    /* System generated locals */
    integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1, 
	    i__2, i__3, i__4, i__5, i__6, i__7;
    doublereal d__1;
    doublecomplex z__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void), 
	    do_fio(integer *, char *, ftnlen);

    /* Local variables */
    integer i__, j, k, n, iik, iin;
    doublereal eps, beta;
    integer info;
    char uplo[1];
    integer nrun;
    doublereal alpha;
    integer nfail, iseed[4];
    char cform[1];
    integer iform;
    doublereal norma, normc;
    extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *, 
	    doublereal *, doublecomplex *, integer *, doublereal *, 
	    doublecomplex *, integer *), zhfrk_(char *, char *
, char *, integer *, integer *, doublereal *, doublecomplex *, 
	    integer *, doublereal *, doublecomplex *);
    char trans[1];
    integer iuplo;
    extern doublereal dlamch_(char *);
    integer ialpha;
    extern doublereal dlarnd_(integer *, integer *), zlange_(char *, integer *
, integer *, doublecomplex *, integer *, doublereal *);
    extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, 
	    integer *);
    integer itrans;
    doublereal result[1];
    extern /* Subroutine */ int ztfttr_(char *, char *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, integer *), ztrttf_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *);

    /* Fortran I/O blocks */
    static cilist io___28 = { 0, 0, 0, 0, 0 };
    static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };



/*  -- LAPACK test routine (version 3.2.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2008 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZDRVRF4 tests the LAPACK RFP routines: */
/*      ZHFRK */

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

/*  NOUT          (input) INTEGER */
/*                The unit number for output. */

/*  NN            (input) INTEGER */
/*                The number of values of N contained in the vector NVAL. */

/*  NVAL          (input) INTEGER array, dimension (NN) */
/*                The values of the matrix dimension N. */

/*  THRESH        (input) DOUBLE PRECISION */
/*                The threshold value for the test ratios.  A result is */
/*                included in the output file if RESULT >= THRESH.  To have */
/*                every test ratio printed, use THRESH = 0. */

/*  C1            (workspace) COMPLEX*16 array, dimension (LDC,NMAX) */

/*  C2            (workspace) COMPLEX*16 array, dimension (LDC,NMAX) */

/*  LDC           (input) INTEGER */
/*                The leading dimension of the array A.  LDA >= max(1,NMAX). */

/*  CRF           (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */

/*  A             (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */

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

/*  D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */

/*  ===================================================================== */
/*     .. */
/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --nval;
    c2_dim1 = *ldc;
    c2_offset = 1 + c2_dim1;
    c2 -= c2_offset;
    c1_dim1 = *ldc;
    c1_offset = 1 + c1_dim1;
    c1 -= c1_offset;
    --crf;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --d_work_zlange__;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Initialize constants and the random number seed. */

    nrun = 0;
    nfail = 0;
    info = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
    }
    eps = dlamch_("Precision");

    i__1 = *nn;
    for (iin = 1; iin <= i__1; ++iin) {

	n = nval[iin];

	i__2 = *nn;
	for (iik = 1; iik <= i__2; ++iik) {

	    k = nval[iin];

	    for (iform = 1; iform <= 2; ++iform) {

		*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];

		for (iuplo = 1; iuplo <= 2; ++iuplo) {

		    *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 
			    1];

		    for (itrans = 1; itrans <= 2; ++itrans) {

			*(unsigned char *)trans = *(unsigned char *)&transs[
				itrans - 1];

			for (ialpha = 1; ialpha <= 4; ++ialpha) {

			    if (ialpha == 1) {
				alpha = 0.;
				beta = 0.;
			    } else if (ialpha == 1) {
				alpha = 1.;
				beta = 0.;
			    } else if (ialpha == 1) {
				alpha = 0.;
				beta = 1.;
			    } else {
				alpha = dlarnd_(&c__2, iseed);
				beta = dlarnd_(&c__2, iseed);
			    }

/*                       All the parameters are set: */
/*                          CFORM, UPLO, TRANS, M, N, */
/*                          ALPHA, and BETA */
/*                       READY TO TEST! */

			    ++nrun;

			    if (itrans == 1) {

/*                          In this case we are NOTRANS, so A is N-by-K */

				i__3 = k;
				for (j = 1; j <= i__3; ++j) {
				    i__4 = n;
				    for (i__ = 1; i__ <= i__4; ++i__) {
					i__5 = i__ + j * a_dim1;
					zlarnd_(&z__1, &c__4, iseed);
					a[i__5].r = z__1.r, a[i__5].i = 
						z__1.i;
				    }
				}

				norma = zlange_("I", &n, &k, &a[a_offset], 
					lda, &d_work_zlange__[1]);

			    } else {

/*                          In this case we are TRANS, so A is K-by-N */

				i__3 = n;
				for (j = 1; j <= i__3; ++j) {
				    i__4 = k;
				    for (i__ = 1; i__ <= i__4; ++i__) {
					i__5 = i__ + j * a_dim1;
					zlarnd_(&z__1, &c__4, iseed);
					a[i__5].r = z__1.r, a[i__5].i = 
						z__1.i;
				    }
				}

				norma = zlange_("I", &k, &n, &a[a_offset], 
					lda, &d_work_zlange__[1]);

			    }


/*                       Generate C1 our N--by--N Hermitian matrix. */
/*                       Make sure C2 has the same upper/lower part, */
/*                       (the one that we do not touch), so */
/*                       copy the initial C1 in C2 in it. */

			    i__3 = n;
			    for (j = 1; j <= i__3; ++j) {
				i__4 = n;
				for (i__ = 1; i__ <= i__4; ++i__) {
				    i__5 = i__ + j * c1_dim1;
				    zlarnd_(&z__1, &c__4, iseed);
				    c1[i__5].r = z__1.r, c1[i__5].i = z__1.i;
				    i__5 = i__ + j * c2_dim1;
				    i__6 = i__ + j * c1_dim1;
				    c2[i__5].r = c1[i__6].r, c2[i__5].i = c1[
					    i__6].i;
				}
			    }

/*                       (See comment later on for why we use ZLANGE and */
/*                       not ZLANHE for C1.) */

			    normc = zlange_("I", &n, &n, &c1[c1_offset], ldc, 
				    &d_work_zlange__[1]);

			    s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (
				    ftnlen)6);
			    ztrttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
				    crf[1], &info);

/*                       call zherk the BLAS routine -> gives C1 */

			    s_copy(srnamc_1.srnamt, "ZHERK ", (ftnlen)32, (
				    ftnlen)6);
			    zherk_(uplo, trans, &n, &k, &alpha, &a[a_offset], 
				    lda, &beta, &c1[c1_offset], ldc);

/*                       call zhfrk the RFP routine -> gives CRF */

			    s_copy(srnamc_1.srnamt, "ZHFRK ", (ftnlen)32, (
				    ftnlen)6);
			    zhfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
				    a_offset], lda, &beta, &crf[1]);

/*                       convert CRF in full format -> gives C2 */

			    s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (
				    ftnlen)6);
			    ztfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset], 
				    ldc, &info);

/*                       compare C1 and C2 */

			    i__3 = n;
			    for (j = 1; j <= i__3; ++j) {
				i__4 = n;
				for (i__ = 1; i__ <= i__4; ++i__) {
				    i__5 = i__ + j * c1_dim1;
				    i__6 = i__ + j * c1_dim1;
				    i__7 = i__ + j * c2_dim1;
				    z__1.r = c1[i__6].r - c2[i__7].r, z__1.i =
					     c1[i__6].i - c2[i__7].i;
				    c1[i__5].r = z__1.r, c1[i__5].i = z__1.i;
				}
			    }

/*                       Yes, C1 is Hermitian so we could call ZLANHE, */
/*                       but we want to check the upper part that is */
/*                       supposed to be unchanged and the diagonal that */
/*                       is supposed to be real -> ZLANGE */

			    result[0] = zlange_("I", &n, &n, &c1[c1_offset], 
				    ldc, &d_work_zlange__[1]);
/* Computing MAX */
			    d__1 = abs(alpha) * norma * norma + abs(beta) * 
				    normc;
			    result[0] = result[0] / max(d__1,1.) / max(n,1) / 
				    eps;

			    if (result[0] >= *thresh) {
				if (nfail == 0) {
				    io___28.ciunit = *nout;
				    s_wsle(&io___28);
				    e_wsle();
				    io___29.ciunit = *nout;
				    s_wsfe(&io___29);
				    e_wsfe();
				}
				io___30.ciunit = *nout;
				s_wsfe(&io___30);
				do_fio(&c__1, "ZHFRK", (ftnlen)5);
				do_fio(&c__1, cform, (ftnlen)1);
				do_fio(&c__1, uplo, (ftnlen)1);
				do_fio(&c__1, trans, (ftnlen)1);
				do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&result[0], (ftnlen)
					sizeof(doublereal));
				e_wsfe();
				++nfail;
			    }

/* L100: */
			}
/* L110: */
		    }
/* L120: */
		}
/* L130: */
	    }
/* L140: */
	}
/* L150: */
    }

/*     Print a summary of the results. */

    if (nfail == 0) {
	io___31.ciunit = *nout;
	s_wsfe(&io___31);
	do_fio(&c__1, "ZHFRK", (ftnlen)5);
	do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
	e_wsfe();
    } else {
	io___32.ciunit = *nout;
	s_wsfe(&io___32);
	do_fio(&c__1, "ZHFRK", (ftnlen)5);
	do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
	e_wsfe();
    }


    return 0;

/*     End of ZDRVRF4 */

} /* zdrvrf4_ */
コード例 #22
0
ファイル: zggev.c プロジェクト: 0u812/roadrunner-backup
/* Subroutine */ int zggev_(char *jobvl, char *jobvr, integer *n, 
	doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 
	doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer 
	*ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer 
	*lwork, doublereal *rwork, integer *info)
{
    /* 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;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;

    /* Builtin functions */
    double sqrt(doublereal), d_imag(doublecomplex *);

    /* Local variables */
    integer jc, in, jr, ihi, ilo;
    doublereal eps;
    logical ilv;
    doublereal anrm, bnrm;
    integer ierr, itau;
    doublereal temp;
    logical ilvl, ilvr;
    integer iwrk;
    extern logical lsame_(char *, char *);
    integer ileft, icols, irwrk, irows;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    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 *);
    logical ilascl, ilbscl;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *);
    logical ldumma[1];
    char chtemp[1];
    doublereal bignum;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    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 *);
    integer ijobvr;
    extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *, 
	     integer *, doublecomplex *, doublecomplex *, integer *, integer *
);
    doublereal anrmto;
    integer lwkmin;
    doublereal bnrmto;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    zlaset_(char *, integer *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *), ztgevc_(
	    char *, char *, logical *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, doublecomplex *, 
	     doublereal *, integer *), zhgeqz_(char *, char *, 
	     char *, integer *, integer *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, doublereal *, integer *);
    doublereal smlnum;
    integer lwkopt;
    logical lquery;
    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 *);


/*  -- LAPACK driver routine (version 3.2) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices */
/*  (A,B), the generalized eigenvalues, and optionally, the left and/or */
/*  right generalized eigenvectors. */

/*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
/*  lambda or a ratio alpha/beta = lambda, such that A - lambda*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. */

/*  The right generalized eigenvector v(j) corresponding to the */
/*  generalized eigenvalue lambda(j) of (A,B) satisfies */

/*               A * v(j) = lambda(j) * B * v(j). */

/*  The left generalized eigenvector u(j) corresponding to the */
/*  generalized eigenvalues lambda(j) of (A,B) satisfies */

/*               u(j)**H * A = lambda(j) * u(j)**H * B */

/*  where u(j)**H is the conjugate-transpose of u(j). */

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

/*  JOBVL   (input) CHARACTER*1 */
/*          = 'N':  do not compute the left generalized eigenvectors; */
/*          = 'V':  compute the left generalized eigenvectors. */

/*  JOBVR   (input) CHARACTER*1 */
/*          = 'N':  do not compute the right generalized eigenvectors; */
/*          = 'V':  compute the right generalized eigenvectors. */

/*  N       (input) INTEGER */
/*          The order of the matrices A, B, VL, and VR.  N >= 0. */

/*  A       (input/output) COMPLEX*16 array, dimension (LDA, N) */
/*          On entry, the matrix A in the pair (A,B). */
/*          On exit, A has been overwritten. */

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

/*  B       (input/output) COMPLEX*16 array, dimension (LDB, N) */
/*          On entry, the matrix B in the pair (A,B). */
/*          On exit, B has been overwritten. */

/*  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. */

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

/*  VL      (output) COMPLEX*16 array, dimension (LDVL,N) */
/*          If JOBVL = 'V', the left generalized eigenvectors u(j) are */
/*          stored one after another in the columns of VL, in the same */
/*          order as their eigenvalues. */
/*          Each eigenvector is scaled so the largest component has */
/*          abs(real part) + abs(imag. part) = 1. */
/*          Not referenced if JOBVL = 'N'. */

/*  LDVL    (input) INTEGER */
/*          The leading dimension of the matrix VL. LDVL >= 1, and */
/*          if JOBVL = 'V', LDVL >= N. */

/*  VR      (output) COMPLEX*16 array, dimension (LDVR,N) */
/*          If JOBVR = 'V', the right generalized eigenvectors v(j) are */
/*          stored one after another in the columns of VR, in the same */
/*          order as their eigenvalues. */
/*          Each eigenvector is scaled so the largest component has */
/*          abs(real part) + abs(imag. part) = 1. */
/*          Not referenced if JOBVR = 'N'. */

/*  LDVR    (input) INTEGER */
/*          The leading dimension of the matrix VR. LDVR >= 1, and */
/*          if JOBVR = 'V', LDVR >= N. */

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

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK.  LWORK >= max(1,2*N). */
/*          For good performance, LWORK must 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. */

/*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (8*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.  No eigenvectors have been */
/*                calculated, but ALPHA(j) and BETA(j) should be */
/*                correct for j=INFO+1,...,N. */
/*          > N:  =N+1: other then QZ iteration failed in DHGEQZ, */
/*                =N+2: error return from DTGEVC. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Statement Functions .. */
/*     .. */
/*     .. Statement Function definitions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Decode the input arguments */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --alpha;
    --beta;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --work;
    --rwork;

    /* Function Body */
    if (lsame_(jobvl, "N")) {
	ijobvl = 1;
	ilvl = FALSE_;
    } else if (lsame_(jobvl, "V")) {
	ijobvl = 2;
	ilvl = TRUE_;
    } else {
	ijobvl = -1;
	ilvl = FALSE_;
    }

    if (lsame_(jobvr, "N")) {
	ijobvr = 1;
	ilvr = FALSE_;
    } else if (lsame_(jobvr, "V")) {
	ijobvr = 2;
	ilvr = TRUE_;
    } else {
	ijobvr = -1;
	ilvr = FALSE_;
    }
    ilv = ilvl || ilvr;

/*     Test the input arguments */

    *info = 0;
    lquery = *lwork == -1;
    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 (*ldvl < 1 || ilvl && *ldvl < *n) {
	*info = -11;
    } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
	*info = -13;
    }

/*     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. */
/*       NB refers to the optimal block size for the immediately */
/*       following subroutine, as returned by ILAENV. The workspace is */
/*       computed assuming ILO = 1 and IHI = N, the worst case.) */

    if (*info == 0) {
/* Computing MAX */
	i__1 = 1, i__2 = *n << 1;
	lwkmin = max(i__1,i__2);
/* Computing MAX */
	i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &c__1, n, 
		&c__0);
	lwkopt = max(i__1,i__2);
/* Computing MAX */
	i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
		c__1, n, &c__0);
	lwkopt = max(i__1,i__2);
	if (ilvl) {
/* Computing MAX */
	    i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", n, &
		    c__1, n, &c_n1);
	    lwkopt = max(i__1,i__2);
	}
	work[1].r = (doublereal) lwkopt, work[1].i = 0.;

	if (*lwork < lwkmin && ! lquery) {
	    *info = -15;
	}
    }

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

/*     Quick return if possible */

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

/*     Get machine constants */

    eps = dlamch_("E") * dlamch_("B");
    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] */

    anrm = zlange_("M", n, n, &a[a_offset], 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__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
		ierr);
    }

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

    bnrm = zlange_("M", n, n, &b[b_offset], 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__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
		ierr);
    }

/*     Permute the matrices A, B to isolate eigenvalues if possible */
/*     (Real Workspace: need 6*N) */

    ileft = 1;
    iright = *n + 1;
    irwrk = iright + *n;
    zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
	    ileft], &rwork[iright], &rwork[irwrk], &ierr);

/*     Reduce B to triangular form (QR decomposition of B) */
/*     (Complex Workspace: need N, prefer N*NB) */

    irows = ihi + 1 - ilo;
    if (ilv) {
	icols = *n + 1 - ilo;
    } else {
	icols = irows;
    }
    itau = 1;
    iwrk = itau + irows;
    i__1 = *lwork + 1 - iwrk;
    zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
	    iwrk], &i__1, &ierr);

/*     Apply the orthogonal transformation to matrix A */
/*     (Complex Workspace: need N, prefer N*NB) */

    i__1 = *lwork + 1 - iwrk;
    zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
	    work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
	    ierr);

/*     Initialize VL */
/*     (Complex Workspace: need N, prefer N*NB) */

    if (ilvl) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
	if (irows > 1) {
	    i__1 = irows - 1;
	    i__2 = irows - 1;
	    zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[
		    ilo + 1 + ilo * vl_dim1], ldvl);
	}
	i__1 = *lwork + 1 - iwrk;
	zungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
		itau], &work[iwrk], &i__1, &ierr);
    }

/*     Initialize VR */

    if (ilvr) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
    }

/*     Reduce to generalized Hessenberg form */

    if (ilv) {

/*        Eigenvectors requested -- work on whole matrix. */

	zgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], 
		ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
    } else {
	zgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, 
		&b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
		vr_offset], ldvr, &ierr);
    }

/*     Perform QZ algorithm (Compute eigenvalues, and optionally, the */
/*     Schur form and Schur vectors) */
/*     (Complex Workspace: need N) */
/*     (Real Workspace: need N) */

    iwrk = itau;
    if (ilv) {
	*(unsigned char *)chtemp = 'S';
    } else {
	*(unsigned char *)chtemp = 'E';
    }
    i__1 = *lwork + 1 - iwrk;
    zhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
	    b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
	    vr_offset], ldvr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
    if (ierr != 0) {
	if (ierr > 0 && ierr <= *n) {
	    *info = ierr;
	} else if (ierr > *n && ierr <= *n << 1) {
	    *info = ierr - *n;
	} else {
	    *info = *n + 1;
	}
	goto L70;
    }

/*     Compute Eigenvectors */
/*     (Real Workspace: need 2*N) */
/*     (Complex Workspace: need 2*N) */

    if (ilv) {
	if (ilvl) {
	    if (ilvr) {
		*(unsigned char *)chtemp = 'B';
	    } else {
		*(unsigned char *)chtemp = 'L';
	    }
	} else {
	    *(unsigned char *)chtemp = 'R';
	}

	ztgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, 
		&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
		iwrk], &rwork[irwrk], &ierr);
	if (ierr != 0) {
	    *info = *n + 2;
	    goto L70;
	}

/*        Undo balancing on VL and VR and normalization */
/*        (Workspace: none needed) */

	if (ilvl) {
	    zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, 
		     &vl[vl_offset], ldvl, &ierr);
	    i__1 = *n;
	    for (jc = 1; jc <= i__1; ++jc) {
		temp = 0.;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    i__3 = jr + jc * vl_dim1;
		    d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (
			    d__2 = d_imag(&vl[jr + jc * vl_dim1]), abs(d__2));
		    temp = max(d__3,d__4);
/* L10: */
		}
		if (temp < smlnum) {
		    goto L30;
		}
		temp = 1. / temp;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    i__3 = jr + jc * vl_dim1;
		    i__4 = jr + jc * vl_dim1;
		    z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i;
		    vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
/* L20: */
		}
L30:
		;
	    }
	}
	if (ilvr) {
	    zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, 
		     &vr[vr_offset], ldvr, &ierr);
	    i__1 = *n;
	    for (jc = 1; jc <= i__1; ++jc) {
		temp = 0.;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    i__3 = jr + jc * vr_dim1;
		    d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (
			    d__2 = d_imag(&vr[jr + jc * vr_dim1]), abs(d__2));
		    temp = max(d__3,d__4);
/* L40: */
		}
		if (temp < smlnum) {
		    goto L60;
		}
		temp = 1. / temp;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    i__3 = jr + jc * vr_dim1;
		    i__4 = jr + jc * vr_dim1;
		    z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i;
		    vr[i__3].r = z__1.r, vr[i__3].i = z__1.i;
/* L50: */
		}
L60:
		;
	    }
	}
    }

/*     Undo scaling if necessary */

    if (ilascl) {
	zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
		ierr);
    }

    if (ilbscl) {
	zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
		ierr);
    }

L70:
    work[1].r = (doublereal) lwkopt, work[1].i = 0.;

    return 0;

/*     End of ZGGEV */

} /* zggev_ */
コード例 #23
0
ファイル: zget22.c プロジェクト: 3deggi/levmar-ndk
/* Subroutine */ int zget22_(char *transa, char *transe, char *transw, 
	integer *n, doublecomplex *a, integer *lda, doublecomplex *e, integer 
	*lde, doublecomplex *w, doublecomplex *work, doublereal *rwork, 
	doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1, z__2;

    /* Builtin functions */
    double d_imag(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *);

    /* Local variables */
    integer j;
    doublereal ulp;
    integer joff, jcol, jvec;
    doublereal unfl;
    integer jrow;
    doublereal temp1;
    extern logical lsame_(char *, char *);
    char norma[1];
    doublereal anorm;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    char norme[1];
    doublereal enorm;
    doublecomplex wtemp;
    extern doublereal dlamch_(char *), zlange_(char *, integer *, 
	    integer *, doublecomplex *, integer *, doublereal *);
    doublereal enrmin, enrmax;
    extern /* Subroutine */ int zlaset_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, doublecomplex *, integer *);
    integer itrnse;
    doublereal errnrm;
    integer itrnsw;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZGET22 does an eigenvector check. */

/*  The basic test is: */

/*     RESULT(1) = | A E  -  E W | / ( |A| |E| ulp ) */

/*  using the 1-norm.  It also tests the normalization of E: */

/*     RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/*                  j */

/*  where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
/*  vector.  The max-norm of a complex n-vector x in this case is the */
/*  maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n. */

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

/*  TRANSA  (input) CHARACTER*1 */
/*          Specifies whether or not A is transposed. */
/*          = 'N':  No transpose */
/*          = 'T':  Transpose */
/*          = 'C':  Conjugate transpose */

/*  TRANSE  (input) CHARACTER*1 */
/*          Specifies whether or not E is transposed. */
/*          = 'N':  No transpose, eigenvectors are in columns of E */
/*          = 'T':  Transpose, eigenvectors are in rows of E */
/*          = 'C':  Conjugate transpose, eigenvectors are in rows of E */

/*  TRANSW  (input) CHARACTER*1 */
/*          Specifies whether or not W is transposed. */
/*          = 'N':  No transpose */
/*          = 'T':  Transpose, same as TRANSW = 'N' */
/*          = 'C':  Conjugate transpose, use -WI(j) instead of WI(j) */

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

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The matrix whose eigenvectors are in E. */

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

/*  E       (input) COMPLEX*16 array, dimension (LDE,N) */
/*          The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
/*          are stored in the columns of E, if TRANSE = 'T' or 'C', the */
/*          eigenvectors are stored in the rows of E. */

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

/*  W       (input) COMPLEX*16 array, dimension (N) */
/*          The eigenvalues of A. */

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

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

/*  RESULT  (output) DOUBLE PRECISION array, dimension (2) */
/*          RESULT(1) = | A E  -  E W | / ( |A| |E| ulp ) */
/*          RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/*                       j */
/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Initialize RESULT (in case N=0) */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    e_dim1 = *lde;
    e_offset = 1 + e_dim1;
    e -= e_offset;
    --w;
    --work;
    --rwork;
    --result;

    /* Function Body */
    result[1] = 0.;
    result[2] = 0.;
    if (*n <= 0) {
	return 0;
    }

    unfl = dlamch_("Safe minimum");
    ulp = dlamch_("Precision");

    itrnse = 0;
    itrnsw = 0;
    *(unsigned char *)norma = 'O';
    *(unsigned char *)norme = 'O';

    if (lsame_(transa, "T") || lsame_(transa, "C")) {
	*(unsigned char *)norma = 'I';
    }

    if (lsame_(transe, "T")) {
	itrnse = 1;
	*(unsigned char *)norme = 'I';
    } else if (lsame_(transe, "C")) {
	itrnse = 2;
	*(unsigned char *)norme = 'I';
    }

    if (lsame_(transw, "C")) {
	itrnsw = 1;
    }

/*     Normalization of E: */

    enrmin = 1. / ulp;
    enrmax = 0.;
    if (itrnse == 0) {
	i__1 = *n;
	for (jvec = 1; jvec <= i__1; ++jvec) {
	    temp1 = 0.;
	    i__2 = *n;
	    for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
		i__3 = j + jvec * e_dim1;
		d__3 = temp1, d__4 = (d__1 = e[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&e[j + jvec * e_dim1]), abs(d__2));
		temp1 = max(d__3,d__4);
/* L10: */
	    }
	    enrmin = min(enrmin,temp1);
	    enrmax = max(enrmax,temp1);
/* L20: */
	}
    } else {
	i__1 = *n;
	for (jvec = 1; jvec <= i__1; ++jvec) {
	    rwork[jvec] = 0.;
/* L30: */
	}

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (jvec = 1; jvec <= i__2; ++jvec) {
/* Computing MAX */
		i__3 = jvec + j * e_dim1;
		d__3 = rwork[jvec], d__4 = (d__1 = e[i__3].r, abs(d__1)) + (
			d__2 = d_imag(&e[jvec + j * e_dim1]), abs(d__2));
		rwork[jvec] = max(d__3,d__4);
/* L40: */
	    }
/* L50: */
	}

	i__1 = *n;
	for (jvec = 1; jvec <= i__1; ++jvec) {
/* Computing MIN */
	    d__1 = enrmin, d__2 = rwork[jvec];
	    enrmin = min(d__1,d__2);
/* Computing MAX */
	    d__1 = enrmax, d__2 = rwork[jvec];
	    enrmax = max(d__1,d__2);
/* L60: */
	}
    }

/*     Norm of A: */

/* Computing MAX */
    d__1 = zlange_(norma, n, n, &a[a_offset], lda, &rwork[1]);
    anorm = max(d__1,unfl);

/*     Norm of E: */

/* Computing MAX */
    d__1 = zlange_(norme, n, n, &e[e_offset], lde, &rwork[1]);
    enorm = max(d__1,ulp);

/*     Norm of error: */

/*     Error =  AE - EW */

    zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);

    joff = 0;
    i__1 = *n;
    for (jcol = 1; jcol <= i__1; ++jcol) {
	if (itrnsw == 0) {
	    i__2 = jcol;
	    wtemp.r = w[i__2].r, wtemp.i = w[i__2].i;
	} else {
	    d_cnjg(&z__1, &w[jcol]);
	    wtemp.r = z__1.r, wtemp.i = z__1.i;
	}

	if (itrnse == 0) {
	    i__2 = *n;
	    for (jrow = 1; jrow <= i__2; ++jrow) {
		i__3 = joff + jrow;
		i__4 = jrow + jcol * e_dim1;
		z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i = 
			e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
		work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L70: */
	    }
	} else if (itrnse == 1) {
	    i__2 = *n;
	    for (jrow = 1; jrow <= i__2; ++jrow) {
		i__3 = joff + jrow;
		i__4 = jcol + jrow * e_dim1;
		z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i = 
			e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
		work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
	    }
	} else {
	    i__2 = *n;
	    for (jrow = 1; jrow <= i__2; ++jrow) {
		i__3 = joff + jrow;
		d_cnjg(&z__2, &e[jcol + jrow * e_dim1]);
		z__1.r = z__2.r * wtemp.r - z__2.i * wtemp.i, z__1.i = z__2.r 
			* wtemp.i + z__2.i * wtemp.r;
		work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
	    }
	}
	joff += *n;
/* L100: */
    }

    z__1.r = -1., z__1.i = -0.;
    zgemm_(transa, transe, n, n, n, &c_b2, &a[a_offset], lda, &e[e_offset], 
	    lde, &z__1, &work[1], n);

    errnrm = zlange_("One", n, n, &work[1], n, &rwork[1]) / enorm;

/*     Compute RESULT(1) (avoiding under/overflow) */

    if (anorm > errnrm) {
	result[1] = errnrm / anorm / ulp;
    } else {
	if (anorm < 1.) {
	    result[1] = min(errnrm,anorm) / anorm / ulp;
	} else {
/* Computing MIN */
	    d__1 = errnrm / anorm;
	    result[1] = min(d__1,1.) / ulp;
	}
    }

/*     Compute RESULT(2) : the normalization error in E. */

/* Computing MAX */
    d__3 = (d__1 = enrmax - 1., abs(d__1)), d__4 = (d__2 = enrmin - 1., abs(
	    d__2));
    result[2] = max(d__3,d__4) / ((doublereal) (*n) * ulp);

    return 0;

/*     End of ZGET22 */

} /* zget22_ */
コード例 #24
0
ファイル: zchkgk.c プロジェクト: 3deggi/levmar-ndk
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
    /* Format strings */
    static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
    static char fmt_9998[] = "(\002 value of largest test error             "
	    "     =\002,d12.3)";
    static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
	    "0    =\002,i4)";
    static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
	    "ot 0 =\002,i4)";
    static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
	    "ot 0 =\002,i4)";
    static char fmt_9994[] = "(\002 example number having largest error     "
	    "     =\002,i4)";
    static char fmt_9992[] = "(\002 number of examples where info is not 0  "
	    "     =\002,i4)";
    static char fmt_9991[] = "(\002 total number of examples tested         "
	    "     =\002,i4)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1, z__2;

    /* Builtin functions */
    integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
	    e_rsle(void);
    double d_imag(doublecomplex *);
    integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);

    /* Local variables */
    doublecomplex a[2500]	/* was [50][50] */, b[2500]	/* was [50][
	    50] */, e[2500]	/* was [50][50] */, f[2500]	/* was [50][
	    50] */;
    integer i__, j, m, n;
    doublecomplex af[2500]	/* was [50][50] */, bf[2500]	/* was [50][
	    50] */, vl[2500]	/* was [50][50] */, vr[2500]	/* was [50][
	    50] */;
    integer ihi, ilo;
    doublereal eps;
    doublecomplex vlf[2500]	/* was [50][50] */;
    integer knt;
    doublecomplex vrf[2500]	/* was [50][50] */;
    integer info, lmax[4];
    doublereal rmax, vmax;
    doublecomplex work[2500]	/* was [50][50] */;
    integer ninfo;
    doublereal anorm, bnorm;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    doublereal rwork[300];
    extern doublereal dlamch_(char *);
    doublereal lscale[50];
    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 *);
    doublereal rscale[50];
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);

    /* Fortran I/O blocks */
    static cilist io___6 = { 0, 0, 0, 0, 0 };
    static cilist io___10 = { 0, 0, 0, 0, 0 };
    static cilist io___13 = { 0, 0, 0, 0, 0 };
    static cilist io___15 = { 0, 0, 0, 0, 0 };
    static cilist io___17 = { 0, 0, 0, 0, 0 };
    static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */

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

/*  ZCHKGK tests ZGGBAK, a routine for backward balancing  of */
/*  a matrix pair (A, B). */

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

/*  NIN     (input) INTEGER */
/*          The logical unit number for input.  NIN > 0. */

/*  NOUT    (input) INTEGER */
/*          The logical unit number for output.  NOUT > 0. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Statement Functions .. */
/*     .. */
/*     .. Statement Function definitions .. */
/*     .. */
/*     .. Executable Statements .. */

    lmax[0] = 0;
    lmax[1] = 0;
    lmax[2] = 0;
    lmax[3] = 0;
    ninfo = 0;
    knt = 0;
    rmax = 0.;

    eps = dlamch_("Precision");

L10:
    io___6.ciunit = *nin;
    s_rsle(&io___6);
    do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
    do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
    e_rsle();
    if (n == 0) {
	goto L100;
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___10.ciunit = *nin;
	s_rsle(&io___10);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
		    sizeof(doublecomplex));
	}
	e_rsle();
/* L20: */
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___13.ciunit = *nin;
	s_rsle(&io___13);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
		    sizeof(doublecomplex));
	}
	e_rsle();
/* L30: */
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___15.ciunit = *nin;
	s_rsle(&io___15);
	i__2 = m;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
		    sizeof(doublecomplex));
	}
	e_rsle();
/* L40: */
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___17.ciunit = *nin;
	s_rsle(&io___17);
	i__2 = m;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
		    sizeof(doublecomplex));
	}
	e_rsle();
/* L50: */
    }

    ++knt;

    anorm = zlange_("M", &n, &n, a, &c__50, rwork);
    bnorm = zlange_("M", &n, &n, b, &c__50, rwork);

    zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
    zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);

    zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork, 
	    &info);
    if (info != 0) {
	++ninfo;
	lmax[0] = knt;
    }

    zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
    zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);

    zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
    if (info != 0) {
	++ninfo;
	lmax[1] = knt;
    }

    zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
    if (info != 0) {
	++ninfo;
	lmax[2] = knt;
    }

/*     Test of ZGGBAK */

/*     Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
/*     where tilde(A) denotes the transformed matrix. */

    zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
	    c__50);

    zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
	    c__50);

    vmax = 0.;
    i__1 = m;
    for (j = 1; j <= i__1; ++j) {
	i__2 = m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = i__ + j * 50 - 51;
	    i__4 = i__ + j * 50 - 51;
	    z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
	    z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
	    d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
		    z__1), abs(d__2));
	    vmax = max(d__3,d__4);
/* L60: */
	}
/* L70: */
    }
    vmax /= eps * max(anorm,bnorm);
    if (vmax > rmax) {
	lmax[3] = knt;
	rmax = vmax;
    }

/*     Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */

    zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
	    c__50);

    zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
	    c__50);

    vmax = 0.;
    i__1 = m;
    for (j = 1; j <= i__1; ++j) {
	i__2 = m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = i__ + j * 50 - 51;
	    i__4 = i__ + j * 50 - 51;
	    z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
	    z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
	    d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
		    z__1), abs(d__2));
	    vmax = max(d__3,d__4);
/* L80: */
	}
/* L90: */
    }
    vmax /= eps * max(anorm,bnorm);
    if (vmax > rmax) {
	lmax[3] = knt;
	rmax = vmax;
    }

    goto L10;

L100:

    io___35.ciunit = *nout;
    s_wsfe(&io___35);
    e_wsfe();

    io___36.ciunit = *nout;
    s_wsfe(&io___36);
    do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
    e_wsfe();
    io___37.ciunit = *nout;
    s_wsfe(&io___37);
    do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
    e_wsfe();
    io___38.ciunit = *nout;
    s_wsfe(&io___38);
    do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
    e_wsfe();
    io___39.ciunit = *nout;
    s_wsfe(&io___39);
    do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
    e_wsfe();
    io___40.ciunit = *nout;
    s_wsfe(&io___40);
    do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
    e_wsfe();
    io___41.ciunit = *nout;
    s_wsfe(&io___41);
    do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
    e_wsfe();
    io___42.ciunit = *nout;
    s_wsfe(&io___42);
    do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
    e_wsfe();

    return 0;

/*     End of ZCHKGK */

} /* zchkgk_ */
コード例 #25
0
/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *
	nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 
	doublecomplex *work, integer *lwork, integer *info)
{
/*  -- LAPACK driver routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       June 30, 1999   


    Purpose   
    =======   

    ZGELS solves overdetermined or underdetermined complex linear systems   
    involving an M-by-N matrix A, or its conjugate-transpose, using a QR   
    or LQ factorization of A.  It is assumed that A has full rank.   

    The following options are provided:   

    1. If TRANS = 'N' and m >= n:  find the least squares solution of   
       an overdetermined system, i.e., solve the least squares problem   
                    minimize || B - A*X ||.   

    2. If TRANS = 'N' and m < n:  find the minimum norm solution of   
       an underdetermined system A * X = B.   

    3. If TRANS = 'C' and m >= n:  find the minimum norm solution of   
       an undetermined system A**H * X = B.   

    4. If TRANS = 'C' and m < n:  find the least squares solution of   
       an overdetermined system, i.e., solve the least squares problem   
                    minimize || B - A**H * X ||.   

    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.   

    Arguments   
    =========   

    TRANS   (input) CHARACTER   
            = 'N': the linear system involves A;   
            = 'C': the linear system involves A**H.   

    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.   
              if M >= N, A is overwritten by details of its QR   
                         factorization as returned by ZGEQRF;   
              if M <  N, A is overwritten by details of its LQ   
                         factorization as returned by ZGELQF.   

    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 matrix B of right hand side vectors, stored   
            columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS   
            if TRANS = 'C'.   
            On exit, B is overwritten by the solution vectors, stored   
            columnwise:   
            if TRANS = 'N' and m >= n, rows 1 to n of B contain the least   
            squares solution vectors; the residual sum of squares for the   
            solution in each column is given by the sum of squares of   
            elements N+1 to M in that column;   
            if TRANS = 'N' and m < n, rows 1 to N of B contain the   
            minimum norm solution vectors;   
            if TRANS = 'C' and m >= n, rows 1 to M of B contain the   
            minimum norm solution vectors;   
            if TRANS = 'C' and m < n, rows 1 to M of B contain the   
            least squares solution vectors; the residual sum of squares   
            for the solution in each column is given by the sum of   
            squares of elements M+1 to N in that column.   

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

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

    LWORK   (input) INTEGER   
            The dimension of the array WORK.   
            LWORK >= max( 1, MN + max( MN, NRHS ) ).   
            For optimal performance,   
            LWORK >= max( 1, MN + max( MN, NRHS )*NB ).   
            where MN = min(M,N) and NB is the optimum block size.   

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

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

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


       Test the input arguments.   

       Parameter adjustments */
    /* Table of constant values */
    static doublecomplex c_b1 = {0.,0.};
    static doublecomplex c_b2 = {1.,0.};
    static integer c__1 = 1;
    static integer c_n1 = -1;
    static integer c__0 = 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 brow;
    static logical tpsd;
    static integer i__, j, iascl, ibscl;
    extern logical lsame_(char *, char *);
    static integer wsize;
    static doublereal rwork[1];
    extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, 
	    integer *, integer *, doublecomplex *, doublecomplex *, integer *,
	     doublecomplex *, integer *), 
	    dlabad_(doublereal *, doublereal *);
    static integer nb;
    extern doublereal dlamch_(char *);
    static integer mn;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static integer scllen;
    static doublereal bignum;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    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 *), zlaset_(
	    char *, integer *, integer *, doublecomplex *, doublecomplex *, 
	    doublecomplex *, integer *);
    static doublereal smlnum;
    static logical lquery;
    extern /* Subroutine */ int 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 *);
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --work;

    /* Function Body */
    *info = 0;
    mn = min(*m,*n);
    lquery = *lwork == -1;
    if (! (lsame_(trans, "N") || lsame_(trans, "C"))) {
	*info = -1;
    } else if (*m < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*lda < max(1,*m)) {
	*info = -6;
    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = max(1,*m);
	if (*ldb < max(i__1,*n)) {
	    *info = -8;
	} else /* if(complicated condition) */ {
/* Computing MAX */
	    i__1 = 1, i__2 = mn + max(mn,*nrhs);
	    if (*lwork < max(i__1,i__2) && ! lquery) {
		*info = -10;
	    }
	}
    }

/*     Figure out optimal block size */

    if (*info == 0 || *info == -10) {

	tpsd = TRUE_;
	if (lsame_(trans, "N")) {
	    tpsd = FALSE_;
	}

	if (*m >= *n) {
	    nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, 
		    (ftnlen)1);
	    if (tpsd) {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LN", m, nrhs, n, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    } else {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", m, nrhs, n, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    }
	} else {
	    nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, 
		    (ftnlen)1);
	    if (tpsd) {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    } else {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LN", n, nrhs, m, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    }
	}

/* Computing MAX */
	i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
	wsize = max(i__1,i__2);
	d__1 = (doublereal) wsize;
	work[1].r = d__1, work[1].i = 0.;

    }

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

/*     Quick return if possible   

   Computing MIN */
    i__1 = min(*m,*n);
    if (min(i__1,*nrhs) == 0) {
	i__1 = max(*m,*n);
	zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
	return 0;
    }

/*     Get machine parameters */

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

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

    anrm = zlange_("M", m, n, &a[a_offset], lda, rwork);
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
		info);
	iascl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
		info);
	iascl = 2;
    } else if (anrm == 0.) {

/*        Matrix all zero. Return zero solution. */

	i__1 = max(*m,*n);
	zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
	goto L50;
    }

    brow = *m;
    if (tpsd) {
	brow = *n;
    }
    bnrm = zlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], 
		ldb, info);
	ibscl = 1;
    } else if (bnrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	zlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], 
		ldb, info);
	ibscl = 2;
    }

    if (*m >= *n) {

/*        compute QR factorization of A */

	i__1 = *lwork - mn;
	zgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

/*        workspace at least N, optimally N*NB */

	if (! tpsd) {

/*           Least-Squares Problem min || A * X - B ||   

             B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], 
		    lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, 
		    info);

/*           workspace at least NRHS, optimally NRHS*NB   

             B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */

	    ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &
		    c_b2, &a[a_offset], lda, &b[b_offset], ldb);

	    scllen = *n;

	} else {

/*           Overdetermined system of equations A' * X = B   

             B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */

	    ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n, 
		    nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb);

/*           B(N+1:M,1:NRHS) = ZERO */

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = *n + 1; i__ <= i__2; ++i__) {
		    i__3 = b_subscr(i__, j);
		    b[i__3].r = 0., b[i__3].i = 0.;
/* L10: */
		}
/* L20: */
	    }

/*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB */

	    scllen = *m;

	}

    } else {

/*        Compute LQ factorization of A */

	i__1 = *lwork - mn;
	zgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

/*        workspace at least M, optimally M*NB. */

	if (! tpsd) {

/*           underdetermined system of equations A * X = B   

             B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */

	    ztrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &
		    c_b2, &a[a_offset], lda, &b[b_offset], ldb);

/*           B(M+1:N,1:NRHS) = 0 */

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = *m + 1; i__ <= i__2; ++i__) {
		    i__3 = b_subscr(i__, j);
		    b[i__3].r = 0., b[i__3].i = 0.;
/* L30: */
		}
/* L40: */
	    }

/*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], 
		    lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, 
		    info);

/*           workspace at least NRHS, optimally NRHS*NB */

	    scllen = *n;

	} else {

/*           overdetermined system min || A' * X - B ||   

             B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB   

             B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */

	    ztrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", m, 
		    nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb);

	    scllen = *m;

	}

    }

/*     Undo scaling */

    if (iascl == 1) {
	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    } else if (iascl == 2) {
	zlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    }
    if (ibscl == 1) {
	zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    } else if (ibscl == 2) {
	zlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    }

L50:
    d__1 = (doublereal) wsize;
    work[1].r = d__1, work[1].i = 0.;

    return 0;

/*     End of ZGELS */

} /* zgels_ */
コード例 #26
0
ファイル: zgerfsx.c プロジェクト: 0u812/roadrunner-backup
/* Subroutine */ int zgerfsx_(char *trans, char *equed, integer *n, integer *
	nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
	ldaf, integer *ipiv, doublereal *r__, doublereal *c__, doublecomplex *
	b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, 
	doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, 
	doublereal *err_bnds_comp__, integer *nparams, doublereal *params, 
	doublecomplex *work, doublereal *rwork, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, 
	    x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, 
	    err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
    doublereal d__1, d__2;

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

    /* Local variables */
    doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
    integer ref_type__;
    extern integer ilatrans_(char *);
    integer j;
    doublereal rcond_tmp__;
    integer prec_type__, trans_type__;
    doublereal cwise_wrong__;
    extern /* Subroutine */ int zla_gerfsx_extended__(integer *, integer *, 
	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,
	     integer *, integer *, logical *, doublereal *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublecomplex *, doublereal *, 
	    doublecomplex *, doublecomplex *, doublereal *, integer *, 
	    doublereal *, doublereal *, logical *, integer *);
    char norm[1];
    logical ignore_cwise__;
    extern logical lsame_(char *, char *);
    doublereal anorm;
    extern doublereal zla_gercond_c__(char *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, integer *, doublereal *, 
	    logical *, integer *, doublecomplex *, doublereal *, ftnlen), 
	    zla_gercond_x__(char *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, doublecomplex *, integer *,
	     doublecomplex *, doublereal *, ftnlen), dlamch_(char *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zgecon_(char *, integer *, doublecomplex *, 
	    integer *, doublereal *, doublereal *, doublecomplex *, 
	    doublereal *, integer *);
    logical colequ, notran, rowequ;
    extern integer ilaprec_(char *);
    integer ithresh, n_norms__;
    doublereal rthresh;


/*     -- LAPACK routine (version 3.2.1)                                 -- */
/*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/*     -- Jason Riedy of Univ. of California Berkeley.                 -- */
/*     -- April 2009                                                   -- */

/*     -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/*     -- Univ. of California Berkeley and NAG Ltd.                    -- */

/*     .. */
/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*     ZGERFSX improves the computed solution to a system of linear */
/*     equations and provides error bounds and backward error estimates */
/*     for the solution.  In addition to normwise error bound, the code */
/*     provides maximum componentwise error bound if possible.  See */
/*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
/*     error bounds. */

/*     The original system of linear equations may have been equilibrated */
/*     before calling this routine, as described by arguments EQUED, R */
/*     and C below. In this case, the solution and error bounds returned */
/*     are for the original unequilibrated system. */

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

/*     Some optional parameters are bundled in the PARAMS array.  These */
/*     settings determine how refinement is performed, but often the */
/*     defaults are acceptable.  If the defaults are acceptable, users */
/*     can pass NPARAMS = 0 which prevents the source code from accessing */
/*     the PARAMS argument. */

/*     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 = Transpose) */

/*     EQUED   (input) CHARACTER*1 */
/*     Specifies the form of equilibration that was done to A */
/*     before calling this routine. This is needed to compute */
/*     the solution and error bounds correctly. */
/*       = 'N':  No equilibration */
/*       = 'R':  Row equilibration, i.e., A has been premultiplied by */
/*               diag(R). */
/*       = 'C':  Column equilibration, i.e., A has been postmultiplied */
/*               by diag(C). */
/*       = 'B':  Both row and column equilibration, i.e., A has been */
/*               replaced by diag(R) * A * diag(C). */
/*               The right hand side B has been changed accordingly. */

/*     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*16 array, dimension (LDA,N) */
/*     The original N-by-N matrix A. */

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

/*     AF      (input) COMPLEX*16 array, dimension (LDAF,N) */
/*     The factors L and U from the factorization A = P*L*U */
/*     as computed by ZGETRF. */

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

/*     IPIV    (input) INTEGER array, dimension (N) */
/*     The pivot indices from ZGETRF; for 1<=i<=N, row i of the */
/*     matrix was interchanged with row IPIV(i). */

/*     R       (input or output) DOUBLE PRECISION array, dimension (N) */
/*     The row scale factors for A.  If EQUED = 'R' or 'B', A is */
/*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
/*     is not accessed.  R is an input argument if FACT = 'F'; */
/*     otherwise, R is an output argument.  If FACT = 'F' and */
/*     EQUED = 'R' or 'B', each element of R must be positive. */
/*     If R is output, each element of R is a power of the radix. */
/*     If R is input, each element of R should be a power of the radix */
/*     to ensure a reliable solution and error estimates. Scaling by */
/*     powers of the radix does not cause rounding errors unless the */
/*     result underflows or overflows. Rounding errors during scaling */
/*     lead to refining with a matrix that is not equivalent to the */
/*     input matrix, producing error estimates that may not be */
/*     reliable. */

/*     C       (input or output) DOUBLE PRECISION array, dimension (N) */
/*     The column scale factors for A.  If EQUED = 'C' or 'B', A is */
/*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
/*     is not accessed.  C is an input argument if FACT = 'F'; */
/*     otherwise, C is an output argument.  If FACT = 'F' and */
/*     EQUED = 'C' or 'B', each element of C must be positive. */
/*     If C is output, each element of C is a power of the radix. */
/*     If C is input, each element of C should be a power of the radix */
/*     to ensure a reliable solution and error estimates. Scaling by */
/*     powers of the radix does not cause rounding errors unless the */
/*     result underflows or overflows. Rounding errors during scaling */
/*     lead to refining with a matrix that is not equivalent to the */
/*     input matrix, producing error estimates that may not be */
/*     reliable. */

/*     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 ZGETRS. */
/*     On exit, the improved solution matrix X. */

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

/*     RCOND   (output) DOUBLE PRECISION */
/*     Reciprocal scaled condition number.  This is an estimate of the */
/*     reciprocal Skeel condition number of the matrix A after */
/*     equilibration (if done).  If this is less than the machine */
/*     precision (in particular, if it is zero), the matrix is singular */
/*     to working precision.  Note that the error may still be small even */
/*     if this number is very small and the matrix appears ill- */
/*     conditioned. */

/*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS) */
/*     Componentwise relative backward error.  This is 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). */

/*     N_ERR_BNDS (input) INTEGER */
/*     Number of error bounds to return for each right hand side */
/*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and */
/*     ERR_BNDS_COMP below. */

/*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
/*     For each right-hand side, this array contains information about */
/*     various error bounds and condition numbers corresponding to the */
/*     normwise relative error, which is defined as follows: */

/*     Normwise relative error in the ith solution vector: */
/*             max_j (abs(XTRUE(j,i) - X(j,i))) */
/*            ------------------------------ */
/*                  max_j abs(X(j,i)) */

/*     The array is indexed by the type of error information as described */
/*     below. There currently are up to three pieces of information */
/*     returned. */

/*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/*     right-hand side. */

/*     The second index in ERR_BNDS_NORM(:,err) contains the following */
/*     three fields: */
/*     err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/*              reciprocal condition number is less than the threshold */
/*              sqrt(n) * dlamch('Epsilon'). */

/*     err = 2 "Guaranteed" error bound: The estimated forward error, */
/*              almost certainly within a factor of 10 of the true error */
/*              so long as the next entry is greater than the threshold */
/*              sqrt(n) * dlamch('Epsilon'). This error bound should only */
/*              be trusted if the previous boolean is true. */

/*     err = 3  Reciprocal condition number: Estimated normwise */
/*              reciprocal condition number.  Compared with the threshold */
/*              sqrt(n) * dlamch('Epsilon') to determine if the error */
/*              estimate is "guaranteed". These reciprocal condition */
/*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/*              appropriately scaled matrix Z. */
/*              Let Z = S*A, where S scales each row by a power of the */
/*              radix so all absolute row sums of Z are approximately 1. */

/*     See Lapack Working Note 165 for further details and extra */
/*     cautions. */

/*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
/*     For each right-hand side, this array contains information about */
/*     various error bounds and condition numbers corresponding to the */
/*     componentwise relative error, which is defined as follows: */

/*     Componentwise relative error in the ith solution vector: */
/*                    abs(XTRUE(j,i) - X(j,i)) */
/*             max_j ---------------------- */
/*                         abs(X(j,i)) */

/*     The array is indexed by the right-hand side i (on which the */
/*     componentwise relative error depends), and the type of error */
/*     information as described below. There currently are up to three */
/*     pieces of information returned for each right-hand side. If */
/*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most */
/*     the first (:,N_ERR_BNDS) entries are returned. */

/*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/*     right-hand side. */

/*     The second index in ERR_BNDS_COMP(:,err) contains the following */
/*     three fields: */
/*     err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/*              reciprocal condition number is less than the threshold */
/*              sqrt(n) * dlamch('Epsilon'). */

/*     err = 2 "Guaranteed" error bound: The estimated forward error, */
/*              almost certainly within a factor of 10 of the true error */
/*              so long as the next entry is greater than the threshold */
/*              sqrt(n) * dlamch('Epsilon'). This error bound should only */
/*              be trusted if the previous boolean is true. */

/*     err = 3  Reciprocal condition number: Estimated componentwise */
/*              reciprocal condition number.  Compared with the threshold */
/*              sqrt(n) * dlamch('Epsilon') to determine if the error */
/*              estimate is "guaranteed". These reciprocal condition */
/*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/*              appropriately scaled matrix Z. */
/*              Let Z = S*(A*diag(x)), where x is the solution for the */
/*              current right-hand side and S scales each row of */
/*              A*diag(x) by a power of the radix so all absolute row */
/*              sums of Z are approximately 1. */

/*     See Lapack Working Note 165 for further details and extra */
/*     cautions. */

/*     NPARAMS (input) INTEGER */
/*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the */
/*     PARAMS array is never referenced and default values are used. */

/*     PARAMS  (input / output) DOUBLE PRECISION array, dimension NPARAMS */
/*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then */
/*     that entry will be filled with default value used for that */
/*     parameter.  Only positions up to NPARAMS are accessed; defaults */
/*     are used for higher-numbered parameters. */

/*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/*            refinement or not. */
/*         Default: 1.0D+0 */
/*            = 0.0 : No refinement is performed, and no error bounds are */
/*                    computed. */
/*            = 1.0 : Use the double-precision refinement algorithm, */
/*                    possibly with doubled-single computations if the */
/*                    compilation environment does not support DOUBLE */
/*                    PRECISION. */
/*              (other values are reserved for future use) */

/*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/*            computations allowed for refinement. */
/*         Default: 10 */
/*         Aggressive: Set to 100 to permit convergence using approximate */
/*                     factorizations or factorizations other than LU. If */
/*                     the factorization uses a technique other than */
/*                     Gaussian elimination, the guarantees in */
/*                     err_bnds_norm and err_bnds_comp may no longer be */
/*                     trustworthy. */

/*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/*            will attempt to find a solution with small componentwise */
/*            relative error in the double-precision algorithm.  Positive */
/*            is true, 0.0 is false. */
/*         Default: 1.0 (attempt componentwise convergence) */

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

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

/*     INFO    (output) INTEGER */
/*       = 0:  Successful exit. The solution to every right-hand side is */
/*         guaranteed. */
/*       < 0:  If INFO = -i, the i-th argument had an illegal value */
/*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization */
/*         has been completed, but the factor U is exactly singular, so */
/*         the solution and error bounds could not be computed. RCOND = 0 */
/*         is returned. */
/*       = N+J: The solution corresponding to the Jth right-hand side is */
/*         not guaranteed. The solutions corresponding to other right- */
/*         hand sides K with K > J may not be guaranteed as well, but */
/*         only the first such right-hand side is reported. If a small */
/*         componentwise error is not requested (PARAMS(3) = 0.0) then */
/*         the Jth right-hand side is the first with a normwise error */
/*         bound that is not guaranteed (the smallest J such */
/*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/*         the Jth right-hand side is the first with either a normwise or */
/*         componentwise error bound that is not guaranteed (the smallest */
/*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/*         about all of the right-hand sides check ERR_BNDS_NORM or */
/*         ERR_BNDS_COMP. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Check the input parameters. */

    /* Parameter adjustments */
    err_bnds_comp_dim1 = *nrhs;
    err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
    err_bnds_comp__ -= err_bnds_comp_offset;
    err_bnds_norm_dim1 = *nrhs;
    err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
    err_bnds_norm__ -= err_bnds_norm_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    af_dim1 = *ldaf;
    af_offset = 1 + af_dim1;
    af -= af_offset;
    --ipiv;
    --r__;
    --c__;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    --berr;
    --params;
    --work;
    --rwork;

    /* Function Body */
    *info = 0;
    trans_type__ = ilatrans_(trans);
    ref_type__ = 1;
    if (*nparams >= 1) {
	if (params[1] < 0.) {
	    params[1] = 1.;
	} else {
	    ref_type__ = (integer) params[1];
	}
    }

/*     Set default parameters. */

    illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
    ithresh = 10;
    rthresh = .5;
    unstable_thresh__ = .25;
    ignore_cwise__ = FALSE_;

    if (*nparams >= 2) {
	if (params[2] < 0.) {
	    params[2] = (doublereal) ithresh;
	} else {
	    ithresh = (integer) params[2];
	}
    }
    if (*nparams >= 3) {
	if (params[3] < 0.) {
	    if (ignore_cwise__) {
		params[3] = 0.;
	    } else {
		params[3] = 1.;
	    }
	} else {
	    ignore_cwise__ = params[3] == 0.;
	}
    }
    if (ref_type__ == 0 || *n_err_bnds__ == 0) {
	n_norms__ = 0;
    } else if (ignore_cwise__) {
	n_norms__ = 1;
    } else {
	n_norms__ = 2;
    }

    notran = lsame_(trans, "N");
    rowequ = lsame_(equed, "R") || lsame_(equed, "B");
    colequ = lsame_(equed, "C") || lsame_(equed, "B");

/*     Test input parameters. */

    if (trans_type__ == -1) {
	*info = -1;
    } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
	*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 = -13;
    } else if (*ldx < max(1,*n)) {
	*info = -15;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGERFSX", &i__1);
	return 0;
    }

/*     Quick return if possible. */

    if (*n == 0 || *nrhs == 0) {
	*rcond = 1.;
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    berr[j] = 0.;
	    if (*n_err_bnds__ >= 1) {
		err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
		err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
	    } else if (*n_err_bnds__ >= 2) {
		err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
		err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
	    } else if (*n_err_bnds__ >= 3) {
		err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
		err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
	    }
	}
	return 0;
    }

/*     Default to failure. */

    *rcond = 0.;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	berr[j] = 1.;
	if (*n_err_bnds__ >= 1) {
	    err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
	    err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
	} else if (*n_err_bnds__ >= 2) {
	    err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
	    err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
	} else if (*n_err_bnds__ >= 3) {
	    err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
	    err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
	}
    }

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

    if (notran) {
	*(unsigned char *)norm = 'I';
    } else {
	*(unsigned char *)norm = '1';
    }
    anorm = zlange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
    zgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1], 
	     info);

/*     Perform refinement on each right-hand side */

    if (ref_type__ != 0) {
	prec_type__ = ilaprec_("E");
	if (notran) {
	    zla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
		    a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &colequ, &
		    c__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
		    n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
		    err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1]
		    , &work[*n + 1], (doublecomplex*)(&rwork[1]), rcond, &ithresh, &rthresh, &
		    unstable_thresh__, &ignore_cwise__, info);
	} else {
	    zla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
		    a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rowequ, &
		    r__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
		    n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
		    err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1]
		    , &work[*n + 1], (doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &
		    unstable_thresh__, &ignore_cwise__, info);
	}
    }
/* Computing MAX */
    d__1 = 10., d__2 = sqrt((doublereal) (*n));
    err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
    if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {

/*     Compute scaled normwise condition number cond(A*C). */

	if (colequ && notran) {
	    rcond_tmp__ = zla_gercond_c__(trans, n, &a[a_offset], lda, &af[
		    af_offset], ldaf, &ipiv[1], &c__[1], &c_true, info, &work[
		    1], &rwork[1], (ftnlen)1);
	} else if (rowequ && ! notran) {
	    rcond_tmp__ = zla_gercond_c__(trans, n, &a[a_offset], lda, &af[
		    af_offset], ldaf, &ipiv[1], &r__[1], &c_true, info, &work[
		    1], &rwork[1], (ftnlen)1);
	} else {
	    rcond_tmp__ = zla_gercond_c__(trans, n, &a[a_offset], lda, &af[
		    af_offset], ldaf, &ipiv[1], &c__[1], &c_false, info, &
		    work[1], &rwork[1], (ftnlen)1);
	}
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {

/*     Cap the error at 1.0. */

	    if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 
		    << 1)] > 1.) {
		err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
	    }

/*     Threshold the error (see LAWN). */

	    if (rcond_tmp__ < illrcond_thresh__) {
		err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
		err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
		if (*info <= *n) {
		    *info = *n + j;
		}
	    } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < 
		    err_lbnd__) {
		err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
		err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
	    }

/*     Save the condition number. */

	    if (*n_err_bnds__ >= 3) {
		err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
	    }
	}
    }
    if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {

/*     Compute componentwise condition number cond(A*diag(Y(:,J))) for */
/*     each right-hand side using the current solution as an estimate of */
/*     the true solution.  If the componentwise error estimate is too */
/*     large, then the solution is a lousy estimate of truth and the */
/*     estimated RCOND may be too optimistic.  To avoid misleading users, */
/*     the inverse condition number is set to 0.0 when the estimated */
/*     cwise error is at least CWISE_WRONG. */

	cwise_wrong__ = sqrt(dlamch_("Epsilon"));
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < 
		    cwise_wrong__) {
		rcond_tmp__ = zla_gercond_x__(trans, n, &a[a_offset], lda, &
			af[af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], 
			info, &work[1], &rwork[1], (ftnlen)1);
	    } else {
		rcond_tmp__ = 0.;
	    }

/*     Cap the error at 1.0. */

	    if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 
		    << 1)] > 1.) {
		err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
	    }

/*     Threshold the error (see LAWN). */

	    if (rcond_tmp__ < illrcond_thresh__) {
		err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
		err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
		if (params[3] == 1. && *info < *n + j) {
		    *info = *n + j;
		}
	    } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < 
		    err_lbnd__) {
		err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
		err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
	    }

/*     Save the condition number. */

	    if (*n_err_bnds__ >= 3) {
		err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
	    }
	}
    }

    return 0;

/*     End of ZGERFSX */

} /* zgerfsx_ */
コード例 #27
0
ファイル: zlqt02.c プロジェクト: kstraube/hysim
/* Subroutine */ int zlqt02_(integer *m, integer *n, integer *k, 
	doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
	l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
	lwork, doublereal *rwork, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1, 
	    q_offset, i__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    doublereal eps;
    integer info;
    doublereal resid, anorm;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *), zherk_(char *, char *, integer *, 
	    integer *, doublereal *, doublecomplex *, integer *, doublereal *, 
	     doublecomplex *, integer *);
    extern doublereal dlamch_(char *), zlange_(char *, integer *, 
	    integer *, doublecomplex *, integer *, doublereal *);
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    zlaset_(char *, integer *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *);
    extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zunglq_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with */
/*  orthonornmal rows that is defined as the product of k elementary */
/*  reflectors. */

/*  Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates */
/*  the orthogonal matrix Q defined by the factorization of the first k */
/*  rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
/*  checks that the rows of Q are orthonormal. */

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

/*  M       (input) INTEGER */
/*          The number of rows of the matrix Q to be generated.  M >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix Q to be generated. */
/*          N >= M >= 0. */

/*  K       (input) INTEGER */
/*          The number of elementary reflectors whose product defines the */
/*          matrix Q. M >= K >= 0. */

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The m-by-n matrix A which was factorized by ZLQT01. */

/*  AF      (input) COMPLEX*16 array, dimension (LDA,N) */
/*          Details of the LQ factorization of A, as returned by ZGELQF. */
/*          See ZGELQF for further details. */

/*  Q       (workspace) COMPLEX*16 array, dimension (LDA,N) */

/*  L       (workspace) COMPLEX*16 array, dimension (LDA,M) */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the arrays A, AF, Q and L. LDA >= N. */

/*  TAU     (input) COMPLEX*16 array, dimension (M) */
/*          The scalar factors of the elementary reflectors corresponding */
/*          to the LQ factorization in AF. */

/*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (M) */

/*  RESULT  (output) DOUBLE PRECISION array, dimension (2) */
/*          The test ratios: */
/*          RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
/*          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    l_dim1 = *lda;
    l_offset = 1 + l_dim1;
    l -= l_offset;
    q_dim1 = *lda;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    af_dim1 = *lda;
    af_offset = 1 + af_dim1;
    af -= af_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --tau;
    --work;
    --rwork;
    --result;

    /* Function Body */
    eps = dlamch_("Epsilon");

/*     Copy the first k rows of the factorization to the array Q */

    zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
    i__1 = *n - 1;
    zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1) 
	    + 1], lda);

/*     Generate the first n columns of the matrix Q */

    s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)6, (ftnlen)6);
    zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);

/*     Copy L(1:k,1:m) */

    zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
    zlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);

/*     Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */

    zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
	    a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);

/*     Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */

    anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
    resid = zlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
    if (anorm > 0.) {
	result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
    } else {
	result[1] = 0.;
    }

/*     Compute I - Q*Q' */

    zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
    zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
	    l[l_offset], lda);

/*     Compute norm( I - Q*Q' ) / ( N * EPS ) . */

    resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);

    result[2] = resid / (doublereal) max(1,*n) / eps;

    return 0;

/*     End of ZLQT02 */

} /* zlqt02_ */
コード例 #28
0
ファイル: ztzt01.c プロジェクト: zangel/uquad
doublereal ztzt01_(integer *m, integer *n, doublecomplex *a, doublecomplex *
	af, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
	lwork)
{
    /* System generated locals */
    integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
    doublereal ret_val;

    /* Local variables */
    static integer i__, j;
    static doublereal norma, rwork[1];
    extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zlaset_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatzm_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, doublecomplex *, 
	    integer *, doublecomplex *);


#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]


/*  -- LAPACK test routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    ZTZT01 returns   
         || A - R*Q || / ( M * eps * ||A|| )   
    for an upper trapezoidal A that was factored with ZTZRQF.   

    Arguments   
    =========   

    M       (input) INTEGER   
            The number of rows of the matrices A and AF.   

    N       (input) INTEGER   
            The number of columns of the matrices A and AF.   

    A       (input) COMPLEX*16 array, dimension (LDA,N)   
            The original upper trapezoidal M by N matrix A.   

    AF      (input) COMPLEX*16 array, dimension (LDA,N)   
            The output of ZTZRQF for input matrix A.   
            The lower triangle is not referenced.   

    LDA     (input) INTEGER   
            The leading dimension of the arrays A and AF.   

    TAU     (input) COMPLEX*16 array, dimension (M)   
            Details of the  Householder transformations as returned by   
            ZTZRQF.   

    WORK    (workspace) COMPLEX*16 array, dimension (LWORK)   

    LWORK   (input) INTEGER   
            The length of the array WORK.  LWORK >= m*n + m.   

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


       Parameter adjustments */
    af_dim1 = *lda;
    af_offset = 1 + af_dim1 * 1;
    af -= af_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --tau;
    --work;

    /* Function Body */
    ret_val = 0.;

    if (*lwork < *m * *n + *m) {
	xerbla_("ZTZT01", &c__8);
	return ret_val;
    }

/*     Quick return if possible */

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

    norma = zlange_("One-norm", m, n, &a[a_offset], lda, rwork);

/*     Copy upper triangle R */

    zlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	i__2 = j;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = (j - 1) * *m + i__;
	    i__4 = af_subscr(i__, j);
	    work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
/* L10: */
	}
/* L20: */
    }

/*     R = R * P(1) * ... *P(m) */

    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = *n - *m + 1;
	zlatzm_("Right", &i__, &i__2, &af_ref(i__, *m + 1), lda, &tau[i__], &
		work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &work[*m * *
		n + 1]);
/* L30: */
    }

/*     R = R - A */

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	zaxpy_(m, &c_b15, &a_ref(1, i__), &c__1, &work[(i__ - 1) * *m + 1], &
		c__1);
/* L40: */
    }

    ret_val = zlange_("One-norm", m, n, &work[1], m, rwork);

    ret_val /= dlamch_("Epsilon") * (doublereal) max(*m,*n);
    if (norma != 0.) {
	ret_val /= norma;
    }

    return ret_val;

/*     End of ZTZT01 */

} /* ztzt01_ */
コード例 #29
0
ファイル: zsyt03.c プロジェクト: 3deggi/levmar-ndk
/* Subroutine */ int zsyt03_(char *uplo, integer *n, doublecomplex *a, 
	integer *lda, doublecomplex *ainv, integer *ldainv, doublecomplex *
	work, integer *ldwork, doublereal *rwork, doublereal *rcond, 
	doublereal *resid)
{
    /* System generated locals */
    integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset, 
	    i__1, i__2, i__3, i__4;
    doublecomplex z__1;

    /* Local variables */
    integer i__, j;
    doublereal eps;
    extern logical lsame_(char *, char *);
    doublereal anorm;
    extern /* Subroutine */ int zsymm_(char *, char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *);
    extern doublereal dlamch_(char *), zlange_(char *, integer *, 
	    integer *, doublecomplex *, integer *, doublereal *);
    doublereal ainvnm;
    extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, 
	    integer *, doublereal *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

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

/*  ZSYT03 computes the residual for a complex symmetric matrix times */
/*  its inverse: */
/*     norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ) */
/*  where EPS is the machine epsilon. */

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

/*  UPLO    (input) CHARACTER*1 */
/*          Specifies whether the upper or lower triangular part of the */
/*          complex symmetric matrix A is stored: */
/*          = 'U':  Upper triangular */
/*          = 'L':  Lower triangular */

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

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The original complex symmetric matrix A. */

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

/*  AINV    (input/output) COMPLEX*16 array, dimension (LDAINV,N) */
/*          On entry, the inverse of the matrix A, stored as a symmetric */
/*          matrix in the same format as A. */
/*          In this version, AINV is expanded into a full matrix and */
/*          multiplied by A, so the opposing triangle of AINV will be */
/*          changed; i.e., if the upper triangular part of AINV is */
/*          stored, the lower triangular part will be used as work space. */

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

/*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,N) */

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

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

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

/*  RESID   (output) DOUBLE PRECISION */
/*          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */

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


/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick exit if N = 0 */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    ainv_dim1 = *ldainv;
    ainv_offset = 1 + ainv_dim1;
    ainv -= ainv_offset;
    work_dim1 = *ldwork;
    work_offset = 1 + work_dim1;
    work -= work_offset;
    --rwork;

    /* Function Body */
    if (*n <= 0) {
	*rcond = 1.;
	*resid = 0.;
	return 0;
    }

/*     Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */

    eps = dlamch_("Epsilon");
    anorm = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
    ainvnm = zlansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
    if (anorm <= 0. || ainvnm <= 0.) {
	*rcond = 0.;
	*resid = 1. / eps;
	return 0;
    }
    *rcond = 1. / anorm / ainvnm;

/*     Expand AINV into a full matrix and call ZSYMM to multiply */
/*     AINV on the left by A (store the result in WORK). */

    if (lsame_(uplo, "U")) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j - 1;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		i__3 = j + i__ * ainv_dim1;
		i__4 = i__ + j * ainv_dim1;
		ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L10: */
	    }
/* L20: */
	}
    } else {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (i__ = j + 1; i__ <= i__2; ++i__) {
		i__3 = j + i__ * ainv_dim1;
		i__4 = i__ + j * ainv_dim1;
		ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L30: */
	    }
/* L40: */
	}
    }
    z__1.r = -1., z__1.i = -0.;
    zsymm_("Left", uplo, n, n, &z__1, &a[a_offset], lda, &ainv[ainv_offset], 
	    ldainv, &c_b1, &work[work_offset], ldwork);

/*     Add the identity matrix to WORK . */

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = i__ + i__ * work_dim1;
	i__3 = i__ + i__ * work_dim1;
	z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
	work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L50: */
    }

/*     Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */

    *resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);

    *resid = *resid * *rcond / eps / (doublereal) (*n);

    return 0;

/*     End of ZSYT03 */

} /* zsyt03_ */
コード例 #30
0
ファイル: ztrsen.c プロジェクト: flame/libflame
/* 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)
{
    /* 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_(char *, char *);
    integer isave[3], lwmin;
    logical wantq, wants;
    doublereal rnorm, rwork[1];
    extern /* Subroutine */
    int zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *), xerbla_( char *, integer *);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *);
    logical wantbh;
    extern /* Subroutine */
    int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
    logical wantsp;
    extern /* Subroutine */
    int ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *);
    logical lquery;
    extern /* Subroutine */
    int ztrsyl_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *);
    /* -- LAPACK computational routine (version 3.4.0) -- */
    /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
    /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
    /* November 2011 */
    /* .. Scalar Arguments .. */
    /* .. */
    /* .. Array Arguments .. */
    /* .. */
    /* ===================================================================== */
    /* .. Parameters .. */
    /* .. */
    /* .. Local Scalars .. */
    /* .. */
    /* .. Local Arrays .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Decode and test the input parameters. */
    /* 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");
    wants = lsame_(job, "E") || wantbh;
    wantsp = lsame_(job, "V") || wantbh;
    wantq = lsame_(compq, "V");
    /* Set M to the number of selected eigenvalues. */
    *m = 0;
    i__1 = *n;
    for (k = 1;
            k <= i__1;
            ++k)
    {
        if (select[k])
        {
            ++(*m);
        }
        /* L10: */
    }
    n1 = *m;
    n2 = *n - *m;
    nn = n1 * n2;
    *info = 0;
    lquery = *lwork == -1;
    if (wantsp)
    {
        /* Computing MAX */
        i__1 = 1;
        i__2 = nn << 1; // , expr subst
        lwmin = max(i__1,i__2);
    }
    else if (lsame_(job, "N"))
    {
        lwmin = 1;
    }
    else if (lsame_(job, "E"))
    {
        lwmin = max(1,nn);
    }
    if (! lsame_(job, "N") && ! wants && ! wantsp)
    {
        *info = -1;
    }
    else if (! lsame_(compq, "N") && ! wantq)
    {
        *info = -2;
    }
    else if (*n < 0)
    {
        *info = -4;
    }
    else if (*ldt < max(1,*n))
    {
        *info = -6;
    }
    else if (*ldq < 1 || wantq && *ldq < *n)
    {
        *info = -8;
    }
    else if (*lwork < lwmin && ! lquery)
    {
        *info = -14;
    }
    if (*info == 0)
    {
        work[1].r = (doublereal) lwmin;
        work[1].i = 0.; // , expr subst
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("ZTRSEN", &i__1);
        return 0;
    }
    else if (lquery)
    {
        return 0;
    }
    /* Quick return if possible */
    if (*m == *n || *m == 0)
    {
        if (wants)
        {
            *s = 1.;
        }
        if (wantsp)
        {
            *sep = zlange_("1", n, n, &t[t_offset], ldt, rwork);
        }
        goto L40;
    }
    /* Collect the selected eigenvalues at the top left corner of T. */
    ks = 0;
    i__1 = *n;
    for (k = 1;
            k <= i__1;
            ++k)
    {
        if (select[k])
        {
            ++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);
            }
        }
        /* L20: */
    }
    if (wants)
    {
        /* Solve the Sylvester equation for R: */
        /* T11*R - R*T22 = scale*T12 */
        zlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
        ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
        /* Estimate the reciprocal of the condition number of the cluster */
        /* of eigenvalues. */
        rnorm = zlange_("F", &n1, &n2, &work[1], &n1, rwork);
        if (rnorm == 0.)
        {
            *s = 1.;
        }
        else
        {
            *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
        }
    }
    if (wantsp)
    {
        /* Estimate sep(T11,T22). */
        est = 0.;
        kase = 0;
L30:
        zlacn2_(&nn, &work[nn + 1], &work[1], &est, &kase, isave);
        if (kase != 0)
        {
            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);
            }
            else
            {
                /* Solve T11**H*R - R*T22**H = 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);
            }
            goto L30;
        }
        *sep = scale / est;
    }
L40: /* Copy reordered eigenvalues to W. */
    i__1 = *n;
    for (k = 1;
            k <= i__1;
            ++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; // , expr subst
        /* L50: */
    }
    work[1].r = (doublereal) lwmin;
    work[1].i = 0.; // , expr subst
    return 0;
    /* End of ZTRSEN */
}