自学教程：C++ zlacpy_函数代码示例

INT16 dlm_cholfC(COMPLEX64* Z, const COMPLEX64* A, INT32 nXD) {  integer info = 0;  integer n = (integer) nXD;  char uplo[1] = { 'U' };#ifdef __MAX_TYPE_32BIT  extern int clacpy_(char*,integer*,integer*,complex*,integer*,complex*,integer *ldb);  extern int cpotrf_(char*,integer*,complex*,integer*,integer*);#else  extern int zlacpy_(char*,integer*,integer*,doublecomplex*,integer*,doublecomplex*,integer *ldb);  extern int zpotrf_(char*,integer*,doublecomplex*,integer*,integer*);#endif  /* Declare variables */  DLPASSERT(Z != A);                                                            /* Assert input is not output        */  DLPASSERT(dlp_size(Z) >= nXD * nXD * sizeof(FLOAT64));                        /* Check size of output buffer       */  DLPASSERT(dlp_size(A) >= nXD * nXD * sizeof(FLOAT64));                        /* Check size of input buffer        */  /* ... computation ... *//* --------------------------------- */#ifdef __MAX_TYPE_32BIT  cpotrf_(uplo, &n, (complex*)A, &n, &info);  clacpy_(uplo, &n, &n, (complex*)A, &n, (complex*)Z, &n);#else  zpotrf_(uplo, &n, (doublecomplex*)A, &n, &info);  zlacpy_(uplo, &n, &n, (doublecomplex*)A, &n, (doublecomplex*)Z, &n);#endif  return (info == 0) ? O_K : NOT_EXEC; /* All done successfully             */}

//.........这里部分代码省略.........    =====================================================================          Test the input parameters.          Parameter adjustments */    /* Table of constant values */    static doublereal c_b3 = -1.;    static integer c__1 = 1;        /* System generated locals */    integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;    doublereal d__1;    /* Builtin functions */    double sqrt(doublereal);    /* Local variables */    static integer jlam, imax, jmax;    static doublereal c__;    static integer i__, j;    static doublereal s, t;    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 	    integer *), dcopy_(integer *, doublereal *, integer *, doublereal 	    *, integer *);    static integer k2, n1, n2;    extern /* Subroutine */ int zdrot_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, doublereal *), zcopy_(	    integer *, doublecomplex *, integer *, doublecomplex *, integer *)	    ;    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);    static integer jp;    extern integer idamax_(integer *, doublereal *, integer *);    extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, 	    integer *, integer *, integer *), xerbla_(char *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, 	    integer *, doublecomplex *, integer *);    static integer n1p1;    static doublereal eps, tau, tol;#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 q2_subscr(a_1,a_2) (a_2)*q2_dim1 + a_1#define q2_ref(a_1,a_2) q2[q2_subscr(a_1,a_2)]#define givcol_ref(a_1,a_2) givcol[(a_2)*2 + a_1]#define givnum_ref(a_1,a_2) givnum[(a_2)*2 + a_1]    q_dim1 = *ldq;    q_offset = 1 + q_dim1 * 1;    q -= q_offset;    --d__;    --z__;    --dlamda;    q2_dim1 = *ldq2;    q2_offset = 1 + q2_dim1 * 1;    q2 -= q2_offset;    --w;    --indxp;    --indx;    --indxq;    --perm;    givcol -= 3;    givnum -= 3;    /* Function Body */    *info = 0;    if (*n < 0) {

/* Subroutine */ int ztgex2_(logical *wantq, logical *wantz, integer *n, 	doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 	doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz, 	integer *j1, integer *info){    /* System generated locals */    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, 	    z_offset, i__1, i__2, i__3;    doublereal d__1;    doublecomplex z__1, z__2, z__3;    /* Builtin functions */    double sqrt(doublereal), z_abs(doublecomplex *);    void d_cnjg(doublecomplex *, doublecomplex *);    /* Local variables */    static doublecomplex f, g;    static integer i__, m;    static doublecomplex s[4]	/* was [2][2] */, t[4]	/* was [2][2] */;    static doublereal cq, sa, sb, cz;    static doublecomplex sq;    static doublereal ss, ws;    static doublecomplex sz;    static doublereal eps, sum;    static logical weak;    static doublecomplex cdum, work[8];    extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, doublecomplex *);    static doublereal scale;    extern doublereal dlamch_(char *, ftnlen);    static logical dtrong;    static doublereal thresh;    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, ftnlen), 	    zlartg_(doublecomplex *, doublecomplex *, doublereal *, 	    doublecomplex *, doublecomplex *);    static doublereal smlnum;    extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,	     doublereal *, doublereal *);/*  -- LAPACK auxiliary 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 *//*  ======= *//*  ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) *//*  in an upper triangular matrix pair (A, B) by an unitary equivalence *//*  transformation. *//*  (A, B) must be in generalized Schur canonical form, that is, A and *//*  B are both upper triangular. *//*  Optionally, the matrices Q and Z of generalized Schur vectors are *//*  updated. *//*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' *//*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' *//*  Arguments *//*  ========= *//*  WANTQ   (input) LOGICAL *//*          .TRUE. : update the left transformation matrix Q; *//*          .FALSE.: do not update Q. *//*  WANTZ   (input) LOGICAL *//*          .TRUE. : update the right transformation matrix Z; *//*          .FALSE.: do not update Z. *//*  N       (input) INTEGER *//*          The order of the matrices A and B. N >= 0. *//*  A       (input/output) COMPLEX*16 arrays, dimensions (LDA,N) *//*          On entry, the matrix A in the pair (A, B). *//*          On exit, the updated matrix A. *//*  LDA     (input)  INTEGER *//*          The leading dimension of the array A. LDA >= max(1,N). *//*  B       (input/output) COMPLEX*16 arrays, dimensions (LDB,N) *//*          On entry, the matrix B in the pair (A, B). *//*          On exit, the updated matrix B. *//*  LDB     (input)  INTEGER *//*          The leading dimension of the array B. LDB >= max(1,N). *//*  Q       (input/output) COMPLEX*16 array, dimension (LDZ,N) *//*          If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, *//*          the updated matrix Q. *//*          Not referenced if WANTQ = .FALSE.. *///.........这里部分代码省略.........

/* Subroutine */ int zgtsvx_(char *fact, char *trans, integer *n, integer *	nrhs, doublecomplex *dl, doublecomplex *d__, doublecomplex *du, 	doublecomplex *dlf, doublecomplex *df, doublecomplex *duf, 	doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, 	doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, 	doublereal *berr, doublecomplex *work, doublereal *rwork, integer *	info){    /* System generated locals */    integer b_dim1, b_offset, x_dim1, x_offset, i__1;    /* Local variables */    char norm[1];    extern logical lsame_(char *, char *);    doublereal anorm;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *);    extern doublereal dlamch_(char *);    logical nofact;    extern /* Subroutine */ int xerbla_(char *, integer *);    extern doublereal zlangt_(char *, integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *);    logical notran;    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *), 	    zgtcon_(char *, integer *, doublecomplex *, doublecomplex *, 	    doublecomplex *, doublecomplex *, integer *, doublereal *, 	    doublereal *, doublecomplex *, integer *), zgtrfs_(char *, 	     integer *, integer *, doublecomplex *, doublecomplex *, 	    doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, doublereal *, 	    doublecomplex *, doublereal *, integer *), zgttrf_(	    integer *, doublecomplex *, doublecomplex *, doublecomplex *, 	    doublecomplex *, integer *, integer *), zgttrs_(char *, integer *, 	     integer *, doublecomplex *, doublecomplex *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);/*  -- LAPACK routine (version 3.2) -- *//*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. *//*     November 2006 *//*     .. Scalar Arguments .. *//*     .. *//*     .. Array Arguments .. *//*     .. *//*  Purpose *//*  ======= *//*  ZGTSVX uses the LU factorization to compute the solution to a complex *//*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B, *//*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS *//*  matrices. *//*  Error bounds on the solution and a condition estimate are also *//*  provided. *//*  Description *//*  =========== *//*  The following steps are performed: *//*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A *//*     as A = L * U, where L is a product of permutation and unit lower *//*     bidiagonal matrices and U is upper triangular with nonzeros in *//*     only the main diagonal and first two superdiagonals. *//*  2. If some U(i,i)=0, so that U is exactly singular, then the routine *//*     returns with INFO = i. Otherwise, the factored form of A is used *//*     to estimate the condition number of the matrix A.  If the *//*     reciprocal of the condition number is less than machine precision, *//*     INFO = N+1 is returned as a warning, but the routine still goes on *//*     to solve for X and compute error bounds as described below. *//*  3. The system of equations is solved for X using the factored form *//*     of A. *//*  4. Iterative refinement is applied to improve the computed solution *//*     matrix and calculate error bounds and backward error estimates *//*     for it. *//*  Arguments *//*  ========= *//*  FACT    (input) CHARACTER*1 *//*          Specifies whether or not the factored form of A has been *//*          supplied on entry. *//*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored form *//*                  of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not *//*                  be modified. *//*          = 'N':  The matrix will be copied to DLF, DF, and DUF *//*                  and factored. *//*  TRANS   (input) CHARACTER*1 *//*          Specifies the form of the system of equations: *//*          = 'N':  A * X = B     (No transpose) *//*          = 'T':  A**T * X = B  (Transpose) *//*          = 'C':  A**H * X = B  (Conjugate transpose) *///.........这里部分代码省略.........

/* 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 ) *///.........这里部分代码省略.........

//.........这里部分代码省略.........    extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *, 	     integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, 	    doublereal *), zgges_(char *, char *, char *, L_fp, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, integer *, 	     doublecomplex *, doublecomplex *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublereal *, logical *, integer *);    integer nmats, jsize;    extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *, 	     doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, doublereal *);    integer nerrs, jtype, ntest, isort;    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(	    integer *, integer *, integer *, integer *, logical *, doublereal 	    *, doublereal *, doublereal *, integer *, integer *, 	    doublecomplex *, integer *);    logical ilabad;    extern doublereal dlamch_(char *);    extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, 	    integer *, doublecomplex *, integer *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *);    doublereal safmin, safmax;    integer knteig, ioldsd[4];    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 	    integer *, integer *);    extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 	    *, integer *), xerbla_(char *, integer *), 	    zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, 	    doublecomplex *);    extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *, 	    integer *);    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *), 	    zlaset_(char *, integer *, integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *, integer *);    extern logical zlctes_(doublecomplex *, doublecomplex *);    integer minwrk, maxwrk;    doublereal ulpinv;    integer mtypes, ntestt;    /* Fortran I/O blocks */    static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };    static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };    static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };    static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };    static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };    static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };    static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };    static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };    static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };    static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };/*  -- LAPACK test routine (version 3.1.1) -- *//*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. *//*     February 2007 *//*     .. Scalar Arguments .. *//*     .. *//*     .. Array Arguments .. *//*     .. *//*  Purpose */

/* Subroutine */ int zchkhp_(logical *dotype, integer *nn, integer *nval, 	integer *nns, integer *nsval, doublereal *thresh, logical *tsterr, 	integer *nmax, doublecomplex *a, doublecomplex *afac, doublecomplex *	ainv, 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 uplos[1*2] = "U" "L";    /* Format strings */    static char fmt_9999[] = "(/002 UPLO = '/002,a1,/002', N =/002,i5,/002, "	    "type /002,i2,/002, test /002,i2,/002, ratio =/002,g12.5)";    static char fmt_9998[] = "(/002 UPLO = '/002,a1,/002', N =/002,i5,/002, "	    "NRHS=/002,i3,/002, type /002,i2,/002, test(/002,i2,/002) =/002,g"	    "12.5)";    /* System generated locals */    integer i__1, i__2, i__3, i__4, i__5;    /* 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, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat, 	    info;    char path[3], dist[1];    integer irhs, nrhs;    char uplo[1], type__[1];    integer nrun;    extern /* Subroutine */ int alahd_(integer *, char *);    integer nfail, iseed[4];    extern doublereal dget06_(doublereal *, doublereal *);    extern logical lsame_(char *, char *);    doublereal rcond;    integer nimat;    doublereal anorm;    extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *, 	     integer *, doublecomplex *, integer *, doublereal *, doublereal *), zhpt01_(char *, integer *, doublecomplex *, doublecomplex *, 	    integer *, doublecomplex *, integer *, doublereal *, doublereal *);    integer iuplo, izero, nerrs;    extern /* Subroutine */ int zppt02_(char *, integer *, integer *, 	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublereal *, doublereal *), zppt03_(char *, 	    integer *, doublecomplex *, doublecomplex *, doublecomplex *, 	    integer *, doublereal *, doublereal *, doublereal *);    logical zerot;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *), zppt05_(char *, integer *, integer *, 	     doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublecomplex *, integer *, doublereal *, doublereal *, 	     doublereal *);    char xtype[1];    extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer 	    *, char *, integer *, integer *, doublereal *, integer *, 	    doublereal *, char *), alaerh_(char *, 	    char *, integer *, integer *, char *, integer *, integer *, 	    integer *, integer *, integer *, integer *, integer *, integer *, 	    integer *);    doublereal rcondc;    char packit[1];    extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 	    *, integer *);    doublereal cndnum;    extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *, 	     integer *);    logical trfcon;    extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *, 	    doublereal *);    extern /* Subroutine */ int zhpcon_(char *, integer *, doublecomplex *, 	    integer *, doublereal *, doublereal *, doublecomplex *, 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 *), zlatms_(integer *, integer *, char *, 	    integer *, char *, doublereal *, integer *, doublereal *, 	    doublereal *, integer *, integer *, char *, doublecomplex *, 	    integer *, doublecomplex *, integer *), 	    zhprfs_(char *, integer *, integer *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, doublereal *, 	    doublecomplex *, doublereal *, integer *), zhptrf_(char *, 	     integer *, doublecomplex *, integer *, integer *);    doublereal result[8];    extern /* Subroutine */ int zhptri_(char *, integer *, doublecomplex *, 	    integer *, doublecomplex *, integer *), zhptrs_(char *, 	    integer *, integer *, doublecomplex *, integer *, doublecomplex *, 	     integer *, integer *), zerrsy_(char *, integer *)	    ;    /* Fortran I/O blocks */    static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };    static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };    static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };//.........这里部分代码省略.........

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;//.........这里部分代码省略.........

/* Subroutine */ int zneigh_(doublereal *rnorm, integer *n, doublecomplex *	h__, integer *ldh, doublecomplex *ritz, doublecomplex *bounds, 	doublecomplex *q, integer *ldq, doublecomplex *workl, doublereal *	rwork, integer *ierr){    /* System generated locals */    integer h_dim1, h_offset, q_dim1, q_offset, i__1;    doublereal d__1;    /* Local variables */    static integer j;    static real t0, t1;    static doublecomplex vl[1];    static doublereal temp;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *), zmout_(integer *, integer *, integer 	    *, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(	    integer *, integer *, doublecomplex *, integer *, char *, ftnlen);    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);    extern /* Subroutine */ int second_(real *);    static logical select[1];    static integer msglvl;    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, ftnlen), 	    zlahqr_(logical *, logical *, integer *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, integer *,	     doublecomplex *, integer *, integer *), ztrevc_(char *, char *, 	    logical *, integer *, doublecomplex *, integer *, doublecomplex *,	     integer *, doublecomplex *, integer *, integer *, integer *, 	    doublecomplex *, doublereal *, integer *, ftnlen, ftnlen), 	    zdscal_(integer *, doublereal *, doublecomplex *, integer *), 	    zlaset_(char *, integer *, integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *, integer *, ftnlen);/*     %----------------------------------------------------% *//*     | Include files for debugging and timing information | *//*     %----------------------------------------------------% *//* /SCCS Information: @(#) *//* FILE: debug.h   SID: 2.3   DATE OF SID: 11/16/95   RELEASE: 2 *//*     %---------------------------------% *//*     | See debug.doc for documentation | *//*     %---------------------------------% *//*     %------------------% *//*     | Scalar Arguments | *//*     %------------------% *//*     %--------------------------------% *//*     | See stat.doc for documentation | *//*     %--------------------------------% *//* /SCCS Information: @(#) *//* FILE: stat.h   SID: 2.2   DATE OF SID: 11/16/95   RELEASE: 2 *//*     %-----------------% *//*     | Array Arguments | *//*     %-----------------% *//*     %------------% *//*     | Parameters | *//*     %------------% *//*     %------------------------% *//*     | Local Scalars & Arrays | *//*     %------------------------% *//*     %----------------------% *//*     | External Subroutines | *//*     %----------------------% *//*     %--------------------% *//*     | External Functions | *//*     %--------------------% *//*     %-----------------------% *//*     | Executable Statements | *//*     %-----------------------% *//*     %-------------------------------% *//*     | Initialize timing statistics  | *//*     | & message level for debugging | *//*     %-------------------------------% */    /* Parameter adjustments */    --rwork;    --workl;    --bounds;    --ritz;    h_dim1 = *ldh;//.........这里部分代码省略.........

//.........这里部分代码省略.........    }/*     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;

//.........这里部分代码省略.........			    i__4 = ioff;			    a[i__4].r = 0., a[i__4].i = 0.;			    ioff += lda;/* L30: */			}		    } else {			ioff = izero;			i__3 = izero - 1;			for (i__ = 1; i__ <= i__3; ++i__) {			    i__4 = ioff;			    a[i__4].r = 0., a[i__4].i = 0.;			    ioff += lda;/* L40: */			}			ioff -= izero;			i__3 = n;			for (i__ = izero; i__ <= i__3; ++i__) {			    i__4 = ioff + i__;			    a[i__4].r = 0., a[i__4].i = 0.;/* L50: */			}		    }		} else {		    izero = 0;		}/*              Set the imaginary part of the diagonals. */		i__3 = lda + 1;		zlaipd_(&n, &a[1], &i__3, &c__0);/*              Save a copy of the matrix A in ASAV. */		zlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);		for (iequed = 1; iequed <= 2; ++iequed) {		    *(unsigned char *)equed = *(unsigned char *)&equeds[			    iequed - 1];		    if (iequed == 1) {			nfact = 3;		    } else {			nfact = 1;		    }		    i__3 = nfact;		    for (ifact = 1; ifact <= i__3; ++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 L90;			    }			    rcondc = 0.;			} else if (! lsame_(fact, "N")) 				{/*                       Compute the condition number for comparison with *//*                       the value returned by ZPOSVX (FACT = 'N' reuses *//*                       the condition number from the previous iteration *//*                       with FACT = 'F'). */

/* 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 *, //.........这里部分代码省略.........

/* Subroutine */ int zlahr2_(integer *n, integer *k, integer *nb, 	doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, 	integer *ldt, doublecomplex *y, integer *ldy){    /* System generated locals */    integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, 	    i__3;    doublecomplex z__1;    /* Local variables */    integer i__;    doublecomplex ei;    extern /* Subroutine */ int zscal_(integer *, doublecomplex *, 	    doublecomplex *, integer *), zgemm_(char *, char *, integer *, 	    integer *, integer *, doublecomplex *, doublecomplex *, integer *, 	     doublecomplex *, integer *, doublecomplex *, doublecomplex *, 	    integer *), zgemv_(char *, integer *, integer *, 	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublecomplex *, doublecomplex *, integer *), 	    zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, 	    integer *), ztrmm_(char *, char *, char *, char *, integer *, 	    integer *, doublecomplex *, doublecomplex *, integer *, 	    doublecomplex *, integer *), 	    zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, 	    doublecomplex *, integer *), ztrmv_(char *, char *, char *, 	    integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, 	    doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, 	     doublecomplex *, integer *, doublecomplex *, integer *);/*  -- LAPACK auxiliary routine (version 3.2) -- *//*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. *//*     November 2006 *//*     .. Scalar Arguments .. *//*     .. *//*     .. Array Arguments .. *//*     .. *//*  Purpose *//*  ======= *//*  ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) *//*  matrix A so that elements below the k-th subdiagonal are zero. The *//*  reduction is performed by an unitary similarity transformation *//*  Q' * A * Q. The routine returns the matrices V and T which determine *//*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. *//*  This is an auxiliary routine called by ZGEHRD. *//*  Arguments *//*  ========= *//*  N       (input) INTEGER *//*          The order of the matrix A. *//*  K       (input) INTEGER *//*          The offset for the reduction. Elements below the k-th *//*          subdiagonal in the first NB columns are reduced to zero. *//*          K < N. *//*  NB      (input) INTEGER *//*          The number of columns to be reduced. *//*  A       (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) *//*          On entry, the n-by-(n-k+1) general matrix A. *//*          On exit, the elements on and above the k-th subdiagonal in *//*          the first NB columns are overwritten with the corresponding *//*          elements of the reduced matrix; the elements below the k-th *//*          subdiagonal, with the array TAU, represent the matrix Q as a *//*          product of elementary reflectors. The other columns of A are *//*          unchanged. See Further Details. *//*  LDA     (input) INTEGER *//*          The leading dimension of the array A.  LDA >= max(1,N). *//*  TAU     (output) COMPLEX*16 array, dimension (NB) *//*          The scalar factors of the elementary reflectors. See Further *//*          Details. *//*  T       (output) COMPLEX*16 array, dimension (LDT,NB) *//*          The upper triangular matrix T. *//*  LDT     (input) INTEGER *//*          The leading dimension of the array T.  LDT >= NB. *//*  Y       (output) COMPLEX*16 array, dimension (LDY,NB) *//*          The n-by-nb matrix Y. *//*  LDY     (input) INTEGER *//*          The leading dimension of the array Y. LDY >= N. *//*  Further Details *//*  =============== *//*  The matrix Q is represented as a product of nb elementary reflectors *//*     Q = H(1) H(2) . . . H(nb). *///.........这里部分代码省略.........

/* 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)//.........这里部分代码省略.........

/* Subroutine */ int ztimql_(char *line, integer *nm, integer *mval, integer *	nval, integer *nk, integer *kval, integer *nnb, integer *nbval, 	integer *nxval, integer *nlda, integer *ldaval, doublereal *timmin, 	doublecomplex *a, doublecomplex *tau, doublecomplex *b, doublecomplex 	*work, doublereal *rwork, doublereal *reslts, integer *ldr1, integer *	ldr2, integer *ldr3, integer *nout, ftnlen line_len){    /* Initialized data */    static char subnam[6*3] = "ZGEQLF" "ZUNGQL" "ZUNMQL";    static char sides[1*2] = "L" "R";    static char transs[1*2] = "N" "C";    static integer iseed[4] = { 0,0,0,1 };    /* Format strings */    static char fmt_9999[] = "(1x,a6,/002 timing run not attempted/002,/)";    static char fmt_9998[] = "(//002 *** Speed of /002,a6,/002 in megaflops "	    "***/002)";    static char fmt_9997[] = "(5x,/002line /002,i2,/002 with LDA = /002,i5)";    static char fmt_9996[] = "(5x,/002K = min(M,N)/002,/)";    static char fmt_9995[] = "(/5x,a6,/002 with SIDE = '/002,a1,/002', TRANS"	    " = '/002,a1,/002', /002,a1,/002 =/002,i6,/)";    static char fmt_9994[] = "(/002 *** No pairs (M,N) found with M >= N: "	    " /002,a6,/002 not timed/002)";    /* System generated locals */    integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2, 	    i__3, i__4, i__5, i__6;    /* Builtin functions          Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),	     s_wsle(cilist *), e_wsle(void);    /* Local variables */    static integer ilda;    static char labm[1], side[1];    static integer info;    static char path[3];    static doublereal time;    static integer isub, muse[12], nuse[12], i__, k, m, n;    static char cname[6];    static integer iside;    extern doublereal dopla_(char *, integer *, integer *, integer *, integer 	    *, integer *);    static integer itoff, itran, minmn;    extern /* Subroutine */ int icopy_(integer *, integer *, integer *, 	    integer *, integer *);    static char trans[1];    static integer k1, i4, m1, n1;    static doublereal s1, s2;    extern /* Subroutine */ int dprtb4_(char *, char *, char *, integer *, 	    integer *, integer *, integer *, integer *, integer *, integer *, 	    doublereal *, integer *, integer *, integer *, ftnlen, ftnlen, 	    ftnlen), dprtb5_(char *, char *, char *, integer *, integer *, 	    integer *, integer *, integer *, integer *, doublereal *, integer 	    *, integer *, integer *, ftnlen, ftnlen, ftnlen);    static integer ic, nb, ik, im;    extern doublereal dsecnd_(void);    static integer lw, nx, reseed[4];    extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer 	    *, integer *, integer *, integer *, integer *, ftnlen);    extern doublereal dmflop_(doublereal *, doublereal *, integer *);    extern /* Subroutine */ int atimin_(char *, char *, integer *, char *, 	    logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), zgeqlf_(	    integer *, integer *, doublecomplex *, integer *, doublecomplex *,	     doublecomplex *, integer *, integer *), xlaenv_(integer *, 	    integer *);    static doublereal untime;    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *);    static logical timsub[3];    extern /* Subroutine */ int ztimmg_(integer *, integer *, integer *, 	    doublecomplex *, integer *, integer *, integer *), zlatms_(	    integer *, integer *, char *, integer *, char *, doublereal *, 	    integer *, doublereal *, doublereal *, integer *, integer *, char 	    *, doublecomplex *, integer *, doublecomplex *, integer *), zungql_(integer *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 	    integer *, integer *), zunmql_(char *, char *, integer *, integer 	    *, integer *, doublecomplex *, integer *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);    static integer lda, icl, inb, imx;    static doublereal ops;    /* Fortran I/O blocks */    static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };    static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };    static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };    static cilist io___32 = { 0, 0, 0, 0, 0 };    static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };    static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };    static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };    static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };    static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };    static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };    static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]//.........这里部分代码省略.........

//.........这里部分代码省略.........                         not positive definite, so the factorization                            could not be completed, and the solution has not                            been computed. RCOND = 0 is returned.                     = N+1: U is nonsingular, but RCOND is less than machine                            precision, meaning that the matrix is singular                            to working precision.  Nevertheless, the                            solution and error bounds are computed because                            there are a number of situations where the                            computed solution can be more accurate than the                            value of RCOND would suggest.       =====================================================================          Test the input parameters.          Parameter adjustments */    /* Table of constant values */    static integer c__1 = 1;        /* System generated locals */    integer b_dim1, b_offset, x_dim1, x_offset, i__1;    /* Local variables */    extern logical lsame_(char *, char *);    static doublereal anorm;    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 	    doublereal *, integer *), zcopy_(integer *, doublecomplex *, 	    integer *, doublecomplex *, integer *);    extern doublereal dlamch_(char *);    static logical nofact;    extern /* Subroutine */ int xerbla_(char *, integer *);    extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *	    );    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *), 	    zptcon_(integer *, doublereal *, doublecomplex *, doublereal *, 	    doublereal *, doublereal *, integer *), zptrfs_(char *, integer *,	     integer *, doublereal *, doublecomplex *, doublereal *, 	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublereal *, doublereal *, doublecomplex *, 	    doublereal *, integer *), zpttrf_(integer *, doublereal *,	     doublecomplex *, integer *), zpttrs_(char *, integer *, integer *	    , doublereal *, doublecomplex *, doublecomplex *, integer *, 	    integer *);    --d__;    --e;    --df;    --ef;    b_dim1 = *ldb;    b_offset = 1 + b_dim1 * 1;    b -= b_offset;    x_dim1 = *ldx;    x_offset = 1 + x_dim1 * 1;    x -= x_offset;    --ferr;    --berr;    --work;    --rwork;    /* Function Body */    *info = 0;    nofact = lsame_(fact, "N");    if (! nofact && ! lsame_(fact, "F")) {	*info = -1;

//.........这里部分代码省略.........                      0:  zero matrix                         1:  one small singular value                         2:  exponential distribution */		    mode = imode - 1;/*                 Test ZTZRQF                      Generate test matrix of size m by n using                      singular value distribution indicated by `mode'. */		    if (mode == 0) {			zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);			i__3 = mnmin;			for (i__ = 1; i__ <= i__3; ++i__) {			    copys[i__] = 0.;/* L20: */			}		    } else {			d__1 = 1. / eps;			zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &				copys[1], &imode, &d__1, &c_b15, &m, &n, 				"No packing", &a[1], &lda, &work[1], &info);			zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin + 				1], &info);			i__3 = m - 1;			zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &				lda);			dlaord_("Decreasing", &mnmin, &copys[1], &c__1);		    }/*                 Save A and its singular values */		    zlacpy_("All", &m, &n, &a[1], &lda, &copya[1], &lda);/*                 Call ZTZRQF to reduce the upper trapezoidal matrix to                      upper triangular form. */		    s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6);		    ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);/*                 Compute norm(svd(a) - svd(r)) */		    result[0] = zqrt12_(&m, &m, &a[1], &lda, &copys[1], &work[			    1], &lwork, &rwork[1]);/*                 Compute norm( A - R*Q ) */		    result[1] = ztzt01_(&m, &n, &copya[1], &a[1], &lda, &tau[			    1], &work[1], &lwork);/*                 Compute norm(Q'*Q - I). */		    result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]			    , &lwork);/*                 Test ZTZRZF                      Generate test matrix of size m by n using                      singular value distribution indicated by `mode'. */		    if (mode == 0) {			zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);			i__3 = mnmin;			for (i__ = 1; i__ <= i__3; ++i__) {			    copys[i__] = 0.;

/* 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. *///.........这里部分代码省略.........

/* Subroutine */int zpbsvx_(char *fact, char *uplo, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal * ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info){    /* System generated locals */    integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;    doublereal d__1, d__2;    doublecomplex z__1;    /* Local variables */    integer i__, j, j1, j2;    doublereal amax, smin, smax;    extern logical lsame_(char *, char *);    doublereal scond, anorm;    logical equil, rcequ, upper;    extern /* Subroutine */    int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);    extern doublereal dlamch_(char *);    logical nofact;    extern /* Subroutine */    int xerbla_(char *, integer *);    extern doublereal zlanhb_(char *, char *, integer *, integer *, doublecomplex *, integer *, doublereal *);    doublereal bignum;    extern /* Subroutine */    int zlaqhb_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, char *);    integer infequ;    extern /* Subroutine */    int zpbcon_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex * , integer *), zpbequ_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, integer *), zpbrfs_(char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer * , doublereal *, doublereal *, doublecomplex *, doublereal *, integer *), zpbtrf_(char *, integer *, integer *, doublecomplex *, integer *, integer *);    doublereal smlnum;    extern /* Subroutine */    int zpbtrs_(char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);    /* -- LAPACK driver routine (version 3.4.1) -- */    /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */    /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */    /* April 2012 */    /* .. Scalar Arguments .. */    /* .. */    /* .. Array Arguments .. */    /* .. */    /* ===================================================================== */    /* .. Parameters .. */    /* .. */    /* .. Local Scalars .. */    /* .. */    /* .. External Functions .. */    /* .. */    /* .. External Subroutines .. */    /* .. */    /* .. Intrinsic Functions .. */    /* .. */    /* .. Executable Statements .. */    /* Parameter adjustments */    ab_dim1 = *ldab;    ab_offset = 1 + ab_dim1;    ab -= ab_offset;    afb_dim1 = *ldafb;    afb_offset = 1 + afb_dim1;    afb -= afb_offset;    --s;    b_dim1 = *ldb;    b_offset = 1 + b_dim1;    b -= b_offset;    x_dim1 = *ldx;    x_offset = 1 + x_dim1;    x -= x_offset;    --ferr;    --berr;    --work;    --rwork;    /* Function Body */    *info = 0;    nofact = lsame_(fact, "N");    equil = lsame_(fact, "E");    upper = lsame_(uplo, "U");    if (nofact || equil)    {        *(unsigned char *)equed = 'N';        rcequ = FALSE_;    }    else    {        rcequ = lsame_(equed, "Y");        smlnum = dlamch_("Safe minimum");        bignum = 1. / smlnum;    }    /* Test the input parameters. */    if (! nofact && ! equil && ! lsame_(fact, "F"))    {        *info = -1;    }    else if (! upper && ! lsame_(uplo, "L"))    {        *info = -2;    }    else if (*n < 0)    {        *info = -3;    }    else if (*kd < 0)    {        *info = -4;    }//.........这里部分代码省略.........

/* Subroutine */ int zget36_(doublereal *rmax, integer *lmax, integer *ninfo, 	integer *knt, integer *nin){    /* System generated locals */    integer i__1, i__2, i__3, i__4;    /* Builtin functions */    integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 	    e_rsle(void);    /* Local variables */    static doublecomplex diag[10];    static integer ifst, ilst;    static doublecomplex work[200];    static integer info1, info2, i__, j, n;    static doublecomplex q[100]	/* was [10][10] */, ctemp;    extern /* Subroutine */ int zhst01_(integer *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublereal *, doublereal *);    static doublereal rwork[10];    static doublecomplex t1[100]	/* was [10][10] */, t2[100]	/* 	    was [10][10] */;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *);    extern doublereal dlamch_(char *);    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *), 	    zlaset_(char *, integer *, integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *, integer *);    static doublereal result[2];    extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *, 	    integer *, doublecomplex *, integer *, integer *, integer *, 	    integer *);    static doublereal eps, res;    static doublecomplex tmp[100]	/* was [10][10] */;    /* Fortran I/O blocks */    static cilist io___2 = { 0, 0, 0, 0, 0 };    static cilist io___7 = { 0, 0, 0, 0, 0 };#define q_subscr(a_1,a_2) (a_2)*10 + a_1 - 11#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]#define t1_subscr(a_1,a_2) (a_2)*10 + a_1 - 11#define t1_ref(a_1,a_2) t1[t1_subscr(a_1,a_2)]#define t2_subscr(a_1,a_2) (a_2)*10 + a_1 - 11#define t2_ref(a_1,a_2) t2[t2_subscr(a_1,a_2)]#define tmp_subscr(a_1,a_2) (a_2)*10 + a_1 - 11#define tmp_ref(a_1,a_2) tmp[tmp_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       =======       ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a       matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix       Q such that          Q' * T1 * Q  = T2       and where one of the diagonal blocks of T1 (the one at row IFST) has       been moved to position ILST.       The test code verifies that the residual Q'*T1*Q-T2 is small, that T2       is in Schur form, and that the final position of the IFST block is       ILST.       The test matrices are read from a file with logical unit number NIN.       Arguments       ==========       RMAX    (output) DOUBLE PRECISION               Value of the largest test ratio.       LMAX    (output) INTEGER               Example number where largest test ratio achieved.       NINFO   (output) INTEGER               Number of examples where INFO is nonzero.       KNT     (output) INTEGER               Total number of examples tested.       NIN     (input) INTEGER               Input logical unit number.       ===================================================================== */    eps = dlamch_("P");    *rmax = 0.;//.........这里部分代码省略.........

/* Subroutine */ int zchkgt_(logical *dotype, integer *nn, integer *nval, 	integer *nns, integer *nsval, doublereal *thresh, logical *tsterr, 	doublecomplex *a, doublecomplex *af, doublecomplex *b, doublecomplex *	x, doublecomplex *xact, doublecomplex *work, doublereal *rwork, 	integer *iwork, integer *nout){    /* Initialized data */    static integer iseedy[4] = { 0,0,0,1 };    static char transs[1*3] = "N" "T" "C";    /* Format strings */    static char fmt_9999[] = "(12x,/002N =/002,i5,/002,/002,10x,/002 type"	    " /002,i2,/002, test(/002,i2,/002) = /002,g12.5)";    static char fmt_9997[] = "(/002 NORM ='/002,a1,/002', N =/002,i5,/002"	    ",/002,10x,/002 type /002,i2,/002, test(/002,i2,/002) = /002,g12."	    "5)";    static char fmt_9998[] = "(/002 TRANS='/002,a1,/002', N =/002,i5,/002, N"	    "RHS=/002,i3,/002, type /002,i2,/002, test(/002,i2,/002) = /002,g"	    "12.5)";    /* System generated locals */    integer i__1, i__2, i__3, i__4, i__5;    doublereal d__1, d__2;    /* 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;    doublecomplex z__[3];    integer in, kl, ku, ix, lda;    doublereal cond;    integer 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;    integer nimat;    doublereal anorm;    integer itran;    extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *, 	     integer *, doublecomplex *, integer *, doublereal *, doublereal *);    char trans[1];    integer izero, nerrs;    extern /* Subroutine */ int zgtt01_(integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublereal *, doublereal *), zgtt02_(char *, integer *, 	     integer *, doublecomplex *, doublecomplex *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublereal *, doublereal *), zgtt05_(char *, integer *, 	    integer *, doublecomplex *, doublecomplex *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, doublereal *, 	    doublereal *);    logical zerot;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *), zlatb4_(char *, integer *, integer *, 	     integer *, char *, integer *, integer *, doublereal *, integer *, 	     doublereal *, char *), alaerh_(char *, 	    char *, integer *, integer *, char *, integer *, integer *, 	    integer *, integer *, integer *, integer *, integer *, integer *, 	    integer *);    doublereal rcondc, rcondi;    extern /* Subroutine */ int zdscal_(integer *, doublereal *, 	    doublecomplex *, integer *), alasum_(char *, integer *, integer *, 	     integer *, integer *);    doublereal rcondo, ainvnm;    logical trfcon;    extern /* Subroutine */ int zerrge_(char *, integer *);    extern doublereal zlangt_(char *, integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *);    extern /* Subroutine */ int zlagtm_(char *, integer *, integer *, 	    doublereal *, doublecomplex *, doublecomplex *, doublecomplex *, 	    doublecomplex *, integer *, doublereal *, doublecomplex *, 	    integer *), zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *);    extern doublereal dzasum_(integer *, doublecomplex *, integer *);    extern /* Subroutine */ int zgtcon_(char *, integer *, doublecomplex *, 	    doublecomplex *, doublecomplex *, doublecomplex *, integer *, 	    doublereal *, doublereal *, doublecomplex *, integer *), 	    zlatms_(integer *, integer *, char *, integer *, char *, 	    doublereal *, integer *, doublereal *, doublereal *, integer *, 	    integer *, char *, doublecomplex *, integer *, doublecomplex *, 	    integer *), zlarnv_(integer *, integer *, 	    integer *, doublecomplex *);    doublereal result[7];    extern /* Subroutine */ int zgtrfs_(char *, integer *, integer *, 	    doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublereal *, doublereal *, doublecomplex *, doublereal *, 	    integer *), zgttrf_(integer *, doublecomplex *, //.........这里部分代码省略.........

//.........这里部分代码省略.........	    vr_offset, i__1, i__2;    doublereal d__1, d__2;    doublecomplex z__1;    /* Builtin functions */    double z_abs(doublecomplex *);    /* Local variables */    static doublereal cond;    static integer ierr, ifst;    static doublereal lnrm;    static doublecomplex yhax, yhbx;    static integer ilst;    static doublereal rnrm;    static integer i__, k;    static doublereal scale;    extern logical lsame_(char *, char *);    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *);    static integer lwmin;    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublecomplex *, doublecomplex *, integer *);    static logical wants;    static integer llwrk, n1, n2;    static doublecomplex dummy[1];    extern doublereal dlapy2_(doublereal *, doublereal *);    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);    static doublecomplex dummy1[1];    extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(	    char *);    static integer ks;    extern /* Subroutine */ int xerbla_(char *, integer *);    static doublereal bignum;    static logical wantbh, wantdf, somcon;    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *), 	    ztgexc_(logical *, logical *, integer *, doublecomplex *, integer 	    *, doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, integer *, integer *, integer *);    static doublereal smlnum;    static logical lquery;    extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer 	    *, doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublereal *, doublereal *, doublecomplex *, integer *, integer *,	     integer *);    static doublereal eps;#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]#define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]    --select;    a_dim1 = *lda;    a_offset = 1 + a_dim1 * 1;    a -= a_offset;    b_dim1 = *ldb;    b_offset = 1 + b_dim1 * 1;    b -= b_offset;    vl_dim1 = *ldvl;    vl_offset = 1 + vl_dim1 * 1;

/* 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 *//.........这里部分代码省略.........

//.........这里部分代码省略.........        /* 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 */

/* Subroutine */ int zdrvpt_(logical *dotype, integer *nn, integer *nval, 	integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a, 	doublereal *d__, doublecomplex *e, doublecomplex *b, doublecomplex *x, 	 doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer 	*nout){    /* Initialized data */    static integer iseedy[4] = { 0,0,0,1 };    /* Format strings */    static char fmt_9999[] = "(1x,a6,/002, N =/002,i5,/002, type /002,i2,"	    "/002, test /002,i2,/002, ratio = /002,g12.5)";    static char fmt_9998[] = "(1x,a6,/002, FACT='/002,a1,/002', N =/002,i5"	    ",/002, type /002,i2,/002, test /002,i2,/002, ratio = /002,g12.5)";    /* System generated locals */    integer i__1, i__2, i__3, i__4, i__5;    doublereal d__1, d__2;    /* Builtin functions */    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);    double z_abs(doublecomplex *);    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);    /* Local variables */    integer i__, j, k, n;    doublereal z__[3];    integer k1, ia, in, kl, ku, ix, nt, lda;    char fact[1];    doublereal cond;    integer mode;    doublereal dmax__;    integer imat, info;    char path[3], dist[1], type__[1];    integer nrun, ifact;    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 	    integer *);    integer nfail, iseed[4];    extern doublereal dget06_(doublereal *, doublereal *);    doublereal rcond;    integer nimat;    doublereal anorm;    extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *, 	     integer *, doublecomplex *, integer *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *, 	    integer *);    integer izero, nerrs;    extern /* Subroutine */ int zptt01_(integer *, doublereal *, 	    doublecomplex *, doublereal *, doublecomplex *, doublecomplex *, 	    doublereal *);    logical zerot;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *), zptt02_(char *, integer *, integer *, 	     doublereal *, doublecomplex *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *), zptt05_(	    integer *, integer *, doublereal *, doublecomplex *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, doublereal *, 	    doublereal *), zptsv_(integer *, integer *, doublereal *, 	    doublecomplex *, doublecomplex *, integer *, integer *), zlatb4_(	    char *, integer *, integer *, integer *, char *, integer *, 	    integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *), alaerh_(char 	    *, char *, integer *, integer *, char *, integer *, integer *, 	    integer *, integer *, integer *, integer *, integer *, integer *, 	    integer *);    extern integer idamax_(integer *, doublereal *, integer *);    doublereal rcondc;    extern /* Subroutine */ int zdscal_(integer *, doublereal *, 	    doublecomplex *, integer *), alasvm_(char *, integer *, integer *, 	     integer *, integer *), dlarnv_(integer *, integer *, 	    integer *, doublereal *);    doublereal ainvnm;    extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *);    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, integer *);    extern doublereal dzasum_(integer *, doublecomplex *, integer *);    extern /* Subroutine */ int zlaset_(char *, integer *, integer *, 	    doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlaptm_(char *, integer *, integer *, doublereal *, 	    doublereal *, doublecomplex *, doublecomplex *, integer *, 	    doublereal *, doublecomplex *, integer *), zlatms_(	    integer *, integer *, char *, integer *, char *, doublereal *, 	    integer *, doublereal *, doublereal *, integer *, integer *, char 	    *, doublecomplex *, integer *, doublecomplex *, integer *), zlarnv_(integer *, integer *, integer *, 	    doublecomplex *);    doublereal result[6];    extern /* Subroutine */ int zpttrf_(integer *, doublereal *, 	    doublecomplex *, integer *), zerrvx_(char *, integer *), 	    zpttrs_(char *, integer *, integer *, doublereal *, doublecomplex 	    *, doublecomplex *, integer *, integer *), zptsvx_(char *, 	     integer *, integer *, doublereal *, doublecomplex *, doublereal *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, 	    integer *, doublereal *, doublereal *, doublereal *, 	    doublecomplex *, doublereal *, integer *);    /* Fortran I/O blocks */    static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };    static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };//.........这里部分代码省略.........

/* 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 *///.........这里部分代码省略.........

/* Subroutine */ int zchkqp_(logical *dotype, integer *nm, integer *mval, 	integer *nn, integer *nval, doublereal *thresh, logical *tsterr, 	doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *	copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork, 	integer *iwork, integer *nout){    /* Initialized data */    static integer iseedy[4] = { 1988,1989,1990,1991 };    /* Format strings */    static char fmt_9999[] = "(/002 M =/002,i5,/002, N =/002,i5,/002, type"	    " /002,i2,/002, test /002,i2,/002, ratio =/002,g12.5)";    /* System generated locals */    integer i__1, i__2, i__3, i__4;    doublereal d__1;    /* 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__, k, m, n, im, in, lda;    doublereal eps;    integer mode, info;    char path[3];    integer ilow, nrun;    extern /* Subroutine */ int alahd_(integer *, char *);    integer ihigh, nfail, iseed[4], imode, mnmin, istep, nerrs, lwork;    extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *), zqrt11_(integer *, integer *, 	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 	    integer *), zqrt12_(integer *, integer *, doublecomplex *, 	    integer *, doublereal *, doublecomplex *, integer *, doublereal *)	    , dlamch_(char *);    extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *, 	    integer *), alasum_(char *, integer *, integer *, integer 	    *, integer *), zgeqpf_(integer *, integer *, 	    doublecomplex *, integer *, integer *, doublecomplex *, 	    doublecomplex *, doublereal *, integer *), zlacpy_(char *, 	    integer *, integer *, doublecomplex *, integer *, doublecomplex *, 	     integer *), zlaset_(char *, integer *, integer *, 	    doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *, 	    doublereal *, integer *, doublereal *, doublereal *, integer *, 	    integer *, char *, doublecomplex *, integer *, doublecomplex *, 	    integer *);    doublereal result[3];    extern /* Subroutine */ int zerrqp_(char *, integer *);    /* Fortran I/O blocks */    static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };/*  -- LAPACK test routine (version 3.1) -- *//*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. *//*     November 2006 *//*     .. Scalar Arguments .. *//*     .. *//*     .. Array Arguments .. *//*     .. *//*  Purpose *//*  ======= *//*  ZCHKQP tests ZGEQPF. *//*  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. *//*  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 (MMAX*NMAX) *//*          where MMAX is the maximum value of M in MVAL and NMAX is the *///.........这里部分代码省略.........

/* Subroutine */int zheevx_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal * w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer * lwork, doublereal *rwork, integer *iwork, integer *ifail, integer * info){    /* System generated locals */    integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;    doublereal d__1, d__2;    /* Builtin functions */    double sqrt(doublereal);    /* Local variables */    integer i__, j, nb, jj;    doublereal eps, vll, vuu, tmp1;    integer indd, inde;    doublereal anrm;    integer imax;    doublereal rmin, rmax;    logical test;    integer itmp1, indee;    extern /* Subroutine */    int dscal_(integer *, doublereal *, doublereal *, integer *);    doublereal sigma;    extern logical lsame_(char *, char *);    integer iinfo;    char order[1];    extern /* Subroutine */    int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);    logical lower, wantz;    extern /* Subroutine */    int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);    extern doublereal dlamch_(char *);    logical alleig, indeig;    integer iscale, indibl;    logical valeig;    doublereal safmin;    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);    extern /* Subroutine */    int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);    doublereal abstll, bignum;    extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);    integer indiwk, indisp, indtau;    extern /* Subroutine */    int dsterf_(integer *, doublereal *, doublereal *, integer *), dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);    integer indrwk, indwrk;    extern /* Subroutine */    int zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublecomplex *, integer *, integer *);    integer lwkmin;    extern /* Subroutine */    int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);    integer llwork, nsplit;    doublereal smlnum;    extern /* Subroutine */    int zstein_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, integer *, integer *);    integer lwkopt;    logical lquery;    extern /* Subroutine */    int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *), zungtr_(char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);    /* -- 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 .. */    /* .. */    /* .. External Functions .. */    /* .. */    /* .. External Subroutines .. */    /* .. */    /* .. Intrinsic Functions .. */    /* .. */    /* .. Executable Statements .. */    /* Test the input parameters. */    /* Parameter adjustments */    a_dim1 = *lda;    a_offset = 1 + a_dim1;    a -= a_offset;    --w;    z_dim1 = *ldz;    z_offset = 1 + z_dim1;    z__ -= z_offset;    --work;    --rwork;    --iwork;    --ifail;    /* Function Body */    lower = lsame_(uplo, "L");    wantz = lsame_(jobz, "V");    alleig = lsame_(range, "A");    valeig = lsame_(range, "V");    indeig = lsame_(range, "I");    lquery = *lwork == -1;    *info = 0;    if (! (wantz || lsame_(jobz, "N")))    {        *info = -1;    }//.........这里部分代码省略.........

/* Subroutine */ int zlatm6_(integer *type__, integer *n, doublecomplex *a, 	integer *lda, doublecomplex *b, doublecomplex *x, integer *ldx, 	doublecomplex *y, integer *ldy, doublecomplex *alpha, doublecomplex *	beta, doublecomplex *wx, doublecomplex *wy, doublereal *s, doublereal 	*dif){    /* System generated locals */    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, 	    y_offset, i__1, i__2, i__3;    doublereal d__1, d__2;    doublecomplex z__1, z__2, z__3, z__4;    /* Builtin functions */    void d_cnjg(doublecomplex *, doublecomplex *);    double z_abs(doublecomplex *), sqrt(doublereal);    /* Local variables */    integer i__, j;    doublecomplex z__[64]	/* was [8][8] */;    integer info;    doublecomplex work[26];    doublereal rwork[50];    extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *, 	     integer *, doublecomplex *, doublecomplex *, doublecomplex *, 	    doublecomplex *, integer *), zgesvd_(char *, char *, integer *, 	    integer *, doublecomplex *, integer *, doublereal *, 	    doublecomplex *, integer *, doublecomplex *, integer *, 	    doublecomplex *, integer *, doublereal *, integer *), 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 *//*  ======= *//*  ZLATM6 generates test matrices for the generalized eigenvalue *//*  problem, their corresponding right and left eigenvector matrices, *//*  and also reciprocal condition numbers for all eigenvalues and *//*  the reciprocal condition numbers of eigenvectors corresponding to *//*  the 1th and 5th eigenvalues. *//*  Test Matrices *//*  ============= *//*  Two kinds of test matrix pairs *//*           (A, B) = inverse(YH) * (Da, Db) * inverse(X) *//*  are used in the tests: *//*  Type 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 Type 2: *//*     Da = 1+i   0    0       0       0    Db = 1   0   0   0   0 *//*           0   1-i   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)i  0         0   0   0   1   0 *//*           0    0    0       0 (1+a)-(1+b)i,   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. *//*  Arguments *//*  ========= *//*  TYPE    (input) INTEGER *//*          Specifies the problem type (see futher details). *//*  N       (input) INTEGER *//*          Size of the matrices A and B. *//*  A       (output) COMPLEX*16 array, dimension (LDA, N). *//*          On exit A N-by-N is initialized according to TYPE. *//*  LDA     (input) INTEGER *//*          The leading dimension of A and of B. *//*  B       (output) COMPLEX*16 array, dimension (LDA, N). *//*          On exit B N-by-N is initialized according to TYPE. *//*  X       (output) COMPLEX*16 array, dimension (LDX, N). *//*          On exit X is the N-by-N matrix of right eigenvectors. *///.........这里部分代码省略.........

//.........这里部分代码省略.........                             has not been completed unless i = N, but the                             factor U is exactly singular, so the solution                             and error bounds could not be computed.                     = N+1:  RCOND is less than machine precision.  The                             factorization has been completed, but the                             matrix is singular to working precision, and                             the solution and error bounds have not been                             computed.        =====================================================================       Parameter adjustments           Function Body */    /* Table of constant values */    static integer c__1 = 1;    /* System generated locals */    integer b_dim1, b_offset, x_dim1, x_offset, i__1;    /* Local variables */    static char norm[1];    extern logical lsame_(char *, char *);    static doublereal anorm;    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,                                       doublecomplex *, integer *);    extern doublereal dlamch_(char *);    static logical nofact;    extern /* Subroutine */ int xerbla_(char *, integer *);    extern doublereal zlangt_(char *, integer *, doublecomplex *,                              doublecomplex *, doublecomplex *);    static logical notran;    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,                                        doublecomplex *, integer *, doublecomplex *, integer *),                                                      zgtcon_(char *, integer *, doublecomplex *, doublecomplex *,                                                              doublecomplex *, doublecomplex *, integer *, doublereal *,                                                              doublereal *, doublecomplex *, integer *), zgtrfs_(char *,                                                                      integer *, integer *, doublecomplex *, doublecomplex *,                                                                      doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *                                                                      , doublecomplex *, integer *, doublecomplex *, integer *,                                                                      doublecomplex *, integer *, doublereal *, doublereal *,                                                                      doublecomplex *, doublereal *, integer *), zgttrf_(                                                                              integer *, doublecomplex *, doublecomplex *, doublecomplex *,                                                                              doublecomplex *, integer *, integer *), zgttrs_(char *, integer *,                                                                                      integer *, doublecomplex *, doublecomplex *, doublecomplex *,                                                                                      doublecomplex *, integer *, doublecomplex *, integer *, integer *);#define DL(I) dl[(I)-1]#define D(I) d[(I)-1]#define DU(I) du[(I)-1]#define DLF(I) dlf[(I)-1]#define DF(I) df[(I)-1]#define DUF(I) duf[(I)-1]#define DU2(I) du2[(I)-1]#define IPIV(I) ipiv[(I)-1]#define FERR(I) ferr[(I)-1]#define BERR(I) berr[(I)-1]#define WORK(I) work[(I)-1]#define RWORK(I) rwork[(I)-1]#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]