NOTE: The tests are renumbered in xDRVLS and xCHKTZ.
TODO: remove deprecated xGEQPF, when it is replaced by xGEQP3 in xGGSVP.
schkgg.f schkgk.f schkgl.f schkhs.f schksb.f schkst.f
sckcsd.f sckglm.f sckgqr.f sckgsv.f scklse.f scsdts.f
sdrges.f sdrgev.f sdrges3.f sdrgev3.f sdrgsx.f sdrgvx.f
- sdrvbd.f sdrves.f sdrvev.f sdrvgg.f sdrvsg.f
+ sdrvbd.f sdrves.f sdrvev.f sdrvsg.f
sdrvst.f sdrvsx.f sdrvvx.f
serrbd.f serrec.f serred.f serrgg.f serrhs.f serrst.f
sget02.f sget10.f sget22.f sget23.f sget24.f sget31.f
cchkgg.f cchkgk.f cchkgl.f cchkhb.f cchkhs.f cchkst.f
cckcsd.f cckglm.f cckgqr.f cckgsv.f ccklse.f ccsdts.f
cdrges.f cdrgev.f cdrges3.f cdrgev3.f cdrgsx.f cdrgvx.f
- cdrvbd.f cdrves.f cdrvev.f cdrvgg.f cdrvsg.f
+ cdrvbd.f cdrves.f cdrvev.f cdrvsg.f
cdrvst.f cdrvsx.f cdrvvx.f
cerrbd.f cerrec.f cerred.f cerrgg.f cerrhs.f cerrst.f
cget02.f cget10.f cget22.f cget23.f cget24.f
dchkgg.f dchkgk.f dchkgl.f dchkhs.f dchksb.f dchkst.f
dckcsd.f dckglm.f dckgqr.f dckgsv.f dcklse.f dcsdts.f
ddrges.f ddrgev.f ddrges3.f ddrgev3.f ddrgsx.f ddrgvx.f
- ddrvbd.f ddrves.f ddrvev.f ddrvgg.f ddrvsg.f
+ ddrvbd.f ddrves.f ddrvev.f ddrvsg.f
ddrvst.f ddrvsx.f ddrvvx.f
derrbd.f derrec.f derred.f derrgg.f derrhs.f derrst.f
dget02.f dget10.f dget22.f dget23.f dget24.f dget31.f
zchkgg.f zchkgk.f zchkgl.f zchkhb.f zchkhs.f zchkst.f
zckcsd.f zckglm.f zckgqr.f zckgsv.f zcklse.f zcsdts.f
zdrges.f zdrgev.f zdrges3.f zdrgev3.f zdrgsx.f zdrgvx.f
- zdrvbd.f zdrves.f zdrvev.f zdrvgg.f zdrvsg.f
+ zdrvbd.f zdrves.f zdrvev.f zdrvsg.f
zdrvst.f zdrvsx.f zdrvvx.f
zerrbd.f zerrec.f zerred.f zerrgg.f zerrhs.f zerrst.f
zget02.f zget10.f zget22.f zget23.f zget24.f
schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o \
sckcsd.o sckglm.o sckgqr.o sckgsv.o scklse.o scsdts.o \
sdrges.o sdrgev.o sdrges3.o sdrgev3.o sdrgsx.o sdrgvx.o \
- sdrvbd.o sdrves.o sdrvev.o sdrvgg.o sdrvsg.o \
+ sdrvbd.o sdrves.o sdrvev.o sdrvsg.o \
sdrvst.o sdrvsx.o sdrvvx.o \
serrbd.o serrec.o serred.o serrgg.o serrhs.o serrst.o \
sget02.o sget10.o sget22.o sget23.o sget24.o sget31.o \
cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o \
cckcsd.o cckglm.o cckgqr.o cckgsv.o ccklse.o ccsdts.o \
cdrges.o cdrgev.o cdrges3.o cdrgev3.o cdrgsx.o cdrgvx.o \
- cdrvbd.o cdrves.o cdrvev.o cdrvgg.o cdrvsg.o \
+ cdrvbd.o cdrves.o cdrvev.o cdrvsg.o \
cdrvst.o cdrvsx.o cdrvvx.o \
cerrbd.o cerrec.o cerred.o cerrgg.o cerrhs.o cerrst.o \
cget02.o cget10.o cget22.o cget23.o cget24.o \
dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o \
dckcsd.o dckglm.o dckgqr.o dckgsv.o dcklse.o dcsdts.o \
ddrges.o ddrgev.o ddrges3.o ddrgev3.o ddrgsx.o ddrgvx.o \
- ddrvbd.o ddrves.o ddrvev.o ddrvgg.o ddrvsg.o \
+ ddrvbd.o ddrves.o ddrvev.o ddrvsg.o \
ddrvst.o ddrvsx.o ddrvvx.o \
derrbd.o derrec.o derred.o derrgg.o derrhs.o derrst.o \
dget02.o dget10.o dget22.o dget23.o dget24.o dget31.o \
zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o \
zckcsd.o zckglm.o zckgqr.o zckgsv.o zcklse.o zcsdts.o \
zdrges.o zdrgev.o zdrges3.o zdrgev3.o zdrgsx.o zdrgvx.o \
- zdrvbd.o zdrves.o zdrvev.o zdrvgg.o zdrvsg.o \
+ zdrvbd.o zdrves.o zdrvev.o zdrvsg.o \
zdrvst.o zdrvsx.o zdrvvx.o \
zerrbd.o zerrec.o zerred.o zerrgg.o zerrhs.o zerrst.o \
zget02.o zget10.o zget22.o zget23.o zget24.o \
*>
*> CGG (Generalized Nonsymmetric Eigenvalue Problem):
*> Test CGGHD3, CGGBAL, CGGBAK, CHGEQZ, and CTGEVC
-*> and the driver routines CGEGS and CGEGV
*>
*> CGS (Generalized Nonsymmetric Schur form Driver):
*> Test CGGES
*> CVX 21 CDRVVX
*> CSX 21 CDRVSX
*> CGG 26 CCHKGG (routines)
-*> 26 CDRVGG (drivers)
*> CGS 26 CDRGES
*> CGX 5 CDRGSX
*> CGV 26 CDRGEV
$ CCHKGG, CCHKGK, CCHKGL, CCHKHB, CCHKHS, CCHKST,
$ CCKCSD, CCKGLM, CCKGQR, CCKGSV, CCKLSE, CDRGES,
$ CDRGEV, CDRGSX, CDRGVX, CDRVBD, CDRVES, CDRVEV,
- $ CDRVGG, CDRVSG, CDRVST, CDRVSX, CDRVVX, CERRBD,
+ $ CDRVSG, CDRVST, CDRVSX, CDRVVX, CERRBD,
$ CERRED, CERRGG, CERRHS, CERRST, ILAVER, XLAENV,
$ CDRGES3, CDRGEV3
* ..
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'CCHKGG', INFO
END IF
- CALL XLAENV( 1, 1 )
- IF( TSTDRV ) THEN
- CALL CDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
- $ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
- $ A( 1, 7 ), NMAX, A( 1, 8 ), DC( 1, 1 ),
- $ DC( 1, 2 ), DC( 1, 3 ), DC( 1, 4 ),
- $ A( 1, 8 ), A( 1, 9 ), WORK, LWORK, RWORK,
- $ RESULT, INFO )
- IF( INFO.NE.0 )
- $ WRITE( NOUT, FMT = 9980 )'CDRVGG', INFO
- END IF
350 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'CGS' ) ) THEN
+++ /dev/null
-*> \brief \b CDRVGG
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE CDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
-* THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
-* LDQ, Z, ALPHA1, BETA1, ALPHA2, BETA2, VL, VR,
-* WORK, LWORK, RWORK, RESULT, INFO )
-*
-* .. Scalar Arguments ..
-* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
-* REAL THRESH, THRSHN
-* ..
-* .. Array Arguments ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> CDRVGG checks the nonsymmetric generalized eigenvalue driver
-*> routines.
-*> T T T
-*> CGEGS factors A and B as Q S Z and Q T Z , where means
-*> transpose, T is upper triangular, S is in generalized Schur form
-*> (upper triangular), and Q and Z are unitary. It also
-*> computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) --
-*> thus, w(j) = alpha(j)/beta(j) is a root of the generalized
-*> eigenvalue problem
-*>
-*> det( A - w(j) B ) = 0
-*>
-*> and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
-*> problem
-*>
-*> det( m(j) A - B ) = 0
-*>
-*> CGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), the matrix L whose columns contain the
-*> generalized left eigenvectors l, and the matrix R whose columns
-*> contain the generalized right eigenvectors r for the pair (A,B).
-*>
-*> When CDRVGG is called, a number of matrix "sizes" ("n's") and a
-*> number of matrix "types" are specified. For each size ("n")
-*> and each type of matrix, one matrix will be generated and used
-*> to test the nonsymmetric eigenroutines. For each matrix, 7
-*> tests will be performed and compared with the threshhold THRESH:
-*>
-*> Results from CGEGS:
-*>
-*> H
-*> (1) | A - Q S Z | / ( |A| n ulp )
-*>
-*> H
-*> (2) | B - Q T Z | / ( |B| n ulp )
-*>
-*> H
-*> (3) | I - QQ | / ( n ulp )
-*>
-*> H
-*> (4) | I - ZZ | / ( n ulp )
-*>
-*> (5) maximum over j of D(j) where:
-*>
-*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
-*> D(j) = ------------------------ + -----------------------
-*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
-*>
-*> Results from CGEGV:
-*>
-*> (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
-*>
-*> | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> where l**H is the conjugate tranpose of l.
-*>
-*> (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
-*>
-*> | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> Test Matrices
-*> ---- --------
-*>
-*> The sizes of the test matrices are specified by an array
-*> NN(1:NSIZES); the value of each element NN(j) specifies one size.
-*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
-*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
-*> Currently, the list of possible types is:
-*>
-*> (1) ( 0, 0 ) (a pair of zero matrices)
-*>
-*> (2) ( I, 0 ) (an identity and a zero matrix)
-*>
-*> (3) ( 0, I ) (an identity and a zero matrix)
-*>
-*> (4) ( I, I ) (a pair of identity matrices)
-*>
-*> t t
-*> (5) ( J , J ) (a pair of transposed Jordan blocks)
-*>
-*> t ( I 0 )
-*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
-*> ( 0 I ) ( 0 J )
-*> and I is a k x k identity and J a (k+1)x(k+1)
-*> Jordan block; k=(N-1)/2
-*>
-*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
-*> matrix with those diagonal entries.)
-*> (8) ( I, D )
-*>
-*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
-*>
-*> (10) ( small*D, big*I )
-*>
-*> (11) ( big*I, small*D )
-*>
-*> (12) ( small*I, big*D )
-*>
-*> (13) ( big*D, big*I )
-*>
-*> (14) ( small*D, small*I )
-*>
-*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
-*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
-*> t t
-*> (16) Q ( J , J ) Z where Q and Z are random unitary matrices.
-*>
-*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
-*> with random O(1) entries above the diagonal
-*> and diagonal entries diag(T1) =
-*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
-*> ( 0, N-3, N-4,..., 1, 0, 0 )
-*>
-*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
-*> s = machine precision.
-*>
-*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
-*>
-*> N-5
-*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*>
-*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*> where r1,..., r(N-4) are random.
-*>
-*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
-*> matrices.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] NSIZES
-*> \verbatim
-*> NSIZES is INTEGER
-*> The number of sizes of matrices to use. If it is zero,
-*> CDRVGG does nothing. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] NN
-*> \verbatim
-*> NN is INTEGER array, dimension (NSIZES)
-*> An array containing the sizes to be used for the matrices.
-*> Zero values will be skipped. The values must be at least
-*> zero.
-*> \endverbatim
-*>
-*> \param[in] NTYPES
-*> \verbatim
-*> NTYPES is INTEGER
-*> The number of elements in DOTYPE. If it is zero, CDRVGG
-*> does nothing. It must be at least zero. If it is MAXTYP+1
-*> and NSIZES is 1, then an additional type, MAXTYP+1 is
-*> defined, which is to use whatever matrix is in A. This
-*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
-*> DOTYPE(MAXTYP+1) is .TRUE. .
-*> \endverbatim
-*>
-*> \param[in] DOTYPE
-*> \verbatim
-*> DOTYPE is LOGICAL array, dimension (NTYPES)
-*> If DOTYPE(j) is .TRUE., then for each size in NN a
-*> matrix of that size and of type j will be generated.
-*> If NTYPES is smaller than the maximum number of types
-*> defined (PARAMETER MAXTYP), then types NTYPES+1 through
-*> MAXTYP will not be generated. If NTYPES is larger
-*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
-*> will be ignored.
-*> \endverbatim
-*>
-*> \param[in,out] ISEED
-*> \verbatim
-*> ISEED is INTEGER array, dimension (4)
-*> On entry ISEED specifies the seed of the random number
-*> generator. The array elements should be between 0 and 4095;
-*> if not they will be reduced mod 4096. Also, ISEED(4) must
-*> be odd. The random number generator uses a linear
-*> congruential sequence limited to small integers, and so
-*> should produce machine independent random numbers. The
-*> values of ISEED are changed on exit, and can be used in the
-*> next call to CDRVGG to continue the same random number
-*> sequence.
-*> \endverbatim
-*>
-*> \param[in] THRESH
-*> \verbatim
-*> THRESH is REAL
-*> A test will count as "failed" if the "error", computed as
-*> described above, exceeds THRESH. Note that the error is
-*> scaled to be O(1), so THRESH should be a reasonably small
-*> multiple of 1, e.g., 10 or 100. In particular, it should
-*> not depend on the precision (single vs. double) or the size
-*> of the matrix. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] THRSHN
-*> \verbatim
-*> THRSHN is REAL
-*> Threshhold for reporting eigenvector normalization error.
-*> If the normalization of any eigenvector differs from 1 by
-*> more than THRSHN*ulp, then a special error message will be
-*> printed. (This is handled separately from the other tests,
-*> since only a compiler or programming error should cause an
-*> error message, at least if THRSHN is at least 5--10.)
-*> \endverbatim
-*>
-*> \param[in] NOUNIT
-*> \verbatim
-*> NOUNIT is INTEGER
-*> The FORTRAN unit number for printing out error messages
-*> (e.g., if a routine returns IINFO not equal to 0.)
-*> \endverbatim
-*>
-*> \param[in,out] A
-*> \verbatim
-*> A is COMPLEX array, dimension (LDA, max(NN))
-*> Used to hold the original A matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of A, B, S, T, S2, and T2.
-*> It must be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is COMPLEX array, dimension (LDA, max(NN))
-*> Used to hold the original B matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[out] S
-*> \verbatim
-*> S is COMPLEX array, dimension (LDA, max(NN))
-*> The upper triangular matrix computed from A by CGEGS.
-*> \endverbatim
-*>
-*> \param[out] T
-*> \verbatim
-*> T is COMPLEX array, dimension (LDA, max(NN))
-*> The upper triangular matrix computed from B by CGEGS.
-*> \endverbatim
-*>
-*> \param[out] S2
-*> \verbatim
-*> S2 is COMPLEX array, dimension (LDA, max(NN))
-*> The matrix computed from A by CGEGV. This will be the
-*> Schur (upper triangular) form of some matrix related to A,
-*> but will not, in general, be the same as S.
-*> \endverbatim
-*>
-*> \param[out] T2
-*> \verbatim
-*> T2 is COMPLEX array, dimension (LDA, max(NN))
-*> The matrix computed from B by CGEGV. This will be the
-*> Schur form of some matrix related to B, but will not, in
-*> general, be the same as T.
-*> \endverbatim
-*>
-*> \param[out] Q
-*> \verbatim
-*> Q is COMPLEX array, dimension (LDQ, max(NN))
-*> The (left) unitary matrix computed by CGEGS.
-*> \endverbatim
-*>
-*> \param[in] LDQ
-*> \verbatim
-*> LDQ is INTEGER
-*> The leading dimension of Q, Z, VL, and VR. It must
-*> be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[out] Z
-*> \verbatim
-*> Z is COMPLEX array, dimension (LDQ, max(NN))
-*> The (right) unitary matrix computed by CGEGS.
-*> \endverbatim
-*>
-*> \param[out] ALPHA1
-*> \verbatim
-*> ALPHA1 is COMPLEX array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA1
-*> \verbatim
-*> BETA1 is COMPLEX array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by CGEGS.
-*> ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of
-*> the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] ALPHA2
-*> \verbatim
-*> ALPHA2 is COMPLEX array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA2
-*> \verbatim
-*> BETA2 is COMPLEX array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by CGEGV.
-*> ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of
-*> the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] VL
-*> \verbatim
-*> VL is COMPLEX array, dimension (LDQ, max(NN))
-*> The (lower triangular) left eigenvector matrix for the
-*> matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] VR
-*> \verbatim
-*> VR is COMPLEX array, dimension (LDQ, max(NN))
-*> The (upper triangular) right eigenvector matrix for the
-*> matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is COMPLEX array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The number of entries in WORK. This must be at least
-*> MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the
-*> sum of the blocksize and number-of-shifts for CHGEQZ, and
-*> NB is the greatest of the blocksizes for CGEQRF, CUNMQR,
-*> and CUNGQR. (The blocksizes and the number-of-shifts are
-*> retrieved through calls to ILAENV.)
-*> \endverbatim
-*>
-*> \param[out] RWORK
-*> \verbatim
-*> RWORK is REAL array, dimension (8*N)
-*> \endverbatim
-*>
-*> \param[out] RESULT
-*> \verbatim
-*> RESULT is REAL array, dimension (7)
-*> The values computed by the tests described above.
-*> The values are currently limited to 1/ulp, to avoid
-*> overflow.
-*> \endverbatim
-*>
-*> \param[out] INFO
-*> \verbatim
-*> INFO is INTEGER
-*> = 0: successful exit
-*> < 0: if INFO = -i, the i-th argument had an illegal value.
-*> > 0: A routine returned an error code. INFO is the
-*> absolute value of the INFO value returned.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup complex_eig
-*
-* =====================================================================
- SUBROUTINE CDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
- $ LDQ, Z, ALPHA1, BETA1, ALPHA2, BETA2, VL, VR,
- $ WORK, LWORK, RWORK, RESULT, INFO )
-*
-* -- LAPACK test 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 ..
- INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
- REAL THRESH, THRSHN
-* ..
-* .. Array Arguments ..
-*
-* =====================================================================
-*
- LOGICAL DOTYPE( * )
- INTEGER ISEED( 4 ), NN( * )
- REAL RESULT( * ), RWORK( * )
- COMPLEX A( LDA, * ), ALPHA1( * ), ALPHA2( * ),
- $ B( LDA, * ), BETA1( * ), BETA2( * ),
- $ Q( LDQ, * ), S( LDA, * ), S2( LDA, * ),
- $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
- $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
-* ..
-* .. Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
- COMPLEX CZERO, CONE
- PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
- $ CONE = ( 1.0E+0, 0.0E+0 ) )
- INTEGER MAXTYP
- PARAMETER ( MAXTYP = 26 )
-* ..
-* .. Local Scalars ..
- LOGICAL BADNN
- INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
- $ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
- $ NMAX, NS, NTEST, NTESTT
- REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
- COMPLEX CTEMP, X
-* ..
-* .. Local Arrays ..
- LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
- INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
- $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
- $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
- $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
- $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
- REAL DUMMA( 4 ), RMAGN( 0: 3 )
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- REAL SLAMCH
- COMPLEX CLARND
- EXTERNAL ILAENV, SLAMCH, CLARND
-* ..
-* .. External Subroutines ..
- EXTERNAL ALASVM, CGEGS, CGEGV, CGET51, CGET52, CLACPY,
- $ CLARFG, CLASET, CLATM4, CUNM2R, SLABAD, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SIGN
-* ..
-* .. Statement Functions ..
- REAL ABS1
-* ..
-* .. Statement Function definitions ..
- ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
-* ..
-* .. Data statements ..
- DATA KCLASS / 15*1, 10*2, 1*3 /
- DATA KZ1 / 0, 1, 2, 1, 3, 3 /
- DATA KZ2 / 0, 0, 1, 2, 1, 1 /
- DATA KADD / 0, 0, 0, 0, 3, 2 /
- DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
- $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
- DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
- $ 1, 1, -4, 2, -4, 8*8, 0 /
- DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
- $ 4*5, 4*3, 1 /
- DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
- $ 4*6, 4*4, 1 /
- DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
- $ 2, 1 /
- DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
- $ 2, 1 /
- DATA KTRIAN / 16*0, 10*1 /
- DATA LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE.,
- $ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE.,
- $ 3*.FALSE., 5*.TRUE., .FALSE. /
- DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE.,
- $ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE.,
- $ 9*.FALSE. /
-* ..
-* .. Executable Statements ..
-*
-* Check for errors
-*
- INFO = 0
-*
- BADNN = .FALSE.
- NMAX = 1
- DO 10 J = 1, NSIZES
- NMAX = MAX( NMAX, NN( J ) )
- IF( NN( J ).LT.0 )
- $ BADNN = .TRUE.
- 10 CONTINUE
-*
-* Maximum blocksize and shift -- we assume that blocksize and number
-* of shifts are monotone increasing functions of N.
-*
- NB = MAX( 1, ILAENV( 1, 'CGEQRF', ' ', NMAX, NMAX, -1, -1 ),
- $ ILAENV( 1, 'CUNMQR', 'LC', NMAX, NMAX, NMAX, -1 ),
- $ ILAENV( 1, 'CUNGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
- NBZ = ILAENV( 1, 'CHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- NS = ILAENV( 4, 'CHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- I1 = NBZ + NS
- LWKOPT = MAX( 2*NMAX, NMAX*( NB+1 ), ( 2*I1+NMAX+1 )*( I1+1 ) )
-*
-* Check for errors
-*
- IF( NSIZES.LT.0 ) THEN
- INFO = -1
- ELSE IF( BADNN ) THEN
- INFO = -2
- ELSE IF( NTYPES.LT.0 ) THEN
- INFO = -3
- ELSE IF( THRESH.LT.ZERO ) THEN
- INFO = -6
- ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
- INFO = -10
- ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
- INFO = -19
- ELSE IF( LWKOPT.GT.LWORK ) THEN
- INFO = -30
- END IF
-*
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'CDRVGG', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
- $ RETURN
-*
- ULP = SLAMCH( 'Precision' )
- SAFMIN = SLAMCH( 'Safe minimum' )
- SAFMIN = SAFMIN / ULP
- SAFMAX = ONE / SAFMIN
- CALL SLABAD( SAFMIN, SAFMAX )
- ULPINV = ONE / ULP
-*
-* The values RMAGN(2:3) depend on N, see below.
-*
- RMAGN( 0 ) = ZERO
- RMAGN( 1 ) = ONE
-*
-* Loop over sizes, types
-*
- NTESTT = 0
- NERRS = 0
- NMATS = 0
-*
- DO 160 JSIZE = 1, NSIZES
- N = NN( JSIZE )
- N1 = MAX( 1, N )
- RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
- RMAGN( 3 ) = SAFMIN*ULPINV*N1
-*
- IF( NSIZES.NE.1 ) THEN
- MTYPES = MIN( MAXTYP, NTYPES )
- ELSE
- MTYPES = MIN( MAXTYP+1, NTYPES )
- END IF
-*
- DO 150 JTYPE = 1, MTYPES
- IF( .NOT.DOTYPE( JTYPE ) )
- $ GO TO 150
- NMATS = NMATS + 1
- NTEST = 0
-*
-* Save ISEED in case of an error.
-*
- DO 20 J = 1, 4
- IOLDSD( J ) = ISEED( J )
- 20 CONTINUE
-*
-* Initialize RESULT
-*
- DO 30 J = 1, 7
- RESULT( J ) = ZERO
- 30 CONTINUE
-*
-* Compute A and B
-*
-* Description of control parameters:
-*
-* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
-* =3 means random.
-* KATYPE: the "type" to be passed to CLATM4 for computing A.
-* KAZERO: the pattern of zeros on the diagonal for A:
-* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
-* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
-* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
-* non-zero entries.)
-* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
-* =2: large, =3: small.
-* LASIGN: .TRUE. if the diagonal elements of A are to be
-* multiplied by a random magnitude 1 number.
-* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
-* KTRIAN: =0: don't fill in the upper triangle, =1: do.
-* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
-* RMAGN: used to implement KAMAGN and KBMAGN.
-*
- IF( MTYPES.GT.MAXTYP )
- $ GO TO 110
- IINFO = 0
- IF( KCLASS( JTYPE ).LT.3 ) THEN
-*
-* Generate A (w/o rotation)
-*
- IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL CLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
- ELSE
- IN = N
- END IF
- CALL CLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
- $ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ),
- $ RMAGN( KAMAGN( JTYPE ) ), ULP,
- $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
- $ ISEED, A, LDA )
- IADD = KADD( KAZERO( JTYPE ) )
- IF( IADD.GT.0 .AND. IADD.LE.N )
- $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) )
-*
-* Generate B (w/o rotation)
-*
- IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL CLASET( 'Full', N, N, CZERO, CZERO, B, LDA )
- ELSE
- IN = N
- END IF
- CALL CLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
- $ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ),
- $ RMAGN( KBMAGN( JTYPE ) ), ONE,
- $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
- $ ISEED, B, LDA )
- IADD = KADD( KBZERO( JTYPE ) )
- IF( IADD.NE.0 .AND. IADD.LE.N )
- $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) )
-*
- IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
-*
-* Include rotations
-*
-* Generate Q, Z as Householder transformations times
-* a diagonal matrix.
-*
- DO 50 JC = 1, N - 1
- DO 40 JR = JC, N
- Q( JR, JC ) = CLARND( 3, ISEED )
- Z( JR, JC ) = CLARND( 3, ISEED )
- 40 CONTINUE
- CALL CLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
- $ WORK( JC ) )
- WORK( 2*N+JC ) = SIGN( ONE, REAL( Q( JC, JC ) ) )
- Q( JC, JC ) = CONE
- CALL CLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
- $ WORK( N+JC ) )
- WORK( 3*N+JC ) = SIGN( ONE, REAL( Z( JC, JC ) ) )
- Z( JC, JC ) = CONE
- 50 CONTINUE
- CTEMP = CLARND( 3, ISEED )
- Q( N, N ) = CONE
- WORK( N ) = CZERO
- WORK( 3*N ) = CTEMP / ABS( CTEMP )
- CTEMP = CLARND( 3, ISEED )
- Z( N, N ) = CONE
- WORK( 2*N ) = CZERO
- WORK( 4*N ) = CTEMP / ABS( CTEMP )
-*
-* Apply the diagonal matrices
-*
- DO 70 JC = 1, N
- DO 60 JR = 1, N
- A( JR, JC ) = WORK( 2*N+JR )*
- $ CONJG( WORK( 3*N+JC ) )*
- $ A( JR, JC )
- B( JR, JC ) = WORK( 2*N+JR )*
- $ CONJG( WORK( 3*N+JC ) )*
- $ B( JR, JC )
- 60 CONTINUE
- 70 CONTINUE
- CALL CUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL CUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ A, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL CUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL CUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ B, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- END IF
- ELSE
-*
-* Random matrices
-*
- DO 90 JC = 1, N
- DO 80 JR = 1, N
- A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
- $ CLARND( 4, ISEED )
- B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
- $ CLARND( 4, ISEED )
- 80 CONTINUE
- 90 CONTINUE
- END IF
-*
- 100 CONTINUE
-*
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- RETURN
- END IF
-*
- 110 CONTINUE
-*
-* Call CGEGS to compute H, T, Q, Z, alpha, and beta.
-*
- CALL CLACPY( ' ', N, N, A, LDA, S, LDA )
- CALL CLACPY( ' ', N, N, B, LDA, T, LDA )
- NTEST = 1
- RESULT( 1 ) = ULPINV
-*
- CALL CGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHA1, BETA1, Q,
- $ LDQ, Z, LDQ, WORK, LWORK, RWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'CGEGS', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 130
- END IF
-*
- NTEST = 4
-*
-* Do tests 1--4
-*
- CALL CGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RWORK, RESULT( 1 ) )
- CALL CGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RWORK, RESULT( 2 ) )
- CALL CGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
- $ RWORK, RESULT( 3 ) )
- CALL CGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
- $ RWORK, RESULT( 4 ) )
-*
-* Do test 5: compare eigenvalues with diagonals.
-*
- TEMP1 = ZERO
-*
- DO 120 J = 1, N
- TEMP2 = ( ABS1( ALPHA1( J )-S( J, J ) ) /
- $ MAX( SAFMIN, ABS1( ALPHA1( J ) ), ABS1( S( J,
- $ J ) ) )+ABS1( BETA1( J )-T( J, J ) ) /
- $ MAX( SAFMIN, ABS1( BETA1( J ) ), ABS1( T( J,
- $ J ) ) ) ) / ULP
- TEMP1 = MAX( TEMP1, TEMP2 )
- 120 CONTINUE
- RESULT( 5 ) = TEMP1
-*
-* Call CGEGV to compute S2, T2, VL, and VR, do tests.
-*
-* Eigenvalues and Eigenvectors
-*
- CALL CLACPY( ' ', N, N, A, LDA, S2, LDA )
- CALL CLACPY( ' ', N, N, B, LDA, T2, LDA )
- NTEST = 6
- RESULT( 6 ) = ULPINV
-*
- CALL CGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHA2, BETA2,
- $ VL, LDQ, VR, LDQ, WORK, LWORK, RWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'CGEGV', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 130
- END IF
-*
- NTEST = 7
-*
-* Do Tests 6 and 7
-*
- CALL CGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHA2,
- $ BETA2, WORK, RWORK, DUMMA( 1 ) )
- RESULT( 6 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRSHN ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Left', 'CGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
- CALL CGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHA2,
- $ BETA2, WORK, RWORK, DUMMA( 1 ) )
- RESULT( 7 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRESH ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Right', 'CGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
-* End of Loop -- Check for RESULT(j) > THRESH
-*
- 130 CONTINUE
-*
- NTESTT = NTESTT + NTEST
-*
-* Print out tests which fail.
-*
- DO 140 JR = 1, NTEST
- IF( RESULT( JR ).GE.THRESH ) THEN
-*
-* If this is the first test to fail,
-* print a header to the data file.
-*
- IF( NERRS.EQ.0 ) THEN
- WRITE( NOUNIT, FMT = 9997 )'CGG'
-*
-* Matrix types
-*
- WRITE( NOUNIT, FMT = 9996 )
- WRITE( NOUNIT, FMT = 9995 )
- WRITE( NOUNIT, FMT = 9994 )'Unitary'
-*
-* Tests performed
-*
- WRITE( NOUNIT, FMT = 9993 )'unitary', '*',
- $ 'conjugate transpose', ( '*', J = 1, 5 )
-*
- END IF
- NERRS = NERRS + 1
- IF( RESULT( JR ).LT.10000.0 ) THEN
- WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- ELSE
- WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- END IF
- END IF
- 140 CONTINUE
-*
- 150 CONTINUE
- 160 CONTINUE
-*
-* Summary
-*
- CALL ALASVM( 'CGG', NOUNIT, NERRS, NTESTT, 0 )
- RETURN
-*
- 9999 FORMAT( ' CDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
- $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
-*
- 9998 FORMAT( ' CDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
- $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
- $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
- $ ')' )
-*
- 9997 FORMAT( / 1X, A3,
- $ ' -- Complex Generalized eigenvalue problem driver' )
-*
- 9996 FORMAT( ' Matrix types (see CDRVGG for details): ' )
-*
- 9995 FORMAT( ' Special Matrices:', 23X,
- $ '(J''=transposed Jordan block)',
- $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
- $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
- $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
- $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
- $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
- $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
- 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
- $ / ' 16=Transposed Jordan Blocks 19=geometric ',
- $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
- $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
- $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
- $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
- $ '23=(small,large) 24=(small,small) 25=(large,large)',
- $ / ' 26=random O(1) matrices.' )
-*
- 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
- $ 'Q and Z are ', A, ',', / 20X,
- $ 'l and r are the appropriate left and right', / 19X,
- $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
- $ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
- $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
- $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
- $ ' | / ( n ulp ) 4 = | I - ZZ', A,
- $ ' | / ( n ulp )', /
- $ ' 5 = difference between (alpha,beta) and diagonals of',
- $ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
- $ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
- $ / 1X )
- 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
- 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 1P, E10.3 )
-*
-* End of CDRVGG
-*
- END
*>
*> DGG (Generalized Nonsymmetric Eigenvalue Problem):
*> Test DGGHD3, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC
-*> and the driver routines DGEGS and DGEGV
*>
*> DGS (Generalized Nonsymmetric Schur form Driver):
*> Test DGGES
*> DVX 21 DDRVVX
*> DSX 21 DDRVSX
*> DGG 26 DCHKGG (routines)
-*> 26 DDRVGG (drivers)
*> DGS 26 DDRGES
*> DGX 5 DDRGSX
*> DGV 26 DDRGEV
$ DCHKGG, DCHKGK, DCHKGL, DCHKHS, DCHKSB, DCHKST,
$ DCKCSD, DCKGLM, DCKGQR, DCKGSV, DCKLSE, DDRGES,
$ DDRGEV, DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV,
- $ DDRVGG, DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD,
+ $ DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD,
$ DERRED, DERRGG, DERRHS, DERRST, ILAVER, XLAENV,
$ DDRGES3, DDRGEV3
* ..
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKGG', INFO
END IF
- CALL XLAENV( 1, 1 )
- IF( TSTDRV ) THEN
- CALL DDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
- $ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
- $ A( 1, 7 ), NMAX, A( 1, 8 ), D( 1, 1 ),
- $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
- $ D( 1, 6 ), A( 1, 13 ), A( 1, 14 ), WORK,
- $ LWORK, RESULT, INFO )
- IF( INFO.NE.0 )
- $ WRITE( NOUT, FMT = 9980 )'DDRVGG', INFO
- END IF
350 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'DGS' ) ) THEN
+++ /dev/null
-*> \brief \b DDRVGG
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE DDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
-* THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
-* LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
-* BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
-*
-* .. Scalar Arguments ..
-* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
-* DOUBLE PRECISION THRESH, THRSHN
-* ..
-* .. Array Arguments ..
-* LOGICAL DOTYPE( * )
-* INTEGER ISEED( 4 ), NN( * )
-* DOUBLE PRECISION A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
-* $ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
-* $ BETA1( * ), BETA2( * ), Q( LDQ, * ),
-* $ RESULT( * ), S( LDA, * ), S2( LDA, * ),
-* $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
-* $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> DDRVGG checks the nonsymmetric generalized eigenvalue driver
-*> routines.
-*> T T T
-*> DGEGS factors A and B as Q S Z and Q T Z , where means
-*> transpose, T is upper triangular, S is in generalized Schur form
-*> (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
-*> the 2x2 blocks corresponding to complex conjugate pairs of
-*> generalized eigenvalues), and Q and Z are orthogonal. It also
-*> computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) --
-*> thus, w(j) = alpha(j)/beta(j) is a root of the generalized
-*> eigenvalue problem
-*>
-*> det( A - w(j) B ) = 0
-*>
-*> and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
-*> problem
-*>
-*> det( m(j) A - B ) = 0
-*>
-*> DGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), the matrix L whose columns contain the
-*> generalized left eigenvectors l, and the matrix R whose columns
-*> contain the generalized right eigenvectors r for the pair (A,B).
-*>
-*> When DDRVGG is called, a number of matrix "sizes" ("n's") and a
-*> number of matrix "types" are specified. For each size ("n")
-*> and each type of matrix, one matrix will be generated and used
-*> to test the nonsymmetric eigenroutines. For each matrix, 7
-*> tests will be performed and compared with the threshhold THRESH:
-*>
-*> Results from DGEGS:
-*>
-*> T
-*> (1) | A - Q S Z | / ( |A| n ulp )
-*>
-*> T
-*> (2) | B - Q T Z | / ( |B| n ulp )
-*>
-*> T
-*> (3) | I - QQ | / ( n ulp )
-*>
-*> T
-*> (4) | I - ZZ | / ( n ulp )
-*>
-*> (5) maximum over j of D(j) where:
-*>
-*> if alpha(j) is real:
-*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
-*> D(j) = ------------------------ + -----------------------
-*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
-*>
-*> if alpha(j) is complex:
-*> | det( s S - w T ) |
-*> D(j) = ---------------------------------------------------
-*> ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
-*>
-*> and S and T are here the 2 x 2 diagonal blocks of S and T
-*> corresponding to the j-th eigenvalue.
-*>
-*> Results from DGEGV:
-*>
-*> (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
-*>
-*> | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> where l**H is the conjugate tranpose of l.
-*>
-*> (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
-*>
-*> | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> Test Matrices
-*> ---- --------
-*>
-*> The sizes of the test matrices are specified by an array
-*> NN(1:NSIZES); the value of each element NN(j) specifies one size.
-*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
-*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
-*> Currently, the list of possible types is:
-*>
-*> (1) ( 0, 0 ) (a pair of zero matrices)
-*>
-*> (2) ( I, 0 ) (an identity and a zero matrix)
-*>
-*> (3) ( 0, I ) (an identity and a zero matrix)
-*>
-*> (4) ( I, I ) (a pair of identity matrices)
-*>
-*> t t
-*> (5) ( J , J ) (a pair of transposed Jordan blocks)
-*>
-*> t ( I 0 )
-*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
-*> ( 0 I ) ( 0 J )
-*> and I is a k x k identity and J a (k+1)x(k+1)
-*> Jordan block; k=(N-1)/2
-*>
-*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
-*> matrix with those diagonal entries.)
-*> (8) ( I, D )
-*>
-*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
-*>
-*> (10) ( small*D, big*I )
-*>
-*> (11) ( big*I, small*D )
-*>
-*> (12) ( small*I, big*D )
-*>
-*> (13) ( big*D, big*I )
-*>
-*> (14) ( small*D, small*I )
-*>
-*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
-*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
-*> t t
-*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
-*>
-*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
-*> with random O(1) entries above the diagonal
-*> and diagonal entries diag(T1) =
-*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
-*> ( 0, N-3, N-4,..., 1, 0, 0 )
-*>
-*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
-*> s = machine precision.
-*>
-*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
-*>
-*> N-5
-*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*>
-*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*> where r1,..., r(N-4) are random.
-*>
-*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
-*> matrices.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] NSIZES
-*> \verbatim
-*> NSIZES is INTEGER
-*> The number of sizes of matrices to use. If it is zero,
-*> DDRVGG does nothing. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] NN
-*> \verbatim
-*> NN is INTEGER array, dimension (NSIZES)
-*> An array containing the sizes to be used for the matrices.
-*> Zero values will be skipped. The values must be at least
-*> zero.
-*> \endverbatim
-*>
-*> \param[in] NTYPES
-*> \verbatim
-*> NTYPES is INTEGER
-*> The number of elements in DOTYPE. If it is zero, DDRVGG
-*> does nothing. It must be at least zero. If it is MAXTYP+1
-*> and NSIZES is 1, then an additional type, MAXTYP+1 is
-*> defined, which is to use whatever matrix is in A. This
-*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
-*> DOTYPE(MAXTYP+1) is .TRUE. .
-*> \endverbatim
-*>
-*> \param[in] DOTYPE
-*> \verbatim
-*> DOTYPE is LOGICAL array, dimension (NTYPES)
-*> If DOTYPE(j) is .TRUE., then for each size in NN a
-*> matrix of that size and of type j will be generated.
-*> If NTYPES is smaller than the maximum number of types
-*> defined (PARAMETER MAXTYP), then types NTYPES+1 through
-*> MAXTYP will not be generated. If NTYPES is larger
-*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
-*> will be ignored.
-*> \endverbatim
-*>
-*> \param[in,out] ISEED
-*> \verbatim
-*> ISEED is INTEGER array, dimension (4)
-*> On entry ISEED specifies the seed of the random number
-*> generator. The array elements should be between 0 and 4095;
-*> if not they will be reduced mod 4096. Also, ISEED(4) must
-*> be odd. The random number generator uses a linear
-*> congruential sequence limited to small integers, and so
-*> should produce machine independent random numbers. The
-*> values of ISEED are changed on exit, and can be used in the
-*> next call to DDRVGG to continue the same random number
-*> sequence.
-*> \endverbatim
-*>
-*> \param[in] THRESH
-*> \verbatim
-*> THRESH is DOUBLE PRECISION
-*> A test will count as "failed" if the "error", computed as
-*> described above, exceeds THRESH. Note that the error is
-*> scaled to be O(1), so THRESH should be a reasonably small
-*> multiple of 1, e.g., 10 or 100. In particular, it should
-*> not depend on the precision (single vs. double) or the size
-*> of the matrix. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] THRSHN
-*> \verbatim
-*> THRSHN is DOUBLE PRECISION
-*> Threshhold for reporting eigenvector normalization error.
-*> If the normalization of any eigenvector differs from 1 by
-*> more than THRSHN*ulp, then a special error message will be
-*> printed. (This is handled separately from the other tests,
-*> since only a compiler or programming error should cause an
-*> error message, at least if THRSHN is at least 5--10.)
-*> \endverbatim
-*>
-*> \param[in] NOUNIT
-*> \verbatim
-*> NOUNIT is INTEGER
-*> The FORTRAN unit number for printing out error messages
-*> (e.g., if a routine returns IINFO not equal to 0.)
-*> \endverbatim
-*>
-*> \param[in,out] A
-*> \verbatim
-*> A is DOUBLE PRECISION array, dimension
-*> (LDA, max(NN))
-*> Used to hold the original A matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of A, B, S, T, S2, and T2.
-*> It must be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is DOUBLE PRECISION array, dimension
-*> (LDA, max(NN))
-*> Used to hold the original B matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[out] S
-*> \verbatim
-*> S is DOUBLE PRECISION array, dimension (LDA, max(NN))
-*> The Schur form matrix computed from A by DGEGS. On exit, S
-*> contains the Schur form matrix corresponding to the matrix
-*> in A.
-*> \endverbatim
-*>
-*> \param[out] T
-*> \verbatim
-*> T is DOUBLE PRECISION array, dimension (LDA, max(NN))
-*> The upper triangular matrix computed from B by DGEGS.
-*> \endverbatim
-*>
-*> \param[out] S2
-*> \verbatim
-*> S2 is DOUBLE PRECISION array, dimension (LDA, max(NN))
-*> The matrix computed from A by DGEGV. This will be the
-*> Schur form of some matrix related to A, but will not, in
-*> general, be the same as S.
-*> \endverbatim
-*>
-*> \param[out] T2
-*> \verbatim
-*> T2 is DOUBLE PRECISION array, dimension (LDA, max(NN))
-*> The matrix computed from B by DGEGV. This will be the
-*> Schur form of some matrix related to B, but will not, in
-*> general, be the same as T.
-*> \endverbatim
-*>
-*> \param[out] Q
-*> \verbatim
-*> Q is DOUBLE PRECISION array, dimension (LDQ, max(NN))
-*> The (left) orthogonal matrix computed by DGEGS.
-*> \endverbatim
-*>
-*> \param[in] LDQ
-*> \verbatim
-*> LDQ is INTEGER
-*> The leading dimension of Q, Z, VL, and VR. It must
-*> be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[out] Z
-*> \verbatim
-*> Z is DOUBLE PRECISION array of
-*> dimension( LDQ, max(NN) )
-*> The (right) orthogonal matrix computed by DGEGS.
-*> \endverbatim
-*>
-*> \param[out] ALPHR1
-*> \verbatim
-*> ALPHR1 is DOUBLE PRECISION array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] ALPHI1
-*> \verbatim
-*> ALPHI1 is DOUBLE PRECISION array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA1
-*> \verbatim
-*> BETA1 is DOUBLE PRECISION array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by DGEGS.
-*> ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
-*> generalized eigenvalue of the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] ALPHR2
-*> \verbatim
-*> ALPHR2 is DOUBLE PRECISION array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] ALPHI2
-*> \verbatim
-*> ALPHI2 is DOUBLE PRECISION array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA2
-*> \verbatim
-*> BETA2 is DOUBLE PRECISION array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by DGEGV.
-*> ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th
-*> generalized eigenvalue of the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] VL
-*> \verbatim
-*> VL is DOUBLE PRECISION array, dimension (LDQ, max(NN))
-*> The (block lower triangular) left eigenvector matrix for
-*> the matrices in A and B. (See DTGEVC for the format.)
-*> \endverbatim
-*>
-*> \param[out] VR
-*> \verbatim
-*> VR is DOUBLE PRECISION array, dimension (LDQ, max(NN))
-*> The (block upper triangular) right eigenvector matrix for
-*> the matrices in A and B. (See DTGEVC for the format.)
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is DOUBLE PRECISION array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The number of entries in WORK. This must be at least
-*> 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where
-*> "k" is the sum of the blocksize and number-of-shifts for
-*> DHGEQZ, and NB is the greatest of the blocksizes for
-*> DGEQRF, DORMQR, and DORGQR. (The blocksizes and the
-*> number-of-shifts are retrieved through calls to ILAENV.)
-*> \endverbatim
-*>
-*> \param[out] RESULT
-*> \verbatim
-*> RESULT is DOUBLE PRECISION array, dimension (15)
-*> The values computed by the tests described above.
-*> The values are currently limited to 1/ulp, to avoid
-*> overflow.
-*> \endverbatim
-*>
-*> \param[out] INFO
-*> \verbatim
-*> INFO is INTEGER
-*> = 0: successful exit
-*> < 0: if INFO = -i, the i-th argument had an illegal value.
-*> > 0: A routine returned an error code. INFO is the
-*> absolute value of the INFO value returned.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup double_eig
-*
-* =====================================================================
- SUBROUTINE DDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
- $ LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
- $ BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
-*
-* -- LAPACK test 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 ..
- INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
- DOUBLE PRECISION THRESH, THRSHN
-* ..
-* .. Array Arguments ..
- LOGICAL DOTYPE( * )
- INTEGER ISEED( 4 ), NN( * )
- DOUBLE PRECISION A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
- $ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
- $ BETA1( * ), BETA2( * ), Q( LDQ, * ),
- $ RESULT( * ), S( LDA, * ), S2( LDA, * ),
- $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
- $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
- INTEGER MAXTYP
- PARAMETER ( MAXTYP = 26 )
-* ..
-* .. Local Scalars ..
- LOGICAL BADNN, ILABAD
- INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
- $ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
- $ NMAX, NS, NTEST, NTESTT
- DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
-* ..
-* .. Local Arrays ..
- INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
- $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
- $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
- $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
- $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
- $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
- DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- DOUBLE PRECISION DLAMCH, DLARND
- EXTERNAL ILAENV, DLAMCH, DLARND
-* ..
-* .. External Subroutines ..
- EXTERNAL ALASVM, DGEGS, DGEGV, DGET51, DGET52, DGET53,
- $ DLABAD, DLACPY, DLARFG, DLASET, DLATM4, DORM2R,
- $ XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, DBLE, MAX, MIN, SIGN
-* ..
-* .. Data statements ..
- DATA KCLASS / 15*1, 10*2, 1*3 /
- DATA KZ1 / 0, 1, 2, 1, 3, 3 /
- DATA KZ2 / 0, 0, 1, 2, 1, 1 /
- DATA KADD / 0, 0, 0, 0, 3, 2 /
- DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
- $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
- DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
- $ 1, 1, -4, 2, -4, 8*8, 0 /
- DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
- $ 4*5, 4*3, 1 /
- DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
- $ 4*6, 4*4, 1 /
- DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
- $ 2, 1 /
- DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
- $ 2, 1 /
- DATA KTRIAN / 16*0, 10*1 /
- DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
- $ 5*2, 0 /
- DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
-* ..
-* .. Executable Statements ..
-*
-* Check for errors
-*
- INFO = 0
-*
- BADNN = .FALSE.
- NMAX = 1
- DO 10 J = 1, NSIZES
- NMAX = MAX( NMAX, NN( J ) )
- IF( NN( J ).LT.0 )
- $ BADNN = .TRUE.
- 10 CONTINUE
-*
-* Maximum blocksize and shift -- we assume that blocksize and number
-* of shifts are monotone increasing functions of N.
-*
- NB = MAX( 1, ILAENV( 1, 'DGEQRF', ' ', NMAX, NMAX, -1, -1 ),
- $ ILAENV( 1, 'DORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
- $ ILAENV( 1, 'DORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
- NBZ = ILAENV( 1, 'DHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- NS = ILAENV( 4, 'DHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- I1 = NBZ + NS
- LWKOPT = 2*NMAX + MAX( 6*NMAX, NMAX*( NB+1 ),
- $ ( 2*I1+NMAX+1 )*( I1+1 ) )
-*
-* Check for errors
-*
- IF( NSIZES.LT.0 ) THEN
- INFO = -1
- ELSE IF( BADNN ) THEN
- INFO = -2
- ELSE IF( NTYPES.LT.0 ) THEN
- INFO = -3
- ELSE IF( THRESH.LT.ZERO ) THEN
- INFO = -6
- ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
- INFO = -10
- ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
- INFO = -19
- ELSE IF( LWKOPT.GT.LWORK ) THEN
- INFO = -30
- END IF
-*
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'DDRVGG', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
- $ RETURN
-*
- SAFMIN = DLAMCH( 'Safe minimum' )
- ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
- SAFMIN = SAFMIN / ULP
- SAFMAX = ONE / SAFMIN
- CALL DLABAD( SAFMIN, SAFMAX )
- ULPINV = ONE / ULP
-*
-* The values RMAGN(2:3) depend on N, see below.
-*
- RMAGN( 0 ) = ZERO
- RMAGN( 1 ) = ONE
-*
-* Loop over sizes, types
-*
- NTESTT = 0
- NERRS = 0
- NMATS = 0
-*
- DO 170 JSIZE = 1, NSIZES
- N = NN( JSIZE )
- N1 = MAX( 1, N )
- RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
- RMAGN( 3 ) = SAFMIN*ULPINV*N1
-*
- IF( NSIZES.NE.1 ) THEN
- MTYPES = MIN( MAXTYP, NTYPES )
- ELSE
- MTYPES = MIN( MAXTYP+1, NTYPES )
- END IF
-*
- DO 160 JTYPE = 1, MTYPES
- IF( .NOT.DOTYPE( JTYPE ) )
- $ GO TO 160
- NMATS = NMATS + 1
- NTEST = 0
-*
-* Save ISEED in case of an error.
-*
- DO 20 J = 1, 4
- IOLDSD( J ) = ISEED( J )
- 20 CONTINUE
-*
-* Initialize RESULT
-*
- DO 30 J = 1, 15
- RESULT( J ) = ZERO
- 30 CONTINUE
-*
-* Compute A and B
-*
-* Description of control parameters:
-*
-* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
-* =3 means random.
-* KATYPE: the "type" to be passed to DLATM4 for computing A.
-* KAZERO: the pattern of zeros on the diagonal for A:
-* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
-* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
-* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
-* non-zero entries.)
-* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
-* =2: large, =3: small.
-* IASIGN: 1 if the diagonal elements of A are to be
-* multiplied by a random magnitude 1 number, =2 if
-* randomly chosen diagonal blocks are to be rotated
-* to form 2x2 blocks.
-* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
-* KTRIAN: =0: don't fill in the upper triangle, =1: do.
-* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
-* RMAGN: used to implement KAMAGN and KBMAGN.
-*
- IF( MTYPES.GT.MAXTYP )
- $ GO TO 110
- IINFO = 0
- IF( KCLASS( JTYPE ).LT.3 ) THEN
-*
-* Generate A (w/o rotation)
-*
- IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
- ELSE
- IN = N
- END IF
- CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
- $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
- $ RMAGN( KAMAGN( JTYPE ) ), ULP,
- $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
- $ ISEED, A, LDA )
- IADD = KADD( KAZERO( JTYPE ) )
- IF( IADD.GT.0 .AND. IADD.LE.N )
- $ A( IADD, IADD ) = ONE
-*
-* Generate B (w/o rotation)
-*
- IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
- ELSE
- IN = N
- END IF
- CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
- $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
- $ RMAGN( KBMAGN( JTYPE ) ), ONE,
- $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
- $ ISEED, B, LDA )
- IADD = KADD( KBZERO( JTYPE ) )
- IF( IADD.NE.0 .AND. IADD.LE.N )
- $ B( IADD, IADD ) = ONE
-*
- IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
-*
-* Include rotations
-*
-* Generate Q, Z as Householder transformations times
-* a diagonal matrix.
-*
- DO 50 JC = 1, N - 1
- DO 40 JR = JC, N
- Q( JR, JC ) = DLARND( 3, ISEED )
- Z( JR, JC ) = DLARND( 3, ISEED )
- 40 CONTINUE
- CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
- $ WORK( JC ) )
- WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
- Q( JC, JC ) = ONE
- CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
- $ WORK( N+JC ) )
- WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
- Z( JC, JC ) = ONE
- 50 CONTINUE
- Q( N, N ) = ONE
- WORK( N ) = ZERO
- WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
- Z( N, N ) = ONE
- WORK( 2*N ) = ZERO
- WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
-*
-* Apply the diagonal matrices
-*
- DO 70 JC = 1, N
- DO 60 JR = 1, N
- A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
- $ A( JR, JC )
- B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
- $ B( JR, JC )
- 60 CONTINUE
- 70 CONTINUE
- CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ A, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ B, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- END IF
- ELSE
-*
-* Random matrices
-*
- DO 90 JC = 1, N
- DO 80 JR = 1, N
- A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
- $ DLARND( 2, ISEED )
- B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
- $ DLARND( 2, ISEED )
- 80 CONTINUE
- 90 CONTINUE
- END IF
-*
- 100 CONTINUE
-*
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- RETURN
- END IF
-*
- 110 CONTINUE
-*
-* Call DGEGS to compute H, T, Q, Z, alpha, and beta.
-*
- CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
- CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
- NTEST = 1
- RESULT( 1 ) = ULPINV
-*
- CALL DGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
- $ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'DGEGS', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 140
- END IF
-*
- NTEST = 4
-*
-* Do tests 1--4
-*
- CALL DGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RESULT( 1 ) )
- CALL DGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RESULT( 2 ) )
- CALL DGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
- $ RESULT( 3 ) )
- CALL DGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
- $ RESULT( 4 ) )
-*
-* Do test 5: compare eigenvalues with diagonals.
-* Also check Schur form of A.
-*
- TEMP1 = ZERO
-*
- DO 120 J = 1, N
- ILABAD = .FALSE.
- IF( ALPHI1( J ).EQ.ZERO ) THEN
- TEMP2 = ( ABS( ALPHR1( J )-S( J, J ) ) /
- $ MAX( SAFMIN, ABS( ALPHR1( J ) ), ABS( S( J,
- $ J ) ) )+ABS( BETA1( J )-T( J, J ) ) /
- $ MAX( SAFMIN, ABS( BETA1( J ) ), ABS( T( J,
- $ J ) ) ) ) / ULP
- IF( J.LT.N ) THEN
- IF( S( J+1, J ).NE.ZERO )
- $ ILABAD = .TRUE.
- END IF
- IF( J.GT.1 ) THEN
- IF( S( J, J-1 ).NE.ZERO )
- $ ILABAD = .TRUE.
- END IF
- ELSE
- IF( ALPHI1( J ).GT.ZERO ) THEN
- I1 = J
- ELSE
- I1 = J - 1
- END IF
- IF( I1.LE.0 .OR. I1.GE.N ) THEN
- ILABAD = .TRUE.
- ELSE IF( I1.LT.N-1 ) THEN
- IF( S( I1+2, I1+1 ).NE.ZERO )
- $ ILABAD = .TRUE.
- ELSE IF( I1.GT.1 ) THEN
- IF( S( I1, I1-1 ).NE.ZERO )
- $ ILABAD = .TRUE.
- END IF
- IF( .NOT.ILABAD ) THEN
- CALL DGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
- $ BETA1( J ), ALPHR1( J ), ALPHI1( J ),
- $ TEMP2, IINFO )
- IF( IINFO.GE.3 ) THEN
- WRITE( NOUNIT, FMT = 9997 )IINFO, J, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- END IF
- ELSE
- TEMP2 = ULPINV
- END IF
- END IF
- TEMP1 = MAX( TEMP1, TEMP2 )
- IF( ILABAD ) THEN
- WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
- END IF
- 120 CONTINUE
- RESULT( 5 ) = TEMP1
-*
-* Call DGEGV to compute S2, T2, VL, and VR, do tests.
-*
-* Eigenvalues and Eigenvectors
-*
- CALL DLACPY( ' ', N, N, A, LDA, S2, LDA )
- CALL DLACPY( ' ', N, N, B, LDA, T2, LDA )
- NTEST = 6
- RESULT( 6 ) = ULPINV
-*
- CALL DGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHR2, ALPHI2,
- $ BETA2, VL, LDQ, VR, LDQ, WORK, LWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'DGEGV', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 140
- END IF
-*
- NTEST = 7
-*
-* Do Tests 6 and 7
-*
- CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHR2,
- $ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
- RESULT( 6 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRSHN ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Left', 'DGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
- CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHR2,
- $ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
- RESULT( 7 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRESH ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Right', 'DGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
-* Check form of Complex eigenvalues.
-*
- DO 130 J = 1, N
- ILABAD = .FALSE.
- IF( ALPHI2( J ).GT.ZERO ) THEN
- IF( J.EQ.N ) THEN
- ILABAD = .TRUE.
- ELSE IF( ALPHI2( J+1 ).GE.ZERO ) THEN
- ILABAD = .TRUE.
- END IF
- ELSE IF( ALPHI2( J ).LT.ZERO ) THEN
- IF( J.EQ.1 ) THEN
- ILABAD = .TRUE.
- ELSE IF( ALPHI2( J-1 ).LE.ZERO ) THEN
- ILABAD = .TRUE.
- END IF
- END IF
- IF( ILABAD ) THEN
- WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
- END IF
- 130 CONTINUE
-*
-* End of Loop -- Check for RESULT(j) > THRESH
-*
- 140 CONTINUE
-*
- NTESTT = NTESTT + NTEST
-*
-* Print out tests which fail.
-*
- DO 150 JR = 1, NTEST
- IF( RESULT( JR ).GE.THRESH ) THEN
-*
-* If this is the first test to fail,
-* print a header to the data file.
-*
- IF( NERRS.EQ.0 ) THEN
- WRITE( NOUNIT, FMT = 9995 )'DGG'
-*
-* Matrix types
-*
- WRITE( NOUNIT, FMT = 9994 )
- WRITE( NOUNIT, FMT = 9993 )
- WRITE( NOUNIT, FMT = 9992 )'Orthogonal'
-*
-* Tests performed
-*
- WRITE( NOUNIT, FMT = 9991 )'orthogonal', '''',
- $ 'transpose', ( '''', J = 1, 5 )
-*
- END IF
- NERRS = NERRS + 1
- IF( RESULT( JR ).LT.10000.0D0 ) THEN
- WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- ELSE
- WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- END IF
- END IF
- 150 CONTINUE
-*
- 160 CONTINUE
- 170 CONTINUE
-*
-* Summary
-*
- CALL ALASVM( 'DGG', NOUNIT, NERRS, NTESTT, 0 )
- RETURN
-*
- 9999 FORMAT( ' DDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
- $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
-*
- 9998 FORMAT( ' DDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
- $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
- $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
- $ ')' )
-*
- 9997 FORMAT( ' DDRVGG: DGET53 returned INFO=', I1, ' for eigenvalue ',
- $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
- $ 3( I5, ',' ), I5, ')' )
-*
- 9996 FORMAT( ' DDRVGG: S not in Schur form at eigenvalue ', I6, '.',
- $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
- $ I5, ')' )
-*
- 9995 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
- $ )
-*
- 9994 FORMAT( ' Matrix types (see DDRVGG for details): ' )
-*
- 9993 FORMAT( ' Special Matrices:', 23X,
- $ '(J''=transposed Jordan block)',
- $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
- $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
- $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
- $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
- $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
- $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
- 9992 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
- $ / ' 16=Transposed Jordan Blocks 19=geometric ',
- $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
- $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
- $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
- $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
- $ '23=(small,large) 24=(small,small) 25=(large,large)',
- $ / ' 26=random O(1) matrices.' )
-*
- 9991 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
- $ 'Q and Z are ', A, ',', / 20X,
- $ 'l and r are the appropriate left and right', / 19X,
- $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
- $ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
- $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
- $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
- $ ' | / ( n ulp ) 4 = | I - ZZ', A,
- $ ' | / ( n ulp )', /
- $ ' 5 = difference between (alpha,beta) and diagonals of',
- $ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
- $ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
- $ / 1X )
- 9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
- 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 1P, D10.3 )
-*
-* End of DDRVGG
-*
- END
*>
*> SGG (Generalized Nonsymmetric Eigenvalue Problem):
*> Test SGGHD3, SGGBAL, SGGBAK, SHGEQZ, and STGEVC
-*> and the driver routines SGEGS and SGEGV
*>
*> SGS (Generalized Nonsymmetric Schur form Driver):
*> Test SGGES
*> SVX 21 SDRVVX
*> SSX 21 SDRVSX
*> SGG 26 SCHKGG (routines)
-*> 26 SDRVGG (drivers)
*> SGS 26 SDRGES
*> SGX 5 SDRGSX
*> SGV 26 SDRGEV
$ SCHKGG, SCHKGK, SCHKGL, SCHKHS, SCHKSB, SCHKST,
$ SCKCSD, SCKGLM, SCKGQR, SCKGSV, SCKLSE, SDRGES,
$ SDRGEV, SDRGSX, SDRGVX, SDRVBD, SDRVES, SDRVEV,
- $ SDRVGG, SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD,
+ $ SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD,
$ SERRED, SERRGG, SERRHS, SERRST, ILAVER, XLAENV,
$ SDRGES3, SDRGEV3
* ..
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKGG', INFO
END IF
- CALL XLAENV( 1, 1 )
- IF( TSTDRV ) THEN
- CALL SDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
- $ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
- $ A( 1, 7 ), NMAX, A( 1, 8 ), D( 1, 1 ),
- $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
- $ D( 1, 6 ), A( 1, 13 ), A( 1, 14 ), WORK,
- $ LWORK, RESULT, INFO )
- IF( INFO.NE.0 )
- $ WRITE( NOUT, FMT = 9980 )'SDRVGG', INFO
- END IF
350 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'SGS' ) ) THEN
+++ /dev/null
-*> \brief \b SDRVGG
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE SDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
-* THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
-* LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
-* BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
-*
-* .. Scalar Arguments ..
-* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
-* REAL THRESH, THRSHN
-* ..
-* .. Array Arguments ..
-* LOGICAL DOTYPE( * )
-* INTEGER ISEED( 4 ), NN( * )
-* REAL A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
-* $ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
-* $ BETA1( * ), BETA2( * ), Q( LDQ, * ),
-* $ RESULT( * ), S( LDA, * ), S2( LDA, * ),
-* $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
-* $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> SDRVGG checks the nonsymmetric generalized eigenvalue driver
-*> routines.
-*> T T T
-*> SGEGS factors A and B as Q S Z and Q T Z , where means
-*> transpose, T is upper triangular, S is in generalized Schur form
-*> (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
-*> the 2x2 blocks corresponding to complex conjugate pairs of
-*> generalized eigenvalues), and Q and Z are orthogonal. It also
-*> computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) --
-*> thus, w(j) = alpha(j)/beta(j) is a root of the generalized
-*> eigenvalue problem
-*>
-*> det( A - w(j) B ) = 0
-*>
-*> and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
-*> problem
-*>
-*> det( m(j) A - B ) = 0
-*>
-*> SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), the matrix L whose columns contain the
-*> generalized left eigenvectors l, and the matrix R whose columns
-*> contain the generalized right eigenvectors r for the pair (A,B).
-*>
-*> When SDRVGG is called, a number of matrix "sizes" ("n's") and a
-*> number of matrix "types" are specified. For each size ("n")
-*> and each type of matrix, one matrix will be generated and used
-*> to test the nonsymmetric eigenroutines. For each matrix, 7
-*> tests will be performed and compared with the threshhold THRESH:
-*>
-*> Results from SGEGS:
-*>
-*> T
-*> (1) | A - Q S Z | / ( |A| n ulp )
-*>
-*> T
-*> (2) | B - Q T Z | / ( |B| n ulp )
-*>
-*> T
-*> (3) | I - QQ | / ( n ulp )
-*>
-*> T
-*> (4) | I - ZZ | / ( n ulp )
-*>
-*> (5) maximum over j of D(j) where:
-*>
-*> if alpha(j) is real:
-*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
-*> D(j) = ------------------------ + -----------------------
-*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
-*>
-*> if alpha(j) is complex:
-*> | det( s S - w T ) |
-*> D(j) = ---------------------------------------------------
-*> ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
-*>
-*> and S and T are here the 2 x 2 diagonal blocks of S and T
-*> corresponding to the j-th eigenvalue.
-*>
-*> Results from SGEGV:
-*>
-*> (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
-*>
-*> | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> where l**H is the conjugate tranpose of l.
-*>
-*> (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
-*>
-*> | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> Test Matrices
-*> ---- --------
-*>
-*> The sizes of the test matrices are specified by an array
-*> NN(1:NSIZES); the value of each element NN(j) specifies one size.
-*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
-*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
-*> Currently, the list of possible types is:
-*>
-*> (1) ( 0, 0 ) (a pair of zero matrices)
-*>
-*> (2) ( I, 0 ) (an identity and a zero matrix)
-*>
-*> (3) ( 0, I ) (an identity and a zero matrix)
-*>
-*> (4) ( I, I ) (a pair of identity matrices)
-*>
-*> t t
-*> (5) ( J , J ) (a pair of transposed Jordan blocks)
-*>
-*> t ( I 0 )
-*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
-*> ( 0 I ) ( 0 J )
-*> and I is a k x k identity and J a (k+1)x(k+1)
-*> Jordan block; k=(N-1)/2
-*>
-*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
-*> matrix with those diagonal entries.)
-*> (8) ( I, D )
-*>
-*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
-*>
-*> (10) ( small*D, big*I )
-*>
-*> (11) ( big*I, small*D )
-*>
-*> (12) ( small*I, big*D )
-*>
-*> (13) ( big*D, big*I )
-*>
-*> (14) ( small*D, small*I )
-*>
-*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
-*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
-*> t t
-*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
-*>
-*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
-*> with random O(1) entries above the diagonal
-*> and diagonal entries diag(T1) =
-*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
-*> ( 0, N-3, N-4,..., 1, 0, 0 )
-*>
-*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
-*> s = machine precision.
-*>
-*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
-*>
-*> N-5
-*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*>
-*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*> where r1,..., r(N-4) are random.
-*>
-*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
-*> matrices.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] NSIZES
-*> \verbatim
-*> NSIZES is INTEGER
-*> The number of sizes of matrices to use. If it is zero,
-*> SDRVGG does nothing. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] NN
-*> \verbatim
-*> NN is INTEGER array, dimension (NSIZES)
-*> An array containing the sizes to be used for the matrices.
-*> Zero values will be skipped. The values must be at least
-*> zero.
-*> \endverbatim
-*>
-*> \param[in] NTYPES
-*> \verbatim
-*> NTYPES is INTEGER
-*> The number of elements in DOTYPE. If it is zero, SDRVGG
-*> does nothing. It must be at least zero. If it is MAXTYP+1
-*> and NSIZES is 1, then an additional type, MAXTYP+1 is
-*> defined, which is to use whatever matrix is in A. This
-*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
-*> DOTYPE(MAXTYP+1) is .TRUE. .
-*> \endverbatim
-*>
-*> \param[in] DOTYPE
-*> \verbatim
-*> DOTYPE is LOGICAL array, dimension (NTYPES)
-*> If DOTYPE(j) is .TRUE., then for each size in NN a
-*> matrix of that size and of type j will be generated.
-*> If NTYPES is smaller than the maximum number of types
-*> defined (PARAMETER MAXTYP), then types NTYPES+1 through
-*> MAXTYP will not be generated. If NTYPES is larger
-*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
-*> will be ignored.
-*> \endverbatim
-*>
-*> \param[in,out] ISEED
-*> \verbatim
-*> ISEED is INTEGER array, dimension (4)
-*> On entry ISEED specifies the seed of the random number
-*> generator. The array elements should be between 0 and 4095;
-*> if not they will be reduced mod 4096. Also, ISEED(4) must
-*> be odd. The random number generator uses a linear
-*> congruential sequence limited to small integers, and so
-*> should produce machine independent random numbers. The
-*> values of ISEED are changed on exit, and can be used in the
-*> next call to SDRVGG to continue the same random number
-*> sequence.
-*> \endverbatim
-*>
-*> \param[in] THRESH
-*> \verbatim
-*> THRESH is REAL
-*> A test will count as "failed" if the "error", computed as
-*> described above, exceeds THRESH. Note that the error is
-*> scaled to be O(1), so THRESH should be a reasonably small
-*> multiple of 1, e.g., 10 or 100. In particular, it should
-*> not depend on the precision (single vs. double) or the size
-*> of the matrix. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] THRSHN
-*> \verbatim
-*> THRSHN is REAL
-*> Threshhold for reporting eigenvector normalization error.
-*> If the normalization of any eigenvector differs from 1 by
-*> more than THRSHN*ulp, then a special error message will be
-*> printed. (This is handled separately from the other tests,
-*> since only a compiler or programming error should cause an
-*> error message, at least if THRSHN is at least 5--10.)
-*> \endverbatim
-*>
-*> \param[in] NOUNIT
-*> \verbatim
-*> NOUNIT is INTEGER
-*> The FORTRAN unit number for printing out error messages
-*> (e.g., if a routine returns IINFO not equal to 0.)
-*> \endverbatim
-*>
-*> \param[in,out] A
-*> \verbatim
-*> A is REAL array, dimension
-*> (LDA, max(NN))
-*> Used to hold the original A matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of A, B, S, T, S2, and T2.
-*> It must be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is REAL array, dimension
-*> (LDA, max(NN))
-*> Used to hold the original B matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[out] S
-*> \verbatim
-*> S is REAL array, dimension (LDA, max(NN))
-*> The Schur form matrix computed from A by SGEGS. On exit, S
-*> contains the Schur form matrix corresponding to the matrix
-*> in A.
-*> \endverbatim
-*>
-*> \param[out] T
-*> \verbatim
-*> T is REAL array, dimension (LDA, max(NN))
-*> The upper triangular matrix computed from B by SGEGS.
-*> \endverbatim
-*>
-*> \param[out] S2
-*> \verbatim
-*> S2 is REAL array, dimension (LDA, max(NN))
-*> The matrix computed from A by SGEGV. This will be the
-*> Schur form of some matrix related to A, but will not, in
-*> general, be the same as S.
-*> \endverbatim
-*>
-*> \param[out] T2
-*> \verbatim
-*> T2 is REAL array, dimension (LDA, max(NN))
-*> The matrix computed from B by SGEGV. This will be the
-*> Schur form of some matrix related to B, but will not, in
-*> general, be the same as T.
-*> \endverbatim
-*>
-*> \param[out] Q
-*> \verbatim
-*> Q is REAL array, dimension (LDQ, max(NN))
-*> The (left) orthogonal matrix computed by SGEGS.
-*> \endverbatim
-*>
-*> \param[in] LDQ
-*> \verbatim
-*> LDQ is INTEGER
-*> The leading dimension of Q, Z, VL, and VR. It must
-*> be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[out] Z
-*> \verbatim
-*> Z is REAL array of
-*> dimension( LDQ, max(NN) )
-*> The (right) orthogonal matrix computed by SGEGS.
-*> \endverbatim
-*>
-*> \param[out] ALPHR1
-*> \verbatim
-*> ALPHR1 is REAL array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] ALPHI1
-*> \verbatim
-*> ALPHI1 is REAL array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA1
-*> \verbatim
-*> BETA1 is REAL array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by SGEGS.
-*> ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
-*> generalized eigenvalue of the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] ALPHR2
-*> \verbatim
-*> ALPHR2 is REAL array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] ALPHI2
-*> \verbatim
-*> ALPHI2 is REAL array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA2
-*> \verbatim
-*> BETA2 is REAL array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by SGEGV.
-*> ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th
-*> generalized eigenvalue of the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] VL
-*> \verbatim
-*> VL is REAL array, dimension (LDQ, max(NN))
-*> The (block lower triangular) left eigenvector matrix for
-*> the matrices in A and B. (See STGEVC for the format.)
-*> \endverbatim
-*>
-*> \param[out] VR
-*> \verbatim
-*> VR is REAL array, dimension (LDQ, max(NN))
-*> The (block upper triangular) right eigenvector matrix for
-*> the matrices in A and B. (See STGEVC for the format.)
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is REAL array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The number of entries in WORK. This must be at least
-*> 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where
-*> "k" is the sum of the blocksize and number-of-shifts for
-*> SHGEQZ, and NB is the greatest of the blocksizes for
-*> SGEQRF, SORMQR, and SORGQR. (The blocksizes and the
-*> number-of-shifts are retrieved through calls to ILAENV.)
-*> \endverbatim
-*>
-*> \param[out] RESULT
-*> \verbatim
-*> RESULT is REAL array, dimension (15)
-*> The values computed by the tests described above.
-*> The values are currently limited to 1/ulp, to avoid
-*> overflow.
-*> \endverbatim
-*>
-*> \param[out] INFO
-*> \verbatim
-*> INFO is INTEGER
-*> = 0: successful exit
-*> < 0: if INFO = -i, the i-th argument had an illegal value.
-*> > 0: A routine returned an error code. INFO is the
-*> absolute value of the INFO value returned.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup single_eig
-*
-* =====================================================================
- SUBROUTINE SDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
- $ LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
- $ BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
-*
-* -- LAPACK test 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 ..
- INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
- REAL THRESH, THRSHN
-* ..
-* .. Array Arguments ..
- LOGICAL DOTYPE( * )
- INTEGER ISEED( 4 ), NN( * )
- REAL A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
- $ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
- $ BETA1( * ), BETA2( * ), Q( LDQ, * ),
- $ RESULT( * ), S( LDA, * ), S2( LDA, * ),
- $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
- $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0, ONE = 1.0 )
- INTEGER MAXTYP
- PARAMETER ( MAXTYP = 26 )
-* ..
-* .. Local Scalars ..
- LOGICAL BADNN, ILABAD
- INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
- $ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
- $ NMAX, NS, NTEST, NTESTT
- REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
-* ..
-* .. Local Arrays ..
- INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
- $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
- $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
- $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
- $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
- $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
- REAL DUMMA( 4 ), RMAGN( 0: 3 )
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- REAL SLAMCH, SLARND
- EXTERNAL ILAENV, SLAMCH, SLARND
-* ..
-* .. External Subroutines ..
- EXTERNAL ALASVM, SGEGS, SGEGV, SGET51, SGET52, SGET53,
- $ SLABAD, SLACPY, SLARFG, SLASET, SLATM4, SORM2R,
- $ XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, MAX, MIN, REAL, SIGN
-* ..
-* .. Data statements ..
- DATA KCLASS / 15*1, 10*2, 1*3 /
- DATA KZ1 / 0, 1, 2, 1, 3, 3 /
- DATA KZ2 / 0, 0, 1, 2, 1, 1 /
- DATA KADD / 0, 0, 0, 0, 3, 2 /
- DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
- $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
- DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
- $ 1, 1, -4, 2, -4, 8*8, 0 /
- DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
- $ 4*5, 4*3, 1 /
- DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
- $ 4*6, 4*4, 1 /
- DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
- $ 2, 1 /
- DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
- $ 2, 1 /
- DATA KTRIAN / 16*0, 10*1 /
- DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
- $ 5*2, 0 /
- DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
-* ..
-* .. Executable Statements ..
-*
-* Check for errors
-*
- INFO = 0
-*
- BADNN = .FALSE.
- NMAX = 1
- DO 10 J = 1, NSIZES
- NMAX = MAX( NMAX, NN( J ) )
- IF( NN( J ).LT.0 )
- $ BADNN = .TRUE.
- 10 CONTINUE
-*
-* Maximum blocksize and shift -- we assume that blocksize and number
-* of shifts are monotone increasing functions of N.
-*
- NB = MAX( 1, ILAENV( 1, 'SGEQRF', ' ', NMAX, NMAX, -1, -1 ),
- $ ILAENV( 1, 'SORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
- $ ILAENV( 1, 'SORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
- NBZ = ILAENV( 1, 'SHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- NS = ILAENV( 4, 'SHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- I1 = NBZ + NS
- LWKOPT = 2*NMAX + MAX( 6*NMAX, NMAX*( NB+1 ),
- $ ( 2*I1+NMAX+1 )*( I1+1 ) )
-*
-* Check for errors
-*
- IF( NSIZES.LT.0 ) THEN
- INFO = -1
- ELSE IF( BADNN ) THEN
- INFO = -2
- ELSE IF( NTYPES.LT.0 ) THEN
- INFO = -3
- ELSE IF( THRESH.LT.ZERO ) THEN
- INFO = -6
- ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
- INFO = -10
- ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
- INFO = -19
- ELSE IF( LWKOPT.GT.LWORK ) THEN
- INFO = -30
- END IF
-*
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'SDRVGG', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
- $ RETURN
-*
- SAFMIN = SLAMCH( 'Safe minimum' )
- ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
- SAFMIN = SAFMIN / ULP
- SAFMAX = ONE / SAFMIN
- CALL SLABAD( SAFMIN, SAFMAX )
- ULPINV = ONE / ULP
-*
-* The values RMAGN(2:3) depend on N, see below.
-*
- RMAGN( 0 ) = ZERO
- RMAGN( 1 ) = ONE
-*
-* Loop over sizes, types
-*
- NTESTT = 0
- NERRS = 0
- NMATS = 0
-*
- DO 170 JSIZE = 1, NSIZES
- N = NN( JSIZE )
- N1 = MAX( 1, N )
- RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
- RMAGN( 3 ) = SAFMIN*ULPINV*N1
-*
- IF( NSIZES.NE.1 ) THEN
- MTYPES = MIN( MAXTYP, NTYPES )
- ELSE
- MTYPES = MIN( MAXTYP+1, NTYPES )
- END IF
-*
- DO 160 JTYPE = 1, MTYPES
- IF( .NOT.DOTYPE( JTYPE ) )
- $ GO TO 160
- NMATS = NMATS + 1
- NTEST = 0
-*
-* Save ISEED in case of an error.
-*
- DO 20 J = 1, 4
- IOLDSD( J ) = ISEED( J )
- 20 CONTINUE
-*
-* Initialize RESULT
-*
- DO 30 J = 1, 15
- RESULT( J ) = ZERO
- 30 CONTINUE
-*
-* Compute A and B
-*
-* Description of control parameters:
-*
-* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
-* =3 means random.
-* KATYPE: the "type" to be passed to SLATM4 for computing A.
-* KAZERO: the pattern of zeros on the diagonal for A:
-* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
-* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
-* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
-* non-zero entries.)
-* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
-* =2: large, =3: small.
-* IASIGN: 1 if the diagonal elements of A are to be
-* multiplied by a random magnitude 1 number, =2 if
-* randomly chosen diagonal blocks are to be rotated
-* to form 2x2 blocks.
-* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
-* KTRIAN: =0: don't fill in the upper triangle, =1: do.
-* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
-* RMAGN: used to implement KAMAGN and KBMAGN.
-*
- IF( MTYPES.GT.MAXTYP )
- $ GO TO 110
- IINFO = 0
- IF( KCLASS( JTYPE ).LT.3 ) THEN
-*
-* Generate A (w/o rotation)
-*
- IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
- ELSE
- IN = N
- END IF
- CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
- $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
- $ RMAGN( KAMAGN( JTYPE ) ), ULP,
- $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
- $ ISEED, A, LDA )
- IADD = KADD( KAZERO( JTYPE ) )
- IF( IADD.GT.0 .AND. IADD.LE.N )
- $ A( IADD, IADD ) = ONE
-*
-* Generate B (w/o rotation)
-*
- IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
- ELSE
- IN = N
- END IF
- CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
- $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
- $ RMAGN( KBMAGN( JTYPE ) ), ONE,
- $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
- $ ISEED, B, LDA )
- IADD = KADD( KBZERO( JTYPE ) )
- IF( IADD.NE.0 .AND. IADD.LE.N )
- $ B( IADD, IADD ) = ONE
-*
- IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
-*
-* Include rotations
-*
-* Generate Q, Z as Householder transformations times
-* a diagonal matrix.
-*
- DO 50 JC = 1, N - 1
- DO 40 JR = JC, N
- Q( JR, JC ) = SLARND( 3, ISEED )
- Z( JR, JC ) = SLARND( 3, ISEED )
- 40 CONTINUE
- CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
- $ WORK( JC ) )
- WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
- Q( JC, JC ) = ONE
- CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
- $ WORK( N+JC ) )
- WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
- Z( JC, JC ) = ONE
- 50 CONTINUE
- Q( N, N ) = ONE
- WORK( N ) = ZERO
- WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
- Z( N, N ) = ONE
- WORK( 2*N ) = ZERO
- WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
-*
-* Apply the diagonal matrices
-*
- DO 70 JC = 1, N
- DO 60 JR = 1, N
- A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
- $ A( JR, JC )
- B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
- $ B( JR, JC )
- 60 CONTINUE
- 70 CONTINUE
- CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ A, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ B, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- END IF
- ELSE
-*
-* Random matrices
-*
- DO 90 JC = 1, N
- DO 80 JR = 1, N
- A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
- $ SLARND( 2, ISEED )
- B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
- $ SLARND( 2, ISEED )
- 80 CONTINUE
- 90 CONTINUE
- END IF
-*
- 100 CONTINUE
-*
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- RETURN
- END IF
-*
- 110 CONTINUE
-*
-* Call SGEGS to compute H, T, Q, Z, alpha, and beta.
-*
- CALL SLACPY( ' ', N, N, A, LDA, S, LDA )
- CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
- NTEST = 1
- RESULT( 1 ) = ULPINV
-*
- CALL SGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
- $ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'SGEGS', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 140
- END IF
-*
- NTEST = 4
-*
-* Do tests 1--4
-*
- CALL SGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RESULT( 1 ) )
- CALL SGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RESULT( 2 ) )
- CALL SGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
- $ RESULT( 3 ) )
- CALL SGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
- $ RESULT( 4 ) )
-*
-* Do test 5: compare eigenvalues with diagonals.
-* Also check Schur form of A.
-*
- TEMP1 = ZERO
-*
- DO 120 J = 1, N
- ILABAD = .FALSE.
- IF( ALPHI1( J ).EQ.ZERO ) THEN
- TEMP2 = ( ABS( ALPHR1( J )-S( J, J ) ) /
- $ MAX( SAFMIN, ABS( ALPHR1( J ) ), ABS( S( J,
- $ J ) ) )+ABS( BETA1( J )-T( J, J ) ) /
- $ MAX( SAFMIN, ABS( BETA1( J ) ), ABS( T( J,
- $ J ) ) ) ) / ULP
- IF( J.LT.N ) THEN
- IF( S( J+1, J ).NE.ZERO )
- $ ILABAD = .TRUE.
- END IF
- IF( J.GT.1 ) THEN
- IF( S( J, J-1 ).NE.ZERO )
- $ ILABAD = .TRUE.
- END IF
- ELSE
- IF( ALPHI1( J ).GT.ZERO ) THEN
- I1 = J
- ELSE
- I1 = J - 1
- END IF
- IF( I1.LE.0 .OR. I1.GE.N ) THEN
- ILABAD = .TRUE.
- ELSE IF( I1.LT.N-1 ) THEN
- IF( S( I1+2, I1+1 ).NE.ZERO )
- $ ILABAD = .TRUE.
- ELSE IF( I1.GT.1 ) THEN
- IF( S( I1, I1-1 ).NE.ZERO )
- $ ILABAD = .TRUE.
- END IF
- IF( .NOT.ILABAD ) THEN
- CALL SGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
- $ BETA1( J ), ALPHR1( J ), ALPHI1( J ),
- $ TEMP2, IINFO )
- IF( IINFO.GE.3 ) THEN
- WRITE( NOUNIT, FMT = 9997 )IINFO, J, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- END IF
- ELSE
- TEMP2 = ULPINV
- END IF
- END IF
- TEMP1 = MAX( TEMP1, TEMP2 )
- IF( ILABAD ) THEN
- WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
- END IF
- 120 CONTINUE
- RESULT( 5 ) = TEMP1
-*
-* Call SGEGV to compute S2, T2, VL, and VR, do tests.
-*
-* Eigenvalues and Eigenvectors
-*
- CALL SLACPY( ' ', N, N, A, LDA, S2, LDA )
- CALL SLACPY( ' ', N, N, B, LDA, T2, LDA )
- NTEST = 6
- RESULT( 6 ) = ULPINV
-*
- CALL SGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHR2, ALPHI2,
- $ BETA2, VL, LDQ, VR, LDQ, WORK, LWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'SGEGV', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 140
- END IF
-*
- NTEST = 7
-*
-* Do Tests 6 and 7
-*
- CALL SGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHR2,
- $ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
- RESULT( 6 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRSHN ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Left', 'SGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
- CALL SGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHR2,
- $ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
- RESULT( 7 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRESH ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Right', 'SGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
-* Check form of Complex eigenvalues.
-*
- DO 130 J = 1, N
- ILABAD = .FALSE.
- IF( ALPHI2( J ).GT.ZERO ) THEN
- IF( J.EQ.N ) THEN
- ILABAD = .TRUE.
- ELSE IF( ALPHI2( J+1 ).GE.ZERO ) THEN
- ILABAD = .TRUE.
- END IF
- ELSE IF( ALPHI2( J ).LT.ZERO ) THEN
- IF( J.EQ.1 ) THEN
- ILABAD = .TRUE.
- ELSE IF( ALPHI2( J-1 ).LE.ZERO ) THEN
- ILABAD = .TRUE.
- END IF
- END IF
- IF( ILABAD ) THEN
- WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
- END IF
- 130 CONTINUE
-*
-* End of Loop -- Check for RESULT(j) > THRESH
-*
- 140 CONTINUE
-*
- NTESTT = NTESTT + NTEST
-*
-* Print out tests which fail.
-*
- DO 150 JR = 1, NTEST
- IF( RESULT( JR ).GE.THRESH ) THEN
-*
-* If this is the first test to fail,
-* print a header to the data file.
-*
- IF( NERRS.EQ.0 ) THEN
- WRITE( NOUNIT, FMT = 9995 )'SGG'
-*
-* Matrix types
-*
- WRITE( NOUNIT, FMT = 9994 )
- WRITE( NOUNIT, FMT = 9993 )
- WRITE( NOUNIT, FMT = 9992 )'Orthogonal'
-*
-* Tests performed
-*
- WRITE( NOUNIT, FMT = 9991 )'orthogonal', '''',
- $ 'transpose', ( '''', J = 1, 5 )
-*
- END IF
- NERRS = NERRS + 1
- IF( RESULT( JR ).LT.10000.0 ) THEN
- WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- ELSE
- WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- END IF
- END IF
- 150 CONTINUE
-*
- 160 CONTINUE
- 170 CONTINUE
-*
-* Summary
-*
- CALL ALASVM( 'SGG', NOUNIT, NERRS, NTESTT, 0 )
- RETURN
-*
- 9999 FORMAT( ' SDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
- $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
-*
- 9998 FORMAT( ' SDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
- $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
- $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
- $ ')' )
-*
- 9997 FORMAT( ' SDRVGG: SGET53 returned INFO=', I1, ' for eigenvalue ',
- $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
- $ 3( I5, ',' ), I5, ')' )
-*
- 9996 FORMAT( ' SDRVGG: S not in Schur form at eigenvalue ', I6, '.',
- $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
- $ I5, ')' )
-*
- 9995 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
- $ )
-*
- 9994 FORMAT( ' Matrix types (see SDRVGG for details): ' )
-*
- 9993 FORMAT( ' Special Matrices:', 23X,
- $ '(J''=transposed Jordan block)',
- $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
- $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
- $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
- $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
- $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
- $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
- 9992 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
- $ / ' 16=Transposed Jordan Blocks 19=geometric ',
- $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
- $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
- $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
- $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
- $ '23=(small,large) 24=(small,small) 25=(large,large)',
- $ / ' 26=random O(1) matrices.' )
-*
- 9991 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
- $ 'Q and Z are ', A, ',', / 20X,
- $ 'l and r are the appropriate left and right', / 19X,
- $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
- $ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
- $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
- $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
- $ ' | / ( n ulp ) 4 = | I - ZZ', A,
- $ ' | / ( n ulp )', /
- $ ' 5 = difference between (alpha,beta) and diagonals of',
- $ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
- $ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
- $ / 1X )
- 9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
- 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 1P, E10.3 )
-*
-* End of SDRVGG
-*
- END
*>
*> ZGG (Generalized Nonsymmetric Eigenvalue Problem):
*> Test ZGGHD3, ZGGBAL, ZGGBAK, ZHGEQZ, and ZTGEVC
-*> and the driver routines ZGEGS and ZGEGV
*>
*> ZGS (Generalized Nonsymmetric Schur form Driver):
*> Test ZGGES
*> ZVX 21 ZDRVVX
*> ZSX 21 ZDRVSX
*> ZGG 26 ZCHKGG (routines)
-*> 26 ZDRVGG (drivers)
*> ZGS 26 ZDRGES
*> ZGX 5 ZDRGSX
*> ZGV 26 ZDRGEV
$ ZCHKEC, ZCHKGG, ZCHKGK, ZCHKGL, ZCHKHB, ZCHKHS,
$ ZCHKST, ZCKCSD, ZCKGLM, ZCKGQR, ZCKGSV, ZCKLSE,
$ ZDRGES, ZDRGEV, ZDRGSX, ZDRGVX, ZDRVBD, ZDRVES,
- $ ZDRVEV, ZDRVGG, ZDRVSG, ZDRVST, ZDRVSX, ZDRVVX,
+ $ ZDRVEV, ZDRVSG, ZDRVST, ZDRVSX, ZDRVVX,
$ ZERRBD, ZERRED, ZERRGG, ZERRHS, ZERRST, ILAVER,
$ ZDRGES3, ZDRGEV3
* ..
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'ZCHKGG', INFO
END IF
- CALL XLAENV( 1, 1 )
- IF( TSTDRV ) THEN
- CALL ZDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
- $ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
- $ A( 1, 7 ), NMAX, A( 1, 8 ), DC( 1, 1 ),
- $ DC( 1, 2 ), DC( 1, 3 ), DC( 1, 4 ),
- $ A( 1, 8 ), A( 1, 9 ), WORK, LWORK, RWORK,
- $ RESULT, INFO )
- IF( INFO.NE.0 )
- $ WRITE( NOUT, FMT = 9980 )'ZDRVGG', INFO
- END IF
350 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'ZGS' ) ) THEN
+++ /dev/null
-*> \brief \b ZDRVGG
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE ZDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
-* THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
-* LDQ, Z, ALPHA1, BETA1, ALPHA2, BETA2, VL, VR,
-* WORK, LWORK, RWORK, RESULT, INFO )
-*
-* .. Scalar Arguments ..
-* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
-* DOUBLE PRECISION THRESH, THRSHN
-* ..
-* .. Array Arguments ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> ZDRVGG checks the nonsymmetric generalized eigenvalue driver
-*> routines.
-*> T T T
-*> ZGEGS factors A and B as Q S Z and Q T Z , where means
-*> transpose, T is upper triangular, S is in generalized Schur form
-*> (upper triangular), and Q and Z are unitary. It also
-*> computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) --
-*> thus, w(j) = alpha(j)/beta(j) is a root of the generalized
-*> eigenvalue problem
-*>
-*> det( A - w(j) B ) = 0
-*>
-*> and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
-*> problem
-*>
-*> det( m(j) A - B ) = 0
-*>
-*> ZGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
-*> (alpha(n),beta(n)), the matrix L whose columns contain the
-*> generalized left eigenvectors l, and the matrix R whose columns
-*> contain the generalized right eigenvectors r for the pair (A,B).
-*>
-*> When ZDRVGG is called, a number of matrix "sizes" ("n's") and a
-*> number of matrix "types" are specified. For each size ("n")
-*> and each type of matrix, one matrix will be generated and used
-*> to test the nonsymmetric eigenroutines. For each matrix, 7
-*> tests will be performed and compared with the threshhold THRESH:
-*>
-*> Results from ZGEGS:
-*>
-*> H
-*> (1) | A - Q S Z | / ( |A| n ulp )
-*>
-*> H
-*> (2) | B - Q T Z | / ( |B| n ulp )
-*>
-*> H
-*> (3) | I - QQ | / ( n ulp )
-*>
-*> H
-*> (4) | I - ZZ | / ( n ulp )
-*>
-*> (5) maximum over j of D(j) where:
-*>
-*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
-*> D(j) = ------------------------ + -----------------------
-*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
-*>
-*> Results from ZGEGV:
-*>
-*> (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
-*>
-*> | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> where l**H is the conjugate tranpose of l.
-*>
-*> (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
-*>
-*> | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
-*>
-*> Test Matrices
-*> ---- --------
-*>
-*> The sizes of the test matrices are specified by an array
-*> NN(1:NSIZES); the value of each element NN(j) specifies one size.
-*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
-*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
-*> Currently, the list of possible types is:
-*>
-*> (1) ( 0, 0 ) (a pair of zero matrices)
-*>
-*> (2) ( I, 0 ) (an identity and a zero matrix)
-*>
-*> (3) ( 0, I ) (an identity and a zero matrix)
-*>
-*> (4) ( I, I ) (a pair of identity matrices)
-*>
-*> t t
-*> (5) ( J , J ) (a pair of transposed Jordan blocks)
-*>
-*> t ( I 0 )
-*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
-*> ( 0 I ) ( 0 J )
-*> and I is a k x k identity and J a (k+1)x(k+1)
-*> Jordan block; k=(N-1)/2
-*>
-*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
-*> matrix with those diagonal entries.)
-*> (8) ( I, D )
-*>
-*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
-*>
-*> (10) ( small*D, big*I )
-*>
-*> (11) ( big*I, small*D )
-*>
-*> (12) ( small*I, big*D )
-*>
-*> (13) ( big*D, big*I )
-*>
-*> (14) ( small*D, small*I )
-*>
-*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
-*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
-*> t t
-*> (16) Q ( J , J ) Z where Q and Z are random unitary matrices.
-*>
-*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
-*> with random O(1) entries above the diagonal
-*> and diagonal entries diag(T1) =
-*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
-*> ( 0, N-3, N-4,..., 1, 0, 0 )
-*>
-*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
-*> s = machine precision.
-*>
-*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
-*>
-*> N-5
-*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*>
-*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
-*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
-*> where r1,..., r(N-4) are random.
-*>
-*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
-*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
-*>
-*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
-*> matrices.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] NSIZES
-*> \verbatim
-*> NSIZES is INTEGER
-*> The number of sizes of matrices to use. If it is zero,
-*> ZDRVGG does nothing. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] NN
-*> \verbatim
-*> NN is INTEGER array, dimension (NSIZES)
-*> An array containing the sizes to be used for the matrices.
-*> Zero values will be skipped. The values must be at least
-*> zero.
-*> \endverbatim
-*>
-*> \param[in] NTYPES
-*> \verbatim
-*> NTYPES is INTEGER
-*> The number of elements in DOTYPE. If it is zero, ZDRVGG
-*> does nothing. It must be at least zero. If it is MAXTYP+1
-*> and NSIZES is 1, then an additional type, MAXTYP+1 is
-*> defined, which is to use whatever matrix is in A. This
-*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
-*> DOTYPE(MAXTYP+1) is .TRUE. .
-*> \endverbatim
-*>
-*> \param[in] DOTYPE
-*> \verbatim
-*> DOTYPE is LOGICAL array, dimension (NTYPES)
-*> If DOTYPE(j) is .TRUE., then for each size in NN a
-*> matrix of that size and of type j will be generated.
-*> If NTYPES is smaller than the maximum number of types
-*> defined (PARAMETER MAXTYP), then types NTYPES+1 through
-*> MAXTYP will not be generated. If NTYPES is larger
-*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
-*> will be ignored.
-*> \endverbatim
-*>
-*> \param[in,out] ISEED
-*> \verbatim
-*> ISEED is INTEGER array, dimension (4)
-*> On entry ISEED specifies the seed of the random number
-*> generator. The array elements should be between 0 and 4095;
-*> if not they will be reduced mod 4096. Also, ISEED(4) must
-*> be odd. The random number generator uses a linear
-*> congruential sequence limited to small integers, and so
-*> should produce machine independent random numbers. The
-*> values of ISEED are changed on exit, and can be used in the
-*> next call to ZDRVGG to continue the same random number
-*> sequence.
-*> \endverbatim
-*>
-*> \param[in] THRESH
-*> \verbatim
-*> THRESH is DOUBLE PRECISION
-*> A test will count as "failed" if the "error", computed as
-*> described above, exceeds THRESH. Note that the error is
-*> scaled to be O(1), so THRESH should be a reasonably small
-*> multiple of 1, e.g., 10 or 100. In particular, it should
-*> not depend on the precision (single vs. double) or the size
-*> of the matrix. It must be at least zero.
-*> \endverbatim
-*>
-*> \param[in] THRSHN
-*> \verbatim
-*> THRSHN is DOUBLE PRECISION
-*> Threshhold for reporting eigenvector normalization error.
-*> If the normalization of any eigenvector differs from 1 by
-*> more than THRSHN*ulp, then a special error message will be
-*> printed. (This is handled separately from the other tests,
-*> since only a compiler or programming error should cause an
-*> error message, at least if THRSHN is at least 5--10.)
-*> \endverbatim
-*>
-*> \param[in] NOUNIT
-*> \verbatim
-*> NOUNIT is INTEGER
-*> The FORTRAN unit number for printing out error messages
-*> (e.g., if a routine returns IINFO not equal to 0.)
-*> \endverbatim
-*>
-*> \param[in,out] A
-*> \verbatim
-*> A is COMPLEX*16 array, dimension (LDA, max(NN))
-*> Used to hold the original A matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of A, B, S, T, S2, and T2.
-*> It must be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is COMPLEX*16 array, dimension (LDA, max(NN))
-*> Used to hold the original B matrix. Used as input only
-*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
-*> DOTYPE(MAXTYP+1)=.TRUE.
-*> \endverbatim
-*>
-*> \param[out] S
-*> \verbatim
-*> S is COMPLEX*16 array, dimension (LDA, max(NN))
-*> The upper triangular matrix computed from A by ZGEGS.
-*> \endverbatim
-*>
-*> \param[out] T
-*> \verbatim
-*> T is COMPLEX*16 array, dimension (LDA, max(NN))
-*> The upper triangular matrix computed from B by ZGEGS.
-*> \endverbatim
-*>
-*> \param[out] S2
-*> \verbatim
-*> S2 is COMPLEX*16 array, dimension (LDA, max(NN))
-*> The matrix computed from A by ZGEGV. This will be the
-*> Schur (upper triangular) form of some matrix related to A,
-*> but will not, in general, be the same as S.
-*> \endverbatim
-*>
-*> \param[out] T2
-*> \verbatim
-*> T2 is COMPLEX*16 array, dimension (LDA, max(NN))
-*> The matrix computed from B by ZGEGV. This will be the
-*> Schur form of some matrix related to B, but will not, in
-*> general, be the same as T.
-*> \endverbatim
-*>
-*> \param[out] Q
-*> \verbatim
-*> Q is COMPLEX*16 array, dimension (LDQ, max(NN))
-*> The (left) unitary matrix computed by ZGEGS.
-*> \endverbatim
-*>
-*> \param[in] LDQ
-*> \verbatim
-*> LDQ is INTEGER
-*> The leading dimension of Q, Z, VL, and VR. It must
-*> be at least 1 and at least max( NN ).
-*> \endverbatim
-*>
-*> \param[out] Z
-*> \verbatim
-*> Z is COMPLEX*16 array, dimension (LDQ, max(NN))
-*> The (right) unitary matrix computed by ZGEGS.
-*> \endverbatim
-*>
-*> \param[out] ALPHA1
-*> \verbatim
-*> ALPHA1 is COMPLEX*16 array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA1
-*> \verbatim
-*> BETA1 is COMPLEX*16 array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by ZGEGS.
-*> ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of
-*> the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] ALPHA2
-*> \verbatim
-*> ALPHA2 is COMPLEX*16 array, dimension (max(NN))
-*> \endverbatim
-*>
-*> \param[out] BETA2
-*> \verbatim
-*> BETA2 is COMPLEX*16 array, dimension (max(NN))
-*>
-*> The generalized eigenvalues of (A,B) computed by ZGEGV.
-*> ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of
-*> the matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] VL
-*> \verbatim
-*> VL is COMPLEX*16 array, dimension (LDQ, max(NN))
-*> The (lower triangular) left eigenvector matrix for the
-*> matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] VR
-*> \verbatim
-*> VR is COMPLEX*16 array, dimension (LDQ, max(NN))
-*> The (upper triangular) right eigenvector matrix for the
-*> matrices in A and B.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is COMPLEX*16 array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The number of entries in WORK. This must be at least
-*> MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the
-*> sum of the blocksize and number-of-shifts for ZHGEQZ, and
-*> NB is the greatest of the blocksizes for ZGEQRF, ZUNMQR,
-*> and ZUNGQR. (The blocksizes and the number-of-shifts are
-*> retrieved through calls to ILAENV.)
-*> \endverbatim
-*>
-*> \param[out] RWORK
-*> \verbatim
-*> RWORK is DOUBLE PRECISION array, dimension (8*N)
-*> \endverbatim
-*>
-*> \param[out] RESULT
-*> \verbatim
-*> RESULT is DOUBLE PRECISION array, dimension (7)
-*> The values computed by the tests described above.
-*> The values are currently limited to 1/ulp, to avoid
-*> overflow.
-*> \endverbatim
-*>
-*> \param[out] INFO
-*> \verbatim
-*> INFO is INTEGER
-*> = 0: successful exit
-*> < 0: if INFO = -i, the i-th argument had an illegal value.
-*> > 0: A routine returned an error code. INFO is the
-*> absolute value of the INFO value returned.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup complex16_eig
-*
-* =====================================================================
- SUBROUTINE ZDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
- $ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
- $ LDQ, Z, ALPHA1, BETA1, ALPHA2, BETA2, VL, VR,
- $ WORK, LWORK, RWORK, RESULT, INFO )
-*
-* -- LAPACK test 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 ..
- INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
- DOUBLE PRECISION THRESH, THRSHN
-* ..
-* .. Array Arguments ..
-*
-* =====================================================================
-*
- LOGICAL DOTYPE( * )
- INTEGER ISEED( 4 ), NN( * )
- DOUBLE PRECISION RESULT( * ), RWORK( * )
- COMPLEX*16 A( LDA, * ), ALPHA1( * ), ALPHA2( * ),
- $ B( LDA, * ), BETA1( * ), BETA2( * ),
- $ Q( LDQ, * ), S( LDA, * ), S2( LDA, * ),
- $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
- $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
-* ..
-* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
- COMPLEX*16 CZERO, CONE
- PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
- $ CONE = ( 1.0D+0, 0.0D+0 ) )
- INTEGER MAXTYP
- PARAMETER ( MAXTYP = 26 )
-* ..
-* .. Local Scalars ..
- LOGICAL BADNN
- INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
- $ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
- $ NMAX, NS, NTEST, NTESTT
- DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
- COMPLEX*16 CTEMP, X
-* ..
-* .. Local Arrays ..
- LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
- INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
- $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
- $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
- $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
- $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
- DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- DOUBLE PRECISION DLAMCH
- COMPLEX*16 ZLARND
- EXTERNAL ILAENV, DLAMCH, ZLARND
-* ..
-* .. External Subroutines ..
- EXTERNAL ALASVM, DLABAD, XERBLA, ZGEGS, ZGEGV, ZGET51,
- $ ZGET52, ZLACPY, ZLARFG, ZLASET, ZLATM4, ZUNM2R
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SIGN
-* ..
-* .. Statement Functions ..
- DOUBLE PRECISION ABS1
-* ..
-* .. Statement Function definitions ..
- ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
-* ..
-* .. Data statements ..
- DATA KCLASS / 15*1, 10*2, 1*3 /
- DATA KZ1 / 0, 1, 2, 1, 3, 3 /
- DATA KZ2 / 0, 0, 1, 2, 1, 1 /
- DATA KADD / 0, 0, 0, 0, 3, 2 /
- DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
- $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
- DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
- $ 1, 1, -4, 2, -4, 8*8, 0 /
- DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
- $ 4*5, 4*3, 1 /
- DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
- $ 4*6, 4*4, 1 /
- DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
- $ 2, 1 /
- DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
- $ 2, 1 /
- DATA KTRIAN / 16*0, 10*1 /
- DATA LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE.,
- $ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE.,
- $ 3*.FALSE., 5*.TRUE., .FALSE. /
- DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE.,
- $ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE.,
- $ 9*.FALSE. /
-* ..
-* .. Executable Statements ..
-*
-* Check for errors
-*
- INFO = 0
-*
- BADNN = .FALSE.
- NMAX = 1
- DO 10 J = 1, NSIZES
- NMAX = MAX( NMAX, NN( J ) )
- IF( NN( J ).LT.0 )
- $ BADNN = .TRUE.
- 10 CONTINUE
-*
-* Maximum blocksize and shift -- we assume that blocksize and number
-* of shifts are monotone increasing functions of N.
-*
- NB = MAX( 1, ILAENV( 1, 'ZGEQRF', ' ', NMAX, NMAX, -1, -1 ),
- $ ILAENV( 1, 'ZUNMQR', 'LC', NMAX, NMAX, NMAX, -1 ),
- $ ILAENV( 1, 'ZUNGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
- NBZ = ILAENV( 1, 'ZHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- NS = ILAENV( 4, 'ZHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
- I1 = NBZ + NS
- LWKOPT = MAX( 2*NMAX, NMAX*( NB+1 ), ( 2*I1+NMAX+1 )*( I1+1 ) )
-*
-* Check for errors
-*
- IF( NSIZES.LT.0 ) THEN
- INFO = -1
- ELSE IF( BADNN ) THEN
- INFO = -2
- ELSE IF( NTYPES.LT.0 ) THEN
- INFO = -3
- ELSE IF( THRESH.LT.ZERO ) THEN
- INFO = -6
- ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
- INFO = -10
- ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
- INFO = -19
- ELSE IF( LWKOPT.GT.LWORK ) THEN
- INFO = -30
- END IF
-*
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'ZDRVGG', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
- $ RETURN
-*
- ULP = DLAMCH( 'Precision' )
- SAFMIN = DLAMCH( 'Safe minimum' )
- SAFMIN = SAFMIN / ULP
- SAFMAX = ONE / SAFMIN
- CALL DLABAD( SAFMIN, SAFMAX )
- ULPINV = ONE / ULP
-*
-* The values RMAGN(2:3) depend on N, see below.
-*
- RMAGN( 0 ) = ZERO
- RMAGN( 1 ) = ONE
-*
-* Loop over sizes, types
-*
- NTESTT = 0
- NERRS = 0
- NMATS = 0
-*
- DO 160 JSIZE = 1, NSIZES
- N = NN( JSIZE )
- N1 = MAX( 1, N )
- RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
- RMAGN( 3 ) = SAFMIN*ULPINV*N1
-*
- IF( NSIZES.NE.1 ) THEN
- MTYPES = MIN( MAXTYP, NTYPES )
- ELSE
- MTYPES = MIN( MAXTYP+1, NTYPES )
- END IF
-*
- DO 150 JTYPE = 1, MTYPES
- IF( .NOT.DOTYPE( JTYPE ) )
- $ GO TO 150
- NMATS = NMATS + 1
- NTEST = 0
-*
-* Save ISEED in case of an error.
-*
- DO 20 J = 1, 4
- IOLDSD( J ) = ISEED( J )
- 20 CONTINUE
-*
-* Initialize RESULT
-*
- DO 30 J = 1, 7
- RESULT( J ) = ZERO
- 30 CONTINUE
-*
-* Compute A and B
-*
-* Description of control parameters:
-*
-* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
-* =3 means random.
-* KATYPE: the "type" to be passed to ZLATM4 for computing A.
-* KAZERO: the pattern of zeros on the diagonal for A:
-* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
-* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
-* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
-* non-zero entries.)
-* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
-* =2: large, =3: small.
-* LASIGN: .TRUE. if the diagonal elements of A are to be
-* multiplied by a random magnitude 1 number.
-* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
-* KTRIAN: =0: don't fill in the upper triangle, =1: do.
-* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
-* RMAGN: used to implement KAMAGN and KBMAGN.
-*
- IF( MTYPES.GT.MAXTYP )
- $ GO TO 110
- IINFO = 0
- IF( KCLASS( JTYPE ).LT.3 ) THEN
-*
-* Generate A (w/o rotation)
-*
- IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
- ELSE
- IN = N
- END IF
- CALL ZLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
- $ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ),
- $ RMAGN( KAMAGN( JTYPE ) ), ULP,
- $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
- $ ISEED, A, LDA )
- IADD = KADD( KAZERO( JTYPE ) )
- IF( IADD.GT.0 .AND. IADD.LE.N )
- $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) )
-*
-* Generate B (w/o rotation)
-*
- IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
- IN = 2*( ( N-1 ) / 2 ) + 1
- IF( IN.NE.N )
- $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, B, LDA )
- ELSE
- IN = N
- END IF
- CALL ZLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
- $ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ),
- $ RMAGN( KBMAGN( JTYPE ) ), ONE,
- $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
- $ ISEED, B, LDA )
- IADD = KADD( KBZERO( JTYPE ) )
- IF( IADD.NE.0 .AND. IADD.LE.N )
- $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) )
-*
- IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
-*
-* Include rotations
-*
-* Generate Q, Z as Householder transformations times
-* a diagonal matrix.
-*
- DO 50 JC = 1, N - 1
- DO 40 JR = JC, N
- Q( JR, JC ) = ZLARND( 3, ISEED )
- Z( JR, JC ) = ZLARND( 3, ISEED )
- 40 CONTINUE
- CALL ZLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
- $ WORK( JC ) )
- WORK( 2*N+JC ) = SIGN( ONE, DBLE( Q( JC, JC ) ) )
- Q( JC, JC ) = CONE
- CALL ZLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
- $ WORK( N+JC ) )
- WORK( 3*N+JC ) = SIGN( ONE, DBLE( Z( JC, JC ) ) )
- Z( JC, JC ) = CONE
- 50 CONTINUE
- CTEMP = ZLARND( 3, ISEED )
- Q( N, N ) = CONE
- WORK( N ) = CZERO
- WORK( 3*N ) = CTEMP / ABS( CTEMP )
- CTEMP = ZLARND( 3, ISEED )
- Z( N, N ) = CONE
- WORK( 2*N ) = CZERO
- WORK( 4*N ) = CTEMP / ABS( CTEMP )
-*
-* Apply the diagonal matrices
-*
- DO 70 JC = 1, N
- DO 60 JR = 1, N
- A( JR, JC ) = WORK( 2*N+JR )*
- $ DCONJG( WORK( 3*N+JC ) )*
- $ A( JR, JC )
- B( JR, JC ) = WORK( 2*N+JR )*
- $ DCONJG( WORK( 3*N+JC ) )*
- $ B( JR, JC )
- 60 CONTINUE
- 70 CONTINUE
- CALL ZUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL ZUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ A, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL ZUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
- $ LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- CALL ZUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ),
- $ B, LDA, WORK( 2*N+1 ), IINFO )
- IF( IINFO.NE.0 )
- $ GO TO 100
- END IF
- ELSE
-*
-* Random matrices
-*
- DO 90 JC = 1, N
- DO 80 JR = 1, N
- A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
- $ ZLARND( 4, ISEED )
- B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
- $ ZLARND( 4, ISEED )
- 80 CONTINUE
- 90 CONTINUE
- END IF
-*
- 100 CONTINUE
-*
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- RETURN
- END IF
-*
- 110 CONTINUE
-*
-* Call ZGEGS to compute H, T, Q, Z, alpha, and beta.
-*
- CALL ZLACPY( ' ', N, N, A, LDA, S, LDA )
- CALL ZLACPY( ' ', N, N, B, LDA, T, LDA )
- NTEST = 1
- RESULT( 1 ) = ULPINV
-*
- CALL ZGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHA1, BETA1, Q,
- $ LDQ, Z, LDQ, WORK, LWORK, RWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'ZGEGS', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 130
- END IF
-*
- NTEST = 4
-*
-* Do tests 1--4
-*
- CALL ZGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RWORK, RESULT( 1 ) )
- CALL ZGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
- $ RWORK, RESULT( 2 ) )
- CALL ZGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
- $ RWORK, RESULT( 3 ) )
- CALL ZGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
- $ RWORK, RESULT( 4 ) )
-*
-* Do test 5: compare eigenvalues with diagonals.
-*
- TEMP1 = ZERO
-*
- DO 120 J = 1, N
- TEMP2 = ( ABS1( ALPHA1( J )-S( J, J ) ) /
- $ MAX( SAFMIN, ABS1( ALPHA1( J ) ), ABS1( S( J,
- $ J ) ) )+ABS1( BETA1( J )-T( J, J ) ) /
- $ MAX( SAFMIN, ABS1( BETA1( J ) ), ABS1( T( J,
- $ J ) ) ) ) / ULP
- TEMP1 = MAX( TEMP1, TEMP2 )
- 120 CONTINUE
- RESULT( 5 ) = TEMP1
-*
-* Call ZGEGV to compute S2, T2, VL, and VR, do tests.
-*
-* Eigenvalues and Eigenvectors
-*
- CALL ZLACPY( ' ', N, N, A, LDA, S2, LDA )
- CALL ZLACPY( ' ', N, N, B, LDA, T2, LDA )
- NTEST = 6
- RESULT( 6 ) = ULPINV
-*
- CALL ZGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHA2, BETA2,
- $ VL, LDQ, VR, LDQ, WORK, LWORK, RWORK, IINFO )
- IF( IINFO.NE.0 ) THEN
- WRITE( NOUNIT, FMT = 9999 )'ZGEGV', IINFO, N, JTYPE,
- $ IOLDSD
- INFO = ABS( IINFO )
- GO TO 130
- END IF
-*
- NTEST = 7
-*
-* Do Tests 6 and 7
-*
- CALL ZGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHA2,
- $ BETA2, WORK, RWORK, DUMMA( 1 ) )
- RESULT( 6 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRSHN ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Left', 'ZGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
- CALL ZGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHA2,
- $ BETA2, WORK, RWORK, DUMMA( 1 ) )
- RESULT( 7 ) = DUMMA( 1 )
- IF( DUMMA( 2 ).GT.THRESH ) THEN
- WRITE( NOUNIT, FMT = 9998 )'Right', 'ZGEGV', DUMMA( 2 ),
- $ N, JTYPE, IOLDSD
- END IF
-*
-* End of Loop -- Check for RESULT(j) > THRESH
-*
- 130 CONTINUE
-*
- NTESTT = NTESTT + NTEST
-*
-* Print out tests which fail.
-*
- DO 140 JR = 1, NTEST
- IF( RESULT( JR ).GE.THRESH ) THEN
-*
-* If this is the first test to fail,
-* print a header to the data file.
-*
- IF( NERRS.EQ.0 ) THEN
- WRITE( NOUNIT, FMT = 9997 )'ZGG'
-*
-* Matrix types
-*
- WRITE( NOUNIT, FMT = 9996 )
- WRITE( NOUNIT, FMT = 9995 )
- WRITE( NOUNIT, FMT = 9994 )'Unitary'
-*
-* Tests performed
-*
- WRITE( NOUNIT, FMT = 9993 )'unitary', '*',
- $ 'conjugate transpose', ( '*', J = 1, 5 )
-*
- END IF
- NERRS = NERRS + 1
- IF( RESULT( JR ).LT.10000.0D0 ) THEN
- WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- ELSE
- WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
- $ RESULT( JR )
- END IF
- END IF
- 140 CONTINUE
-*
- 150 CONTINUE
- 160 CONTINUE
-*
-* Summary
-*
- CALL ALASVM( 'ZGG', NOUNIT, NERRS, NTESTT, 0 )
- RETURN
-*
- 9999 FORMAT( ' ZDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
- $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
-*
- 9998 FORMAT( ' ZDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
- $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
- $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
- $ ')' )
-*
- 9997 FORMAT( / 1X, A3,
- $ ' -- Complex Generalized eigenvalue problem driver' )
-*
- 9996 FORMAT( ' Matrix types (see ZDRVGG for details): ' )
-*
- 9995 FORMAT( ' Special Matrices:', 23X,
- $ '(J''=transposed Jordan block)',
- $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
- $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
- $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
- $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
- $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
- $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
- 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
- $ / ' 16=Transposed Jordan Blocks 19=geometric ',
- $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
- $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
- $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
- $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
- $ '23=(small,large) 24=(small,small) 25=(large,large)',
- $ / ' 26=random O(1) matrices.' )
-*
- 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
- $ 'Q and Z are ', A, ',', / 20X,
- $ 'l and r are the appropriate left and right', / 19X,
- $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
- $ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
- $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
- $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
- $ ' | / ( n ulp ) 4 = | I - ZZ', A,
- $ ' | / ( n ulp )', /
- $ ' 5 = difference between (alpha,beta) and diagonals of',
- $ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
- $ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
- $ / 1X )
- 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
- 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
- $ 4( I4, ',' ), ' result ', I3, ' is', 1P, D10.3 )
-*
-* End of ZDRVGG
-*
- END
stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f
stpt02.f stpt03.f stpt05.f stpt06.f strt01.f
strt02.f strt03.f strt05.f strt06.f
- stzt01.f stzt02.f sgennd.f
+ sgennd.f
sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f)
if(USEXBLAS)
ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f
ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f
ctrt02.f ctrt03.f ctrt05.f ctrt06.f
- ctzt01.f ctzt02.f sget06.f cgennd.f
+ sget06.f cgennd.f
cqrt04.f cqrt05.f cchkqrt.f cerrqrt.f cchkqrtp.f cerrqrtp.f )
if(USEXBLAS)
dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f
dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f
dtrt02.f dtrt03.f dtrt05.f dtrt06.f
- dtzt01.f dtzt02.f dgennd.f
+ dgennd.f
dqrt04.f dqrt05.f dchkqrt.f derrqrt.f dchkqrtp.f derrqrtp.f )
if(USEXBLAS)
ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f
ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f
ztrt02.f ztrt03.f ztrt05.f ztrt06.f
- ztzt01.f ztzt02.f dget06.f zgennd.f
+ dget06.f zgennd.f
zqrt04.f zqrt05.f zchkqrt.f zerrqrt.f zchkqrtp.f zerrqrtp.f )
if(USEXBLAS)
stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \
stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \
strt02.o strt03.o strt05.o strt06.o \
- stzt01.o stzt02.o sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o
+ sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o
ifdef USEXBLAS
SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \
ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \
ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \
ctrt02.o ctrt03.o ctrt05.o ctrt06.o \
- ctzt01.o ctzt02.o sget06.o cgennd.o \
+ sget06.o cgennd.o \
cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o
ifdef USEXBLAS
dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \
dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \
dtrt02.o dtrt03.o dtrt05.o dtrt06.o \
- dtzt01.o dtzt02.o dgennd.o \
+ dgennd.o \
dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o
ifdef USEXBLAS
ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \
ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \
ztrt02.o ztrt03.o ztrt05.o ztrt06.o \
- ztzt01.o ztzt02.o dget06.o zgennd.o \
+ dget06.o zgennd.o \
zqrt04.o zqrt05.o zchkqrt.o zerrqrt.o zchkqrtp.o zerrqrtp.o
ifdef USEXBLAS
*
WRITE( IOUNIT, FMT = 9985 )PATH
WRITE( IOUNIT, FMT = 9968 )
- WRITE( IOUNIT, FMT = 9929 )C1, C1
+ WRITE( IOUNIT, FMT = 9929 )C1
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9937 )2
WRITE( IOUNIT, FMT = 9938 )3
- WRITE( IOUNIT, FMT = 9940 )4
- WRITE( IOUNIT, FMT = 9937 )5
- WRITE( IOUNIT, FMT = 9938 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LS' ) ) THEN
*
WRITE( IOUNIT, FMT = 9984 )PATH
WRITE( IOUNIT, FMT = 9967 )
- WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1
+ WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1
WRITE( IOUNIT, FMT = 9935 )1
WRITE( IOUNIT, FMT = 9931 )2
WRITE( IOUNIT, FMT = 9933 )3
$ 'otherwise', / 7X,
$ 'check if X is in the row space of A or A'' ',
$ '(overdetermined case)' )
- 9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRQF, 4-6: ', A1,
- $ 'TZRZF):' )
- 9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6',
- $ 3X, ' 15-18: same as 3-6' )
+ 9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRZF):' )
+ 9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6' )
9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1,
- $ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ',
- $ A1, 'GELSD)' )
+ $ 'GELSY, 7-10: ', A1, 'GELSS, 11-14: ', A1, 'GELSD)' )
9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' )
9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X,
$ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' )
*>
*> \verbatim
*>
-*> CCHKTZ tests CTZRQF and CTZRZF.
+*> CCHKTZ tests CTZRZF.
*> \endverbatim
*
* Arguments:
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
- PARAMETER ( NTESTS = 6 )
+ PARAMETER ( NTESTS = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
- REAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
- EXTERNAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
+ REAL CQRT12, CRZT01, CRZT02, SLAMCH
+ EXTERNAL CQRT12, CRZT01, CRZT02, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, CERRTZ, CGEQR2, CLACPY, CLASET,
- $ CLATMS, CTZRQF, CTZRZF, SLAORD
+ $ CLATMS, CTZRZF, SLAORD
* ..
* .. Intrinsic Functions ..
INTRINSIC CMPLX, MAX, MIN
*
MODE = IMODE - 1
*
-* Test CTZRQF
-*
-* Generate test matrix of size m by n using
-* singular value distribution indicated by `mode'.
-*
- IF( MODE.EQ.0 ) THEN
- CALL CLASET( 'Full', M, N, CMPLX( ZERO ),
- $ CMPLX( ZERO ), A, LDA )
- DO 20 I = 1, MNMIN
- S( I ) = ZERO
- 20 CONTINUE
- ELSE
- CALL CLATMS( M, N, 'Uniform', ISEED,
- $ 'Nonsymmetric', S, IMODE,
- $ ONE / EPS, ONE, M, N, 'No packing', A,
- $ LDA, WORK, INFO )
- CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
- $ INFO )
- CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ),
- $ CMPLX( ZERO ), A( 2 ), LDA )
- CALL SLAORD( 'Decreasing', MNMIN, S, 1 )
- END IF
-*
-* Save A and its singular values
-*
- CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA )
-*
-* Call CTZRQF to reduce the upper trapezoidal matrix to
-* upper triangular form.
-*
- SRNAMT = 'CTZRQF'
- CALL CTZRQF( M, N, A, LDA, TAU, INFO )
-*
-* Compute norm(svd(a) - svd(r))
-*
- RESULT( 1 ) = CQRT12( M, M, A, LDA, S, WORK,
- $ LWORK, RWORK )
-*
-* Compute norm( A - R*Q )
-*
- RESULT( 2 ) = CTZT01( M, N, COPYA, A, LDA, TAU, WORK,
- $ LWORK )
-*
-* Compute norm(Q'*Q - I).
-*
- RESULT( 3 ) = CTZT02( M, N, A, LDA, TAU, WORK, LWORK )
-*
* Test CTZRZF
*
* Generate test matrix of size m by n using
*
* Compute norm(svd(a) - svd(r))
*
- RESULT( 4 ) = CQRT12( M, M, A, LDA, S, WORK,
+ RESULT( 1 ) = CQRT12( M, M, A, LDA, S, WORK,
$ LWORK, RWORK )
*
* Compute norm( A - R*Q )
*
- RESULT( 5 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK,
+ RESULT( 2 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
- RESULT( 6 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK )
+ RESULT( 3 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
- DO 40 K = 1, 6
+ DO 40 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
- NRUN = NRUN + 6
+ NRUN = NRUN + 3
50 CONTINUE
END IF
60 CONTINUE
*>
*> \verbatim
*>
-*> CDRVLS tests the least squares driver routines CGELS, CGELSX, CGELSS,
-*> CGELSY and CGELSD.
+*> CDRVLS tests the least squares driver routines CGELS, CGELSS, CGELSY
+*> and CGELSD.
*> \endverbatim
*
* Arguments:
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 18 )
+ PARAMETER ( NTESTS = 14 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
REAL ONE, ZERO
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD,
- $ CGELSS, CGELSX, CGELSY, CGEMM, CLACPY, CLARNV,
+ $ CGELSS, CGELSY, CGEMM, CLACPY, CLARNV,
$ CQRT13, CQRT15, CQRT16, CSSCAL, SAXPY,
$ XLAENV
* ..
*
* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
- DO 50 J = 1, N
- IWORK( J ) = 0
- 50 CONTINUE
LDWORK = MAX( 1, M )
*
-* Test CGELSX
-*
-* CGELSX: Compute the minimum-norm solution X
-* to min( norm( A * X - B ) )
-* using a complete orthogonal factorization.
-*
- CALL CLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
- CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB )
-*
- SRNAMT = 'CGELSX'
- CALL CGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
- $ RCOND, CRANK, WORK, RWORK, INFO )
-*
- IF( INFO.NE.0 )
- $ CALL ALAERH( PATH, 'CGELSX', INFO, 0, ' ', M, N,
- $ NRHS, -1, NB, ITYPE, NFAIL, NERRS,
- $ NOUT )
-*
-* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
-*
-* Test 3: Compute relative error in svd
-* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
-*
- RESULT( 3 ) = CQRT12( CRANK, CRANK, A, LDA, COPYS,
- $ WORK, LWORK, RWORK )
-*
-* Test 4: Compute error in solution
-* workspace: M*NRHS + M
-*
- CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
- $ LDWORK )
- CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
- $ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 4 ) )
-*
-* Test 5: Check norm of r'*A
-* workspace: NRHS*(M+N)
-*
- RESULT( 5 ) = ZERO
- IF( M.GT.CRANK )
- $ RESULT( 5 ) = CQRT17( 'No transpose', 1, M, N,
- $ NRHS, COPYA, LDA, B, LDB, COPYB,
- $ LDB, C, WORK, LWORK )
-*
-* Test 6: Check if x is in the rowspace of A
-* workspace: (M+NRHS)*(N+2)
-*
- RESULT( 6 ) = ZERO
-*
- IF( N.GT.CRANK )
- $ RESULT( 6 ) = CQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB, WORK,
- $ LWORK )
-*
-* Print information about the tests that did not
-* pass the threshold.
-*
- DO 60 K = 3, 6
- IF( RESULT( K ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9998 )M, N, NRHS, 0,
- $ ITYPE, K, RESULT( K )
- NFAIL = NFAIL + 1
- END IF
- 60 CONTINUE
- NRUN = NRUN + 4
-*
* Loop for testing different block sizes.
*
DO 90 INB = 1, NNB
*
* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS)
*
-* Test 7: Compute relative error in svd
+* Test 3: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
- RESULT( 7 ) = CQRT12( CRANK, CRANK, A, LDA,
+ RESULT( 3 ) = CQRT12( CRANK, CRANK, A, LDA,
$ COPYS, WORK, LWORK, RWORK )
*
-* Test 8: Compute error in solution
+* Test 4: Compute error in solution
* workspace: M*NRHS + M
*
CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 8 ) )
+ $ RESULT( 4 ) )
*
-* Test 9: Check norm of r'*A
+* Test 5: Check norm of r'*A
* workspace: NRHS*(M+N)
*
- RESULT( 9 ) = ZERO
+ RESULT( 5 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 9 ) = CQRT17( 'No transpose', 1, M,
+ $ RESULT( 5 ) = CQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 10: Check if x is in the rowspace of A
+* Test 6: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
- RESULT( 10 ) = ZERO
+ RESULT( 6 ) = ZERO
*
IF( N.GT.CRANK )
- $ RESULT( 10 ) = CQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB,
- $ WORK, LWORK )
+ $ RESULT( 6 ) = CQRT14( 'No transpose', M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
*
* Test CGELSS
*
* workspace used: 3*min(m,n) +
* max(2*min(m,n),nrhs,max(m,n))
*
-* Test 11: Compute relative error in svd
+* Test 7: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 11 ) = SASUM( MNMIN, S, 1 ) /
+ RESULT( 7 ) = SASUM( MNMIN, S, 1 ) /
$ SASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*REAL( MNMIN ) )
ELSE
- RESULT( 11 ) = ZERO
+ RESULT( 7 ) = ZERO
END IF
*
-* Test 12: Compute error in solution
+* Test 8: Compute error in solution
*
CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 12 ) )
+ $ RESULT( 8 ) )
*
-* Test 13: Check norm of r'*A
+* Test 9: Check norm of r'*A
*
- RESULT( 13 ) = ZERO
+ RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 13 ) = CQRT17( 'No transpose', 1, M,
+ $ RESULT( 9 ) = CQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 14: Check if x is in the rowspace of A
+* Test 10: Check if x is in the rowspace of A
*
- RESULT( 14 ) = ZERO
+ RESULT( 10 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 14 ) = CQRT14( 'No transpose', M, N,
+ $ RESULT( 10 ) = CQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
-* Test 15: Compute relative error in svd
+* Test 11: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 15 ) = SASUM( MNMIN, S, 1 ) /
+ RESULT( 11 ) = SASUM( MNMIN, S, 1 ) /
$ SASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*REAL( MNMIN ) )
ELSE
- RESULT( 15 ) = ZERO
+ RESULT( 11 ) = ZERO
END IF
*
-* Test 16: Compute error in solution
+* Test 12: Compute error in solution
*
CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 16 ) )
+ $ RESULT( 12 ) )
*
-* Test 17: Check norm of r'*A
+* Test 13: Check norm of r'*A
*
- RESULT( 17 ) = ZERO
+ RESULT( 13 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 17 ) = CQRT17( 'No transpose', 1, M,
+ $ RESULT( 13 ) = CQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 18: Check if x is in the rowspace of A
+* Test 14: Check if x is in the rowspace of A
*
- RESULT( 18 ) = ZERO
+ RESULT( 14 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 18 ) = CQRT14( 'No transpose', M, N,
+ $ RESULT( 14 ) = CQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
- DO 80 K = 7, NTESTS
+ DO 80 K = 3, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
*> \verbatim
*>
*> CERRLS tests the error exits for the COMPLEX least squares
-*> driver routines (CGELS, CGELSS, CGELSX, CGELSY, CGELSD).
+*> driver routines (CGELS, CGELSS, CGELSY, CGELSD).
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CGELS, CGELSD, CGELSS, CGELSX, CGELSY,
- $ CHKXER
+ EXTERNAL ALAESM, CGELS, CGELSD, CGELSS, CGELSY, CHKXER
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ INFO )
CALL CHKXER( 'CGELSS', INFOT, NOUT, LERR, OK )
*
-* CGELSX
-*
- SRNAMT = 'CGELSX'
- INFOT = 1
- CALL CGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL CGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL CGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 5
- CALL CGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 7
- CALL CGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'CGELSX', INFOT, NOUT, LERR, OK )
-*
* CGELSY
*
SRNAMT = 'CGELSY'
*>
*> \verbatim
*>
-*> CERRTZ tests the error exits for CTZRQF and CTZRZF.
+*> CERRTZ tests the error exits for CTZRZF.
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, CTZRQF, CTZRZF
+ EXTERNAL ALAESM, CHKXER, CTZRZF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
WRITE( NOUT, FMT = * )
IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
-* CTZRQF
-*
- SRNAMT = 'CTZRQF'
- INFOT = 1
- CALL CTZRQF( -1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'CTZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL CTZRQF( 1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'CTZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 4
- CALL CTZRQF( 2, 2, A, 1, TAU, INFO )
- CALL CHKXER( 'CTZRQF', INFOT, NOUT, LERR, OK )
-*
* CTZRZF
*
SRNAMT = 'CTZRZF'
+++ /dev/null
-*> \brief \b CTZT01
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* REAL FUNCTION CTZT01( M, N, A, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ),
-* $ WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> CTZT01 returns
-*> || A - R*Q || / ( M * eps * ||A|| )
-*> for an upper trapezoidal A that was factored with CTZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] A
-*> \verbatim
-*> A is COMPLEX array, dimension (LDA,N)
-*> The original upper trapezoidal M by N matrix A.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is COMPLEX array, dimension (LDA,N)
-*> The output of CTZRQF for input matrix A.
-*> The lower triangle is not referenced.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the arrays A and AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is COMPLEX array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> CTZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is COMPLEX array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The length of the array WORK. LWORK >= m*n + m.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup complex_lin
-*
-* =====================================================================
- REAL FUNCTION CTZT01( M, N, A, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- COMPLEX A( LDA, * ), AF( LDA, * ), TAU( * ),
- $ WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
-* ..
-* .. Local Scalars ..
- INTEGER I, J
- REAL NORMA
-* ..
-* .. Local Arrays ..
- REAL RWORK( 1 )
-* ..
-* .. External Functions ..
- REAL CLANGE, SLAMCH
- EXTERNAL CLANGE, SLAMCH
-* ..
-* .. External Subroutines ..
- EXTERNAL CAXPY, CLATZM, CLASET, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CMPLX, MAX, REAL
-* ..
-* .. Executable Statements ..
-*
- CTZT01 = ZERO
-*
- IF( LWORK.LT.M*N+M ) THEN
- CALL XERBLA( 'CTZT01', 8 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
- NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK )
-*
-* Copy upper triangle R
-*
- CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M )
- DO 20 J = 1, M
- DO 10 I = 1, J
- WORK( ( J-1 )*M+I ) = AF( I, J )
- 10 CONTINUE
- 20 CONTINUE
-*
-* R = R * P(1) * ... *P(m)
-*
- DO 30 I = 1, M
- CALL CLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
- $ WORK( M*N+1 ) )
- 30 CONTINUE
-*
-* R = R - A
-*
- DO 40 I = 1, N
- CALL CAXPY( M, CMPLX( -ONE ), A( 1, I ), 1,
- $ WORK( ( I-1 )*M+1 ), 1 )
- 40 CONTINUE
-*
- CTZT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK )
-*
- CTZT01 = CTZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
- IF( NORMA.NE.ZERO )
- $ CTZT01 = CTZT01 / NORMA
-*
- RETURN
-*
-* End of CTZT01
-*
- END
+++ /dev/null
-*> \brief \b CTZT02
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* REAL FUNCTION CTZT02( M, N, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* COMPLEX AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> CTZT02 returns
-*> || I - Q'*Q || / ( M * eps)
-*> where the matrix Q is defined by the Householder transformations
-*> generated by CTZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is COMPLEX array, dimension (LDA,N)
-*> The output of CTZRQF.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is COMPLEX array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> CTZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is COMPLEX array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> length of WORK array. Must be >= N*N+N
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup complex_lin
-*
-* =====================================================================
- REAL FUNCTION CTZT02( M, N, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- COMPLEX AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
-* ..
-* .. Local Scalars ..
- INTEGER I
-* ..
-* .. Local Arrays ..
- REAL RWORK( 1 )
-* ..
-* .. External Functions ..
- REAL CLANGE, SLAMCH
- EXTERNAL CLANGE, SLAMCH
-* ..
-* .. External Subroutines ..
- EXTERNAL CLATZM, CLASET, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CMPLX, CONJG, MAX, REAL
-* ..
-* .. Executable Statements ..
-*
- CTZT02 = ZERO
-*
- IF( LWORK.LT.N*N+N ) THEN
- CALL XERBLA( 'CTZT02', 7 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
-* Q := I
-*
- CALL CLASET( 'Full', N, N, CMPLX( ZERO ), CMPLX( ONE ), WORK, N )
-*
-* Q := P(1) * ... * P(m) * Q
-*
- DO 10 I = M, 1, -1
- CALL CLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
- 10 CONTINUE
-*
-* Q := P(m)' * ... * P(1)' * Q
-*
- DO 20 I = 1, M
- CALL CLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA,
- $ CONJG( TAU( I ) ), WORK( I ), WORK( M+1 ), N,
- $ WORK( N*N+1 ) )
- 20 CONTINUE
-*
-* Q := Q - I
-*
- DO 30 I = 1, N
- WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
- 30 CONTINUE
-*
- CTZT02 = CLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
- $ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
- RETURN
-*
-* End of CTZT02
-*
- END
*>
*> \verbatim
*>
-*> DCHKTZ tests DTZRQF and STZRZF.
+*> DCHKTZ tests DTZRZF.
*> \endverbatim
*
* Arguments:
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
- PARAMETER ( NTESTS = 6 )
+ PARAMETER ( NTESTS = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
- DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02
- EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02
+ DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02
+ EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD,
- $ DLASET, DLATMS, DTZRQF, DTZRZF
+ $ DLASET, DLATMS, DTZRZF
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
-*
- IF( MODE.EQ.0 ) THEN
- CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
- DO 20 I = 1, MNMIN
- S( I ) = ZERO
- 20 CONTINUE
- ELSE
- CALL DLATMS( M, N, 'Uniform', ISEED,
- $ 'Nonsymmetric', S, IMODE,
- $ ONE / EPS, ONE, M, N, 'No packing', A,
- $ LDA, WORK, INFO )
- CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
- $ INFO )
- CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
- $ LDA )
- CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
- END IF
-*
-* Save A and its singular values
-*
- CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA )
-*
-* Call DTZRQF to reduce the upper trapezoidal matrix to
-* upper triangular form.
-*
- SRNAMT = 'DTZRQF'
- CALL DTZRQF( M, N, A, LDA, TAU, INFO )
-*
-* Compute norm(svd(a) - svd(r))
-*
- RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK,
- $ LWORK )
-*
-* Compute norm( A - R*Q )
-*
- RESULT( 2 ) = DTZT01( M, N, COPYA, A, LDA, TAU, WORK,
- $ LWORK )
-*
-* Compute norm(Q'*Q - I).
-*
- RESULT( 3 ) = DTZT02( M, N, A, LDA, TAU, WORK, LWORK )
-*
-* Test DTZRZF
-*
-* Generate test matrix of size m by n using
-* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
*
* Compute norm(svd(a) - svd(r))
*
- RESULT( 4 ) = DQRT12( M, M, A, LDA, S, WORK,
+ RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
- RESULT( 5 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK,
+ RESULT( 2 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
- RESULT( 6 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK )
+ RESULT( 3 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
- DO 40 K = 1, 6
+ DO 40 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
- NRUN = NRUN + 6
+ NRUN = NRUN + 3
50 CONTINUE
END IF
60 CONTINUE
*>
*> \verbatim
*>
-*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX,
-*> DGELSY and DGELSD.
+*> DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSY,
+*> and DGELSD.
*> \endverbatim
*
* Arguments:
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 18 )
+ PARAMETER ( NTESTS = 14 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
DOUBLE PRECISION ONE, TWO, ZERO
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DERRLS, DGELS,
- $ DGELSD, DGELSS, DGELSX, DGELSY, DGEMM, DLACPY,
+ $ DGELSD, DGELSS, DGELSY, DGEMM, DLACPY,
$ DLARNV, DLASRT, DQRT13, DQRT15, DQRT16, DSCAL,
$ XLAENV
* ..
*
* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
-* Initialize vector IWORK.
-*
- DO 50 J = 1, N
- IWORK( J ) = 0
- 50 CONTINUE
LDWORK = MAX( 1, M )
*
-* Test DGELSX
-*
-* DGELSX: Compute the minimum-norm solution X
-* to min( norm( A * X - B ) ) using a complete
-* orthogonal factorization.
-*
- CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
- CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB )
-*
- SRNAMT = 'DGELSX'
- CALL DGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
- $ RCOND, CRANK, WORK, INFO )
- IF( INFO.NE.0 )
- $ CALL ALAERH( PATH, 'DGELSX', INFO, 0, ' ', M, N,
- $ NRHS, -1, NB, ITYPE, NFAIL, NERRS,
- $ NOUT )
-*
-* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
-*
-* Test 3: Compute relative error in svd
-* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
-*
- RESULT( 3 ) = DQRT12( CRANK, CRANK, A, LDA, COPYS,
- $ WORK, LWORK )
-*
-* Test 4: Compute error in solution
-* workspace: M*NRHS + M
-*
- CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
- $ LDWORK )
- CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
- $ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 4 ) )
-*
-* Test 5: Check norm of r'*A
-* workspace: NRHS*(M+N)
-*
- RESULT( 5 ) = ZERO
- IF( M.GT.CRANK )
- $ RESULT( 5 ) = DQRT17( 'No transpose', 1, M, N,
- $ NRHS, COPYA, LDA, B, LDB, COPYB,
- $ LDB, C, WORK, LWORK )
-*
-* Test 6: Check if x is in the rowspace of A
-* workspace: (M+NRHS)*(N+2)
-*
- RESULT( 6 ) = ZERO
-*
- IF( N.GT.CRANK )
- $ RESULT( 6 ) = DQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB, WORK,
- $ LWORK )
-*
-* Print information about the tests that did not
-* pass the threshold.
-*
- DO 60 K = 3, 6
- IF( RESULT( K ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
- $ ITYPE, K, RESULT( K )
- NFAIL = NFAIL + 1
- END IF
- 60 CONTINUE
- NRUN = NRUN + 4
-*
* Loop for testing different block sizes.
*
DO 100 INB = 1, NNB
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
-* Test 7: Compute relative error in svd
+* Test 3: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
- RESULT( 7 ) = DQRT12( CRANK, CRANK, A, LDA,
+ RESULT( 3 ) = DQRT12( CRANK, CRANK, A, LDA,
$ COPYS, WORK, LWORK )
*
-* Test 8: Compute error in solution
+* Test 4: Compute error in solution
* workspace: M*NRHS + M
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 8 ) )
+ $ WORK( M*NRHS+1 ), RESULT( 4 ) )
*
-* Test 9: Check norm of r'*A
+* Test 5: Check norm of r'*A
* workspace: NRHS*(M+N)
*
- RESULT( 9 ) = ZERO
+ RESULT( 5 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 9 ) = DQRT17( 'No transpose', 1, M,
+ $ RESULT( 5 ) = DQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 10: Check if x is in the rowspace of A
+* Test 6: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
- RESULT( 10 ) = ZERO
+ RESULT( 6 ) = ZERO
*
IF( N.GT.CRANK )
- $ RESULT( 10 ) = DQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB,
- $ WORK, LWORK )
+ $ RESULT( 6 ) = DQRT14( 'No transpose', M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
*
* Test DGELSS
*
* workspace used: 3*min(m,n) +
* max(2*min(m,n),nrhs,max(m,n))
*
-* Test 11: Compute relative error in svd
+* Test 7: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 11 ) = DASUM( MNMIN, S, 1 ) /
- $ DASUM( MNMIN, COPYS, 1 ) /
- $ ( EPS*DBLE( MNMIN ) )
+ RESULT( 7 ) = DASUM( MNMIN, S, 1 ) /
+ $ DASUM( MNMIN, COPYS, 1 ) /
+ $ ( EPS*DBLE( MNMIN ) )
ELSE
- RESULT( 11 ) = ZERO
+ RESULT( 7 ) = ZERO
END IF
*
-* Test 12: Compute error in solution
+* Test 8: Compute error in solution
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 12 ) )
+ $ WORK( M*NRHS+1 ), RESULT( 8 ) )
*
-* Test 13: Check norm of r'*A
+* Test 9: Check norm of r'*A
*
- RESULT( 13 ) = ZERO
+ RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 13 ) = DQRT17( 'No transpose', 1, M,
- $ N, NRHS, COPYA, LDA, B, LDB,
- $ COPYB, LDB, C, WORK, LWORK )
+ $ RESULT( 9 ) = DQRT17( 'No transpose', 1, M,
+ $ N, NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK, LWORK )
*
-* Test 14: Check if x is in the rowspace of A
+* Test 10: Check if x is in the rowspace of A
*
- RESULT( 14 ) = ZERO
+ RESULT( 10 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 14 ) = DQRT14( 'No transpose', M, N,
+ $ RESULT( 10 ) = DQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
-* Test 15: Compute relative error in svd
+* Test 11: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 15 ) = DASUM( MNMIN, S, 1 ) /
+ RESULT( 11 ) = DASUM( MNMIN, S, 1 ) /
$ DASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*DBLE( MNMIN ) )
ELSE
- RESULT( 15 ) = ZERO
+ RESULT( 11 ) = ZERO
END IF
*
-* Test 16: Compute error in solution
+* Test 12: Compute error in solution
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 16 ) )
+ $ WORK( M*NRHS+1 ), RESULT( 12 ) )
*
-* Test 17: Check norm of r'*A
+* Test 13: Check norm of r'*A
*
- RESULT( 17 ) = ZERO
+ RESULT( 13 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 17 ) = DQRT17( 'No transpose', 1, M,
+ $ RESULT( 13 ) = DQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 18: Check if x is in the rowspace of A
+* Test 14: Check if x is in the rowspace of A
*
- RESULT( 18 ) = ZERO
+ RESULT( 14 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 18 ) = DQRT14( 'No transpose', M, N,
+ $ RESULT( 14 ) = DQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
- DO 90 K = 7, NTESTS
+ DO 90 K = 3, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
*> \verbatim
*>
*> DERRLS tests the error exits for the DOUBLE PRECISION least squares
-*> driver routines (DGELS, SGELSS, SGELSX, SGELSY, SGELSD).
+*> driver routines (DGELS, SGELSS, SGELSY, SGELSD).
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, DGELS, DGELSD, DGELSS, DGELSX,
- $ DGELSY
+ EXTERNAL ALAESM, CHKXER, DGELS, DGELSD, DGELSS, DGELSY
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CALL DGELSS( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 2, INFO )
CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK )
*
-* DGELSX
-*
- SRNAMT = 'DGELSX'
- INFOT = 1
- CALL DGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL DGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL DGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 5
- CALL DGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 7
- CALL DGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
-*
* DGELSY
*
SRNAMT = 'DGELSY'
*>
*> \verbatim
*>
-*> DERRTZ tests the error exits for DTZRQF and STZRZF.
+*> DERRTZ tests the error exits for STZRZF.
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, DTZRQF, DTZRZF
+ EXTERNAL ALAESM, CHKXER, DTZRZF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* Test error exits for the trapezoidal routines.
*
-* DTZRQF
-*
- SRNAMT = 'DTZRQF'
- INFOT = 1
- CALL DTZRQF( -1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL DTZRQF( 1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 4
- CALL DTZRQF( 2, 2, A, 1, TAU, INFO )
- CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK )
-*
* DTZRZF
*
SRNAMT = 'DTZRZF'
+++ /dev/null
-*> \brief \b DTZT01
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* DOUBLE PRECISION FUNCTION DTZT01( M, N, A, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ),
-* $ WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> DTZT01 returns
-*> || A - R*Q || / ( M * eps * ||A|| )
-*> for an upper trapezoidal A that was factored with DTZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] A
-*> \verbatim
-*> A is DOUBLE PRECISION array, dimension (LDA,N)
-*> The original upper trapezoidal M by N matrix A.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is DOUBLE PRECISION array, dimension (LDA,N)
-*> The output of DTZRQF for input matrix A.
-*> The lower triangle is not referenced.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the arrays A and AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is DOUBLE PRECISION array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> DTZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is DOUBLE PRECISION array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The length of the array WORK. LWORK >= m*n + m.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup double_lin
-*
-* =====================================================================
- DOUBLE PRECISION FUNCTION DTZT01( M, N, A, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ),
- $ WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
-* ..
-* .. Local Scalars ..
- INTEGER I, J
- DOUBLE PRECISION NORMA
-* ..
-* .. Local Arrays ..
- DOUBLE PRECISION RWORK( 1 )
-* ..
-* .. External Functions ..
- DOUBLE PRECISION DLAMCH, DLANGE
- EXTERNAL DLAMCH, DLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL DAXPY, DLASET, DLATZM, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DBLE, MAX
-* ..
-* .. Executable Statements ..
-*
- DTZT01 = ZERO
-*
- IF( LWORK.LT.M*N+M ) THEN
- CALL XERBLA( 'DTZT01', 8 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
- NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
-*
-* Copy upper triangle R
-*
- CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
- DO 20 J = 1, M
- DO 10 I = 1, J
- WORK( ( J-1 )*M+I ) = AF( I, J )
- 10 CONTINUE
- 20 CONTINUE
-*
-* R = R * P(1) * ... *P(m)
-*
- DO 30 I = 1, M
- CALL DLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
- $ WORK( M*N+1 ) )
- 30 CONTINUE
-*
-* R = R - A
-*
- DO 40 I = 1, N
- CALL DAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
- 40 CONTINUE
-*
- DTZT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK )
-*
- DTZT01 = DTZT01 / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
- IF( NORMA.NE.ZERO )
- $ DTZT01 = DTZT01 / NORMA
-*
- RETURN
-*
-* End of DTZT01
-*
- END
+++ /dev/null
-*> \brief \b DTZT02
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* DOUBLE PRECISION FUNCTION DTZT02( M, N, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> DTZT02 returns
-*> || I - Q'*Q || / ( M * eps)
-*> where the matrix Q is defined by the Householder transformations
-*> generated by DTZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is DOUBLE PRECISION array, dimension (LDA,N)
-*> The output of DTZRQF.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is DOUBLE PRECISION array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> DTZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is DOUBLE PRECISION array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> length of WORK array. Must be >= N*N+N
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup double_lin
-*
-* =====================================================================
- DOUBLE PRECISION FUNCTION DTZT02( M, N, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
-* ..
-* .. Local Scalars ..
- INTEGER I
-* ..
-* .. Local Arrays ..
- DOUBLE PRECISION RWORK( 1 )
-* ..
-* .. External Functions ..
- DOUBLE PRECISION DLAMCH, DLANGE
- EXTERNAL DLAMCH, DLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL DLASET, DLATZM, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DBLE, MAX
-* ..
-* .. Executable Statements ..
-*
- DTZT02 = ZERO
-*
- IF( LWORK.LT.N*N+N ) THEN
- CALL XERBLA( 'DTZT02', 7 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
-* Q := I
-*
- CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, N )
-*
-* Q := P(1) * ... * P(m) * Q
-*
- DO 10 I = M, 1, -1
- CALL DLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
- 10 CONTINUE
-*
-* Q := P(m) * ... * P(1) * Q
-*
- DO 20 I = 1, M
- CALL DLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
- 20 CONTINUE
-*
-* Q := Q - I
-*
- DO 30 I = 1, N
- WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
- 30 CONTINUE
-*
- DTZT02 = DLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
- $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
- RETURN
-*
-* End of DTZT02
-*
- END
*>
*> \verbatim
*>
-*> SCHKTZ tests STZRQF and STZRZF.
+*> SCHKTZ tests STZRZF.
*> \endverbatim
*
* Arguments:
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
- PARAMETER ( NTESTS = 6 )
+ PARAMETER ( NTESTS = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
- REAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
- EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
+ REAL SLAMCH, SQRT12, SRZT01, SRZT02
+ EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, SERRTZ, SGEQR2, SLACPY, SLAORD,
- $ SLASET, SLATMS, STZRQF, STZRZF
+ $ SLASET, SLATMS, STZRZF
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
-*
- IF( MODE.EQ.0 ) THEN
- CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
- DO 20 I = 1, MNMIN
- S( I ) = ZERO
- 20 CONTINUE
- ELSE
- CALL SLATMS( M, N, 'Uniform', ISEED,
- $ 'Nonsymmetric', S, IMODE,
- $ ONE / EPS, ONE, M, N, 'No packing', A,
- $ LDA, WORK, INFO )
- CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
- $ INFO )
- CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
- $ LDA )
- CALL SLAORD( 'Decreasing', MNMIN, S, 1 )
- END IF
-*
-* Save A and its singular values
-*
- CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
-*
-* Call STZRQF to reduce the upper trapezoidal matrix to
-* upper triangular form.
-*
- SRNAMT = 'STZRQF'
- CALL STZRQF( M, N, A, LDA, TAU, INFO )
-*
-* Compute norm(svd(a) - svd(r))
-*
- RESULT( 1 ) = SQRT12( M, M, A, LDA, S, WORK,
- $ LWORK )
-*
-* Compute norm( A - R*Q )
-*
- RESULT( 2 ) = STZT01( M, N, COPYA, A, LDA, TAU, WORK,
- $ LWORK )
-*
-* Compute norm(Q'*Q - I).
-*
- RESULT( 3 ) = STZT02( M, N, A, LDA, TAU, WORK, LWORK )
-*
-* Test STZRZF
-*
-* Generate test matrix of size m by n using
-* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
*
* Compute norm(svd(a) - svd(r))
*
- RESULT( 4 ) = SQRT12( M, M, A, LDA, S, WORK,
+ RESULT( 1 ) = SQRT12( M, M, A, LDA, S, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
- RESULT( 5 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK,
+ RESULT( 2 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
- RESULT( 6 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK )
+ RESULT( 3 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
- DO 40 K = 1, 6
+ DO 40 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
- NRUN = NRUN + 6
+ NRUN = NRUN + 3
50 CONTINUE
END IF
60 CONTINUE
*>
*> \verbatim
*>
-*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSX,
-*> SGELSY and SGELSD.
+*> SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSY
+*> and SGELSD.
*> \endverbatim
*
* Arguments:
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 18 )
+ PARAMETER ( NTESTS = 14 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
REAL ONE, TWO, ZERO
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SERRLS, SGELS,
- $ SGELSD, SGELSS, SGELSX, SGELSY, SGEMM, SLACPY,
+ $ SGELSD, SGELSS, SGELSY, SGEMM, SLACPY,
$ SLARNV, SQRT13, SQRT15, SQRT16, SSCAL,
$ XLAENV
* ..
*
* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
-* Initialize vector IWORK.
-*
- DO 50 J = 1, N
- IWORK( J ) = 0
- 50 CONTINUE
LDWORK = MAX( 1, M )
*
-* Test SGELSX
-*
-* SGELSX: Compute the minimum-norm solution X
-* to min( norm( A * X - B ) ) using a complete
-* orthogonal factorization.
-*
- CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
- CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB )
-*
- SRNAMT = 'SGELSX'
- CALL SGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
- $ RCOND, CRANK, WORK, INFO )
- IF( INFO.NE.0 )
- $ CALL ALAERH( PATH, 'SGELSX', INFO, 0, ' ', M, N,
- $ NRHS, -1, NB, ITYPE, NFAIL, NERRS,
- $ NOUT )
-*
-* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
-*
-* Test 3: Compute relative error in svd
-* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
-*
- RESULT( 3 ) = SQRT12( CRANK, CRANK, A, LDA, COPYS,
- $ WORK, LWORK )
-*
-* Test 4: Compute error in solution
-* workspace: M*NRHS + M
-*
- CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
- $ LDWORK )
- CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
- $ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 4 ) )
-*
-* Test 5: Check norm of r'*A
-* workspace: NRHS*(M+N)
-*
- RESULT( 5 ) = ZERO
- IF( M.GT.CRANK )
- $ RESULT( 5 ) = SQRT17( 'No transpose', 1, M, N,
- $ NRHS, COPYA, LDA, B, LDB, COPYB,
- $ LDB, C, WORK, LWORK )
-*
-* Test 6: Check if x is in the rowspace of A
-* workspace: (M+NRHS)*(N+2)
-*
- RESULT( 6 ) = ZERO
-*
- IF( N.GT.CRANK )
- $ RESULT( 6 ) = SQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB, WORK,
- $ LWORK )
-*
-* Print information about the tests that did not
-* pass the threshold.
-*
- DO 60 K = 3, 6
- IF( RESULT( K ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
- $ ITYPE, K, RESULT( K )
- NFAIL = NFAIL + 1
- END IF
- 60 CONTINUE
- NRUN = NRUN + 4
-*
* Loop for testing different block sizes.
*
DO 100 INB = 1, NNB
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
-* Test 7: Compute relative error in svd
+* Test 3: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
- RESULT( 7 ) = SQRT12( CRANK, CRANK, A, LDA,
+ RESULT( 3 ) = SQRT12( CRANK, CRANK, A, LDA,
$ COPYS, WORK, LWORK )
*
-* Test 8: Compute error in solution
+* Test 4: Compute error in solution
* workspace: M*NRHS + M
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 8 ) )
+ $ WORK( M*NRHS+1 ), RESULT( 4 ) )
*
-* Test 9: Check norm of r'*A
+* Test 5: Check norm of r'*A
* workspace: NRHS*(M+N)
*
- RESULT( 9 ) = ZERO
+ RESULT( 5 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 9 ) = SQRT17( 'No transpose', 1, M,
+ $ RESULT( 5 ) = SQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 10: Check if x is in the rowspace of A
+* Test 6: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
- RESULT( 10 ) = ZERO
+ RESULT( 6 ) = ZERO
*
IF( N.GT.CRANK )
- $ RESULT( 10 ) = SQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB,
- $ WORK, LWORK )
+ $ RESULT( 6 ) = SQRT14( 'No transpose', M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
*
* Test SGELSS
*
* workspace used: 3*min(m,n) +
* max(2*min(m,n),nrhs,max(m,n))
*
-* Test 11: Compute relative error in svd
+* Test 7: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 11 ) = SASUM( MNMIN, S, 1 ) /
- $ SASUM( MNMIN, COPYS, 1 ) /
- $ ( EPS*REAL( MNMIN ) )
+ RESULT( 7 ) = SASUM( MNMIN, S, 1 ) /
+ $ SASUM( MNMIN, COPYS, 1 ) /
+ $ ( EPS*REAL( MNMIN ) )
ELSE
- RESULT( 11 ) = ZERO
+ RESULT( 7 ) = ZERO
END IF
*
-* Test 12: Compute error in solution
+* Test 8: Compute error in solution
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 12 ) )
+ $ WORK( M*NRHS+1 ), RESULT( 8 ) )
*
-* Test 13: Check norm of r'*A
+* Test 9: Check norm of r'*A
*
- RESULT( 13 ) = ZERO
+ RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 13 ) = SQRT17( 'No transpose', 1, M,
- $ N, NRHS, COPYA, LDA, B, LDB,
- $ COPYB, LDB, C, WORK, LWORK )
+ $ RESULT( 9 ) = SQRT17( 'No transpose', 1, M,
+ $ N, NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK, LWORK )
*
-* Test 14: Check if x is in the rowspace of A
+* Test 10: Check if x is in the rowspace of A
*
- RESULT( 14 ) = ZERO
+ RESULT( 10 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 14 ) = SQRT14( 'No transpose', M, N,
+ $ RESULT( 10 ) = SQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
-* Test 15: Compute relative error in svd
+* Test 11: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 15 ) = SASUM( MNMIN, S, 1 ) /
+ RESULT( 11 ) = SASUM( MNMIN, S, 1 ) /
$ SASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*REAL( MNMIN ) )
ELSE
- RESULT( 15 ) = ZERO
+ RESULT( 11 ) = ZERO
END IF
*
-* Test 16: Compute error in solution
+* Test 12: Compute error in solution
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
- $ WORK( M*NRHS+1 ), RESULT( 16 ) )
+ $ WORK( M*NRHS+1 ), RESULT( 12 ) )
*
-* Test 17: Check norm of r'*A
+* Test 13: Check norm of r'*A
*
- RESULT( 17 ) = ZERO
+ RESULT( 13 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 17 ) = SQRT17( 'No transpose', 1, M,
+ $ RESULT( 13 ) = SQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 18: Check if x is in the rowspace of A
+* Test 14: Check if x is in the rowspace of A
*
- RESULT( 18 ) = ZERO
+ RESULT( 14 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 18 ) = SQRT14( 'No transpose', M, N,
+ $ RESULT( 14 ) = SQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
- DO 90 K = 7, NTESTS
+ DO 90 K = 3, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
*> \verbatim
*>
*> SERRLS tests the error exits for the REAL least squares
-*> driver routines (SGELS, SGELSS, SGELSX, SGELSY, SGELSD).
+*> driver routines (SGELS, SGELSS, SGELSY, SGELSD).
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, SGELS, SGELSD, SGELSS, SGELSX,
- $ SGELSY
+ EXTERNAL ALAESM, CHKXER, SGELS, SGELSD, SGELSS, SGELSY
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CALL SGELSS( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 2, INFO )
CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK )
*
-* SGELSX
-*
- SRNAMT = 'SGELSX'
- INFOT = 1
- CALL SGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL SGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL SGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 5
- CALL SGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 7
- CALL SGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, INFO )
- CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
-*
* SGELSY
*
SRNAMT = 'SGELSY'
*>
*> \verbatim
*>
-*> SERRTZ tests the error exits for STZRQF and STZRZF.
+*> SERRTZ tests the error exits for STZRZF.
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, STZRQF, STZRZF
+ EXTERNAL ALAESM, CHKXER, STZRZF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
* Test error exits for the trapezoidal routines.
*
-* STZRQF
-*
- SRNAMT = 'STZRQF'
- INFOT = 1
- CALL STZRQF( -1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL STZRQF( 1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 4
- CALL STZRQF( 2, 2, A, 1, TAU, INFO )
- CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK )
-*
* STZRZF
*
SRNAMT = 'STZRZF'
+++ /dev/null
-*> \brief \b STZT01
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* REAL FUNCTION STZT01( M, N, A, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* REAL A( LDA, * ), AF( LDA, * ), TAU( * ),
-* $ WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> STZT01 returns
-*> || A - R*Q || / ( M * eps * ||A|| )
-*> for an upper trapezoidal A that was factored with STZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] A
-*> \verbatim
-*> A is REAL array, dimension (LDA,N)
-*> The original upper trapezoidal M by N matrix A.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is REAL array, dimension (LDA,N)
-*> The output of STZRQF for input matrix A.
-*> The lower triangle is not referenced.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the arrays A and AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is REAL array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> STZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is REAL array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The length of the array WORK. LWORK >= m*n + m.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup single_lin
-*
-* =====================================================================
- REAL FUNCTION STZT01( M, N, A, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- REAL A( LDA, * ), AF( LDA, * ), TAU( * ),
- $ WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
-* ..
-* .. Local Scalars ..
- INTEGER I, J
- REAL NORMA
-* ..
-* .. Local Arrays ..
- REAL RWORK( 1 )
-* ..
-* .. External Functions ..
- REAL SLAMCH, SLANGE
- EXTERNAL SLAMCH, SLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL SAXPY, SLATZM, SLASET, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, REAL
-* ..
-* .. Executable Statements ..
-*
- STZT01 = ZERO
-*
- IF( LWORK.LT.M*N+M ) THEN
- CALL XERBLA( 'STZT01', 8 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
- NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
-*
-* Copy upper triangle R
-*
- CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
- DO 20 J = 1, M
- DO 10 I = 1, J
- WORK( ( J-1 )*M+I ) = AF( I, J )
- 10 CONTINUE
- 20 CONTINUE
-*
-* R = R * P(1) * ... *P(m)
-*
- DO 30 I = 1, M
- CALL SLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
- $ WORK( M*N+1 ) )
- 30 CONTINUE
-*
-* R = R - A
-*
- DO 40 I = 1, N
- CALL SAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
- 40 CONTINUE
-*
- STZT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK )
-*
- STZT01 = STZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
- IF( NORMA.NE.ZERO )
- $ STZT01 = STZT01 / NORMA
-*
- RETURN
-*
-* End of STZT01
-*
- END
+++ /dev/null
-*> \brief \b STZT02
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* REAL FUNCTION STZT02( M, N, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* REAL AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> STZT02 returns
-*> || I - Q'*Q || / ( M * eps)
-*> where the matrix Q is defined by the Householder transformations
-*> generated by STZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is REAL array, dimension (LDA,N)
-*> The output of STZRQF.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is REAL array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> STZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is REAL array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> length of WORK array. Must be >= N*N+N
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup single_lin
-*
-* =====================================================================
- REAL FUNCTION STZT02( M, N, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- REAL AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
-* ..
-* .. Local Scalars ..
- INTEGER I
-* ..
-* .. Local Arrays ..
- REAL RWORK( 1 )
-* ..
-* .. External Functions ..
- REAL SLAMCH, SLANGE
- EXTERNAL SLAMCH, SLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL SLATZM, SLASET, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, REAL
-* ..
-* .. Executable Statements ..
-*
- STZT02 = ZERO
-*
- IF( LWORK.LT.N*N+N ) THEN
- CALL XERBLA( 'STZT02', 7 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
-* Q := I
-*
- CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, N )
-*
-* Q := P(1) * ... * P(m) * Q
-*
- DO 10 I = M, 1, -1
- CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
- 10 CONTINUE
-*
-* Q := P(m) * ... * P(1) * Q
-*
- DO 20 I = 1, M
- CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
- 20 CONTINUE
-*
-* Q := Q - I
-*
- DO 30 I = 1, N
- WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
- 30 CONTINUE
-*
- STZT02 = SLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
- $ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
- RETURN
-*
-* End of STZT02
-*
- END
*>
*> \verbatim
*>
-*> ZCHKTZ tests ZTZRQF and ZTZRZF.
+*> ZCHKTZ tests ZTZRZF.
*> \endverbatim
*
* Arguments:
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
- PARAMETER ( NTESTS = 6 )
+ PARAMETER ( NTESTS = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
- DOUBLE PRECISION DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02
- EXTERNAL DLAMCH, ZQRT12, ZRZT01, ZRZT02, ZTZT01, ZTZT02
+ DOUBLE PRECISION DLAMCH, ZQRT12, ZRZT01, ZRZT02
+ EXTERNAL DLAMCH, ZQRT12, ZRZT01, ZRZT02
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DLAORD, ZERRTZ, ZGEQR2, ZLACPY,
- $ ZLASET, ZLATMS, ZTZRQF, ZTZRZF
+ $ ZLASET, ZLATMS, ZTZRZF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCMPLX, MAX, MIN
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
-*
- IF( MODE.EQ.0 ) THEN
- CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ),
- $ DCMPLX( ZERO ), A, LDA )
- DO 20 I = 1, MNMIN
- S( I ) = ZERO
- 20 CONTINUE
- ELSE
- CALL ZLATMS( M, N, 'Uniform', ISEED,
- $ 'Nonsymmetric', S, IMODE,
- $ ONE / EPS, ONE, M, N, 'No packing', A,
- $ LDA, WORK, INFO )
- CALL ZGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
- $ INFO )
- CALL ZLASET( 'Lower', M-1, N, DCMPLX( ZERO ),
- $ DCMPLX( ZERO ), A( 2 ), LDA )
- CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
- END IF
-*
-* Save A and its singular values
-*
- CALL ZLACPY( 'All', M, N, A, LDA, COPYA, LDA )
-*
-* Call ZTZRQF to reduce the upper trapezoidal matrix to
-* upper triangular form.
-*
- SRNAMT = 'ZTZRQF'
- CALL ZTZRQF( M, N, A, LDA, TAU, INFO )
-*
-* Compute norm(svd(a) - svd(r))
-*
- RESULT( 1 ) = ZQRT12( M, M, A, LDA, S, WORK,
- $ LWORK, RWORK )
-*
-* Compute norm( A - R*Q )
-*
- RESULT( 2 ) = ZTZT01( M, N, COPYA, A, LDA, TAU, WORK,
- $ LWORK )
-*
-* Compute norm(Q'*Q - I).
-*
- RESULT( 3 ) = ZTZT02( M, N, A, LDA, TAU, WORK, LWORK )
-*
-* Test ZTZRZF
-*
-* Generate test matrix of size m by n using
-* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ),
*
* Compute norm(svd(a) - svd(r))
*
- RESULT( 4 ) = ZQRT12( M, M, A, LDA, S, WORK,
+ RESULT( 1 ) = ZQRT12( M, M, A, LDA, S, WORK,
$ LWORK, RWORK )
*
* Compute norm( A - R*Q )
*
- RESULT( 5 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK,
+ RESULT( 2 ) = ZRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
- RESULT( 6 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK )
+ RESULT( 3 ) = ZRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
- DO 40 K = 1, 6
+ DO 40 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
- NRUN = NRUN + 6
+ NRUN = NRUN + 3
50 CONTINUE
END IF
60 CONTINUE
*>
*> \verbatim
*>
-*> ZDRVLS tests the least squares driver routines ZGELS, CGELSX, CGELSS,
-*> ZGELSY and CGELSD.
+*> ZDRVLS tests the least squares driver routines ZGELS, CGELSS, ZGELSY
+*> and CGELSD.
*> \endverbatim
*
* Arguments:
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 18 )
+ PARAMETER ( NTESTS = 14 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
DOUBLE PRECISION ONE, ZERO
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DLASRT, XLAENV,
- $ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS, ZGELSX,
+ $ ZDSCAL, ZERRLS, ZGELS, ZGELSD, ZGELSS,
$ ZGELSY, ZGEMM, ZLACPY, ZLARNV, ZQRT13, ZQRT15,
$ ZQRT16
* ..
*
* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
- DO 50 J = 1, N
- IWORK( J ) = 0
- 50 CONTINUE
LDWORK = MAX( 1, M )
*
-* Test ZGELSX
-*
-* ZGELSX: Compute the minimum-norm solution X
-* to min( norm( A * X - B ) )
-* using a complete orthogonal factorization.
-*
- CALL ZLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
- CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB )
-*
- SRNAMT = 'ZGELSX'
- CALL ZGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
- $ RCOND, CRANK, WORK, RWORK, INFO )
-*
- IF( INFO.NE.0 )
- $ CALL ALAERH( PATH, 'ZGELSX', INFO, 0, ' ', M, N,
- $ NRHS, -1, NB, ITYPE, NFAIL, NERRS,
- $ NOUT )
-*
-* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
-*
-* Test 3: Compute relative error in svd
-* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
-*
- RESULT( 3 ) = ZQRT12( CRANK, CRANK, A, LDA, COPYS,
- $ WORK, LWORK, RWORK )
-*
-* Test 4: Compute error in solution
-* workspace: M*NRHS + M
-*
- CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
- $ LDWORK )
- CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA,
- $ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 4 ) )
-*
-* Test 5: Check norm of r'*A
-* workspace: NRHS*(M+N)
-*
- RESULT( 5 ) = ZERO
- IF( M.GT.CRANK )
- $ RESULT( 5 ) = ZQRT17( 'No transpose', 1, M, N,
- $ NRHS, COPYA, LDA, B, LDB, COPYB,
- $ LDB, C, WORK, LWORK )
-*
-* Test 6: Check if x is in the rowspace of A
-* workspace: (M+NRHS)*(N+2)
-*
- RESULT( 6 ) = ZERO
-*
- IF( N.GT.CRANK )
- $ RESULT( 6 ) = ZQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB, WORK,
- $ LWORK )
-*
-* Print information about the tests that did not
-* pass the threshold.
-*
- DO 60 K = 3, 6
- IF( RESULT( K ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9998 )M, N, NRHS, 0,
- $ ITYPE, K, RESULT( K )
- NFAIL = NFAIL + 1
- END IF
- 60 CONTINUE
- NRUN = NRUN + 4
-*
* Loop for testing different block sizes.
*
DO 90 INB = 1, NNB
*
* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS)
*
-* Test 7: Compute relative error in svd
+* Test 3: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
- RESULT( 7 ) = ZQRT12( CRANK, CRANK, A, LDA,
+ RESULT( 3 ) = ZQRT12( CRANK, CRANK, A, LDA,
$ COPYS, WORK, LWORK, RWORK )
*
-* Test 8: Compute error in solution
+* Test 4: Compute error in solution
* workspace: M*NRHS + M
*
CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 8 ) )
+ $ RESULT( 4 ) )
*
-* Test 9: Check norm of r'*A
+* Test 5: Check norm of r'*A
* workspace: NRHS*(M+N)
*
- RESULT( 9 ) = ZERO
+ RESULT( 5 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 9 ) = ZQRT17( 'No transpose', 1, M,
+ $ RESULT( 5 ) = ZQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 10: Check if x is in the rowspace of A
+* Test 6: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
- RESULT( 10 ) = ZERO
+ RESULT( 6 ) = ZERO
*
IF( N.GT.CRANK )
- $ RESULT( 10 ) = ZQRT14( 'No transpose', M, N,
- $ NRHS, COPYA, LDA, B, LDB,
- $ WORK, LWORK )
+ $ RESULT( 6 ) = ZQRT14( 'No transpose', M, N,
+ $ NRHS, COPYA, LDA, B, LDB,
+ $ WORK, LWORK )
*
* Test ZGELSS
*
* workspace used: 3*min(m,n) +
* max(2*min(m,n),nrhs,max(m,n))
*
-* Test 11: Compute relative error in svd
+* Test 7: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 11 ) = DASUM( MNMIN, S, 1 ) /
- $ DASUM( MNMIN, COPYS, 1 ) /
- $ ( EPS*DBLE( MNMIN ) )
+ RESULT( 7 ) = DASUM( MNMIN, S, 1 ) /
+ $ DASUM( MNMIN, COPYS, 1 ) /
+ $ ( EPS*DBLE( MNMIN ) )
ELSE
- RESULT( 11 ) = ZERO
+ RESULT( 7 ) = ZERO
END IF
*
-* Test 12: Compute error in solution
+* Test 8: Compute error in solution
*
CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 12 ) )
+ $ RESULT( 8 ) )
*
-* Test 13: Check norm of r'*A
+* Test 9: Check norm of r'*A
*
- RESULT( 13 ) = ZERO
+ RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 13 ) = ZQRT17( 'No transpose', 1, M,
- $ N, NRHS, COPYA, LDA, B, LDB,
- $ COPYB, LDB, C, WORK, LWORK )
+ $ RESULT( 9 ) = ZQRT17( 'No transpose', 1, M,
+ $ N, NRHS, COPYA, LDA, B, LDB,
+ $ COPYB, LDB, C, WORK, LWORK )
*
-* Test 14: Check if x is in the rowspace of A
+* Test 10: Check if x is in the rowspace of A
*
- RESULT( 14 ) = ZERO
+ RESULT( 10 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 14 ) = ZQRT14( 'No transpose', M, N,
+ $ RESULT( 10 ) = ZQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
-* Test 15: Compute relative error in svd
+* Test 11: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
- RESULT( 15 ) = DASUM( MNMIN, S, 1 ) /
+ RESULT( 11 ) = DASUM( MNMIN, S, 1 ) /
$ DASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*DBLE( MNMIN ) )
ELSE
- RESULT( 15 ) = ZERO
+ RESULT( 11 ) = ZERO
END IF
*
-* Test 16: Compute error in solution
+* Test 12: Compute error in solution
*
CALL ZLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL ZQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK, RWORK,
- $ RESULT( 16 ) )
+ $ RESULT( 12 ) )
*
-* Test 17: Check norm of r'*A
+* Test 13: Check norm of r'*A
*
- RESULT( 17 ) = ZERO
+ RESULT( 13 ) = ZERO
IF( M.GT.CRANK )
- $ RESULT( 17 ) = ZQRT17( 'No transpose', 1, M,
+ $ RESULT( 13 ) = ZQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
-* Test 18: Check if x is in the rowspace of A
+* Test 14: Check if x is in the rowspace of A
*
- RESULT( 18 ) = ZERO
+ RESULT( 14 ) = ZERO
IF( N.GT.CRANK )
- $ RESULT( 18 ) = ZQRT14( 'No transpose', M, N,
+ $ RESULT( 14 ) = ZQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
- DO 80 K = 7, NTESTS
+ DO 80 K = 3, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
*> \verbatim
*>
*> ZERRLS tests the error exits for the COMPLEX*16 least squares
-*> driver routines (ZGELS, CGELSS, CGELSX, CGELSY, CGELSD).
+*> driver routines (ZGELS, CGELSS, CGELSY, CGELSD).
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, ZGELS, ZGELSD, ZGELSS, ZGELSX,
- $ ZGELSY
+ EXTERNAL ALAESM, CHKXER, ZGELS, ZGELSD, ZGELSS, ZGELSY
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ INFO )
CALL CHKXER( 'ZGELSS', INFOT, NOUT, LERR, OK )
*
-* ZGELSX
-*
- SRNAMT = 'ZGELSX'
- INFOT = 1
- CALL ZGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL ZGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL ZGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 5
- CALL ZGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK )
- INFOT = 7
- CALL ZGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, RW,
- $ INFO )
- CALL CHKXER( 'ZGELSX', INFOT, NOUT, LERR, OK )
-*
* ZGELSY
*
SRNAMT = 'ZGELSY'
*>
*> \verbatim
*>
-*> ZERRTZ tests the error exits for ZTZRQF and ZTZRZF.
+*> ZERRTZ tests the error exits for ZTZRZF.
*> \endverbatim
*
* Arguments:
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, ZTZRQF, ZTZRZF
+ EXTERNAL ALAESM, CHKXER, ZTZRZF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
OK = .TRUE.
*
* Test error exits for the trapezoidal routines.
-*
WRITE( NOUT, FMT = * )
IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
-* ZTZRQF
-*
- SRNAMT = 'ZTZRQF'
- INFOT = 1
- CALL ZTZRQF( -1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'ZTZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL ZTZRQF( 1, 0, A, 1, TAU, INFO )
- CALL CHKXER( 'ZTZRQF', INFOT, NOUT, LERR, OK )
- INFOT = 4
- CALL ZTZRQF( 2, 2, A, 1, TAU, INFO )
- CALL CHKXER( 'ZTZRQF', INFOT, NOUT, LERR, OK )
*
* ZTZRZF
*
+++ /dev/null
-*> \brief \b ZTZT01
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* DOUBLE PRECISION FUNCTION ZTZT01( M, N, A, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ),
-* $ WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> ZTZT01 returns
-*> || A - R*Q || / ( M * eps * ||A|| )
-*> for an upper trapezoidal A that was factored with ZTZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrices A and AF.
-*> \endverbatim
-*>
-*> \param[in] A
-*> \verbatim
-*> A is COMPLEX*16 array, dimension (LDA,N)
-*> The original upper trapezoidal M by N matrix A.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is COMPLEX*16 array, dimension (LDA,N)
-*> The output of ZTZRQF for input matrix A.
-*> The lower triangle is not referenced.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the arrays A and AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is COMPLEX*16 array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> ZTZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is COMPLEX*16 array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> The length of the array WORK. LWORK >= m*n + m.
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup complex16_lin
-*
-* =====================================================================
- DOUBLE PRECISION FUNCTION ZTZT01( M, N, A, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ),
- $ WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
-* ..
-* .. Local Scalars ..
- INTEGER I, J
- DOUBLE PRECISION NORMA
-* ..
-* .. Local Arrays ..
- DOUBLE PRECISION RWORK( 1 )
-* ..
-* .. External Functions ..
- DOUBLE PRECISION DLAMCH, ZLANGE
- EXTERNAL DLAMCH, ZLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZAXPY, ZLASET, ZLATZM
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DBLE, DCMPLX, MAX
-* ..
-* .. Executable Statements ..
-*
- ZTZT01 = ZERO
-*
- IF( LWORK.LT.M*N+M ) THEN
- CALL XERBLA( 'ZTZT01', 8 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
- NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RWORK )
-*
-* Copy upper triangle R
-*
- CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK,
- $ M )
- DO 20 J = 1, M
- DO 10 I = 1, J
- WORK( ( J-1 )*M+I ) = AF( I, J )
- 10 CONTINUE
- 20 CONTINUE
-*
-* R = R * P(1) * ... *P(m)
-*
- DO 30 I = 1, M
- CALL ZLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
- $ WORK( M*N+1 ) )
- 30 CONTINUE
-*
-* R = R - A
-*
- DO 40 I = 1, N
- CALL ZAXPY( M, DCMPLX( -ONE ), A( 1, I ), 1,
- $ WORK( ( I-1 )*M+1 ), 1 )
- 40 CONTINUE
-*
- ZTZT01 = ZLANGE( 'One-norm', M, N, WORK, M, RWORK )
-*
- ZTZT01 = ZTZT01 / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
- IF( NORMA.NE.ZERO )
- $ ZTZT01 = ZTZT01 / NORMA
-*
- RETURN
-*
-* End of ZTZT01
-*
- END
+++ /dev/null
-*> \brief \b ZTZT02
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-* Definition:
-* ===========
-*
-* DOUBLE PRECISION FUNCTION ZTZT02( M, N, AF, LDA, TAU, WORK,
-* LWORK )
-*
-* .. Scalar Arguments ..
-* INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
-* COMPLEX*16 AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> ZTZT02 returns
-*> || I - Q'*Q || / ( M * eps)
-*> where the matrix Q is defined by the Householder transformations
-*> generated by ZTZRQF.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] M
-*> \verbatim
-*> M is INTEGER
-*> The number of rows of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The number of columns of the matrix AF.
-*> \endverbatim
-*>
-*> \param[in] AF
-*> \verbatim
-*> AF is COMPLEX*16 array, dimension (LDA,N)
-*> The output of ZTZRQF.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array AF.
-*> \endverbatim
-*>
-*> \param[in] TAU
-*> \verbatim
-*> TAU is COMPLEX*16 array, dimension (M)
-*> Details of the Householder transformations as returned by
-*> ZTZRQF.
-*> \endverbatim
-*>
-*> \param[out] WORK
-*> \verbatim
-*> WORK is COMPLEX*16 array, dimension (LWORK)
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER
-*> length of WORK array. Must be >= N*N+N
-*> \endverbatim
-*
-* Authors:
-* ========
-*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date November 2011
-*
-*> \ingroup complex16_lin
-*
-* =====================================================================
- DOUBLE PRECISION FUNCTION ZTZT02( M, N, AF, LDA, TAU, WORK,
- $ LWORK )
-*
-* -- LAPACK test 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 ..
- INTEGER LDA, LWORK, M, N
-* ..
-* .. Array Arguments ..
- COMPLEX*16 AF( LDA, * ), TAU( * ), WORK( LWORK )
-* ..
-*
-* =====================================================================
-*
-* .. Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
-* ..
-* .. Local Scalars ..
- INTEGER I
-* ..
-* .. Local Arrays ..
- DOUBLE PRECISION RWORK( 1 )
-* ..
-* .. External Functions ..
- DOUBLE PRECISION DLAMCH, ZLANGE
- EXTERNAL DLAMCH, ZLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZLASET, ZLATZM
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DBLE, DCMPLX, DCONJG, MAX
-* ..
-* .. Executable Statements ..
-*
- ZTZT02 = ZERO
-*
- IF( LWORK.LT.N*N+N ) THEN
- CALL XERBLA( 'ZTZT02', 7 )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.LE.0 .OR. N.LE.0 )
- $ RETURN
-*
-* Q := I
-*
- CALL ZLASET( 'Full', N, N, DCMPLX( ZERO ), DCMPLX( ONE ), WORK,
- $ N )
-*
-* Q := P(1) * ... * P(m) * Q
-*
- DO 10 I = M, 1, -1
- CALL ZLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
- $ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
- 10 CONTINUE
-*
-* Q := P(m)' * ... * P(1)' * Q
-*
- DO 20 I = 1, M
- CALL ZLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA,
- $ DCONJG( TAU( I ) ), WORK( I ), WORK( M+1 ), N,
- $ WORK( N*N+1 ) )
- 20 CONTINUE
-*
-* Q := Q - I
-*
- DO 30 I = 1, N
- WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
- 30 CONTINUE
-*
- ZTZT02 = ZLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
- $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
- RETURN
-*
-* End of ZTZT02
-*
- END
40 40 2 2 Values of NBCOL (minimum col. dimension)
20.0 Threshold value
T Put T to test the LAPACK routines
-T Put T to test the driver routines
+F Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
CGG 26
40 40 2 2 Values of NBCOL (minimum col. dimension)
20.0 Threshold value
T Put T to test the LAPACK routines
-T Put T to test the driver routines
+F Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
DGG 26
40 40 2 2 Values of NBCOL (minimum col. dimension)
20.0 Threshold value
T Put T to test the LAPACK routines
-T Put T to test the driver routines
+F Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SGG 26
40 40 2 2 Values of NBCOL (minimum col. dimension)
20.0 Threshold value
T Put T to test the LAPACK routines
-T Put T to test the driver routines
+F Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
ZGG 26
projects / platform / upstream / lapack.git / commitdiff