diff options
| author | julielangou <julie@cs.utk.edu> | 2016-11-19 14:40:33 -0800 |
|---|---|---|
| committer | GitHub <noreply@github.com> | 2016-11-19 14:40:33 -0800 |
| commit | 01cdfedf1d726a003f7a4e7331f32a7e434f1707 (patch) | |
| tree | 4a9ff4318f5a1d66a4dc2690d9dc5ccb242981a3 /TESTING | |
| parent | ead2c73f1a6dad1342bf32987c0b2f2eaf61f18a (diff) | |
| parent | ae36f785d68d637ef0a60f9028c38eb2d369d9f1 (diff) | |
Merge pull request #83 from haidarazzam/master
adding the 2stage symmetric eigenvalue routines drivers checking
Diffstat (limited to 'TESTING')
28 files changed, 29837 insertions, 74 deletions
diff --git a/TESTING/EIG/Makefile b/TESTING/EIG/Makefile index 6811cc2c..413e2359 100644 --- a/TESTING/EIG/Makefile +++ b/TESTING/EIG/Makefile @@ -51,11 +51,11 @@ SCIGTST = slafts.o slahd2.o slasum.o slatb9.o sstech.o sstect.o \ SEIGTST = schkee.o \ sbdt01.o sbdt02.o sbdt03.o sbdt04.o sbdt05.o\ schkbb.o schkbd.o schkbk.o schkbl.o schkec.o \ - schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o \ + schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o schkst2stg.o schksb2stg.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 sdrvsg.o \ - sdrvst.o sdrvsx.o sdrvvx.o \ + sdrvbd.o sdrves.o sdrvev.o sdrvsg.o sdrvsg2stg.o \ + sdrvst.o sdrvst2stg.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 \ sget32.o sget33.o sget34.o sget35.o sget36.o \ @@ -68,11 +68,11 @@ SEIGTST = schkee.o \ CEIGTST = cchkee.o \ cbdt01.o cbdt02.o cbdt03.o cbdt05.o\ cchkbb.o cchkbd.o cchkbk.o cchkbl.o cchkec.o \ - cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o \ + cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o cchkst2stg.o cchkhb2stg.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 cdrvsg.o \ - cdrvst.o cdrvsx.o cdrvvx.o \ + cdrvbd.o cdrves.o cdrvev.o cdrvsg.o cdrvsg2stg.o \ + cdrvst.o cdrvst2stg.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 \ cget35.o cget36.o cget37.o cget38.o cget51.o cget52.o \ @@ -88,11 +88,11 @@ DZIGTST = dlafts.o dlahd2.o dlasum.o dlatb9.o dstech.o dstect.o \ DEIGTST = dchkee.o \ dbdt01.o dbdt02.o dbdt03.o dbdt04.o dbdt05.o\ dchkbb.o dchkbd.o dchkbk.o dchkbl.o dchkec.o \ - dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o \ + dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o dchkst2stg.o dchksb2stg.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 ddrvsg.o \ - ddrvst.o ddrvsx.o ddrvvx.o \ + ddrvbd.o ddrves.o ddrvev.o ddrvsg.o ddrvsg2stg.o \ + ddrvst.o ddrvst2stg.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 \ dget32.o dget33.o dget34.o dget35.o dget36.o \ @@ -105,11 +105,11 @@ DEIGTST = dchkee.o \ ZEIGTST = zchkee.o \ zbdt01.o zbdt02.o zbdt03.o zbdt05.o\ zchkbb.o zchkbd.o zchkbk.o zchkbl.o zchkec.o \ - zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o \ + zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o zchkst2stg.o zchkhb2stg.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 zdrvsg.o \ - zdrvst.o zdrvsx.o zdrvvx.o \ + zdrvbd.o zdrves.o zdrvev.o zdrvsg.o zdrvsg2stg.o \ + zdrvst.o zdrvst2stg.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 \ zget35.o zget36.o zget37.o zget38.o zget51.o zget52.o \ diff --git a/TESTING/EIG/cchkee.f b/TESTING/EIG/cchkee.f index d5f3f729..2fd530f6 100644 --- a/TESTING/EIG/cchkee.f +++ b/TESTING/EIG/cchkee.f @@ -1102,7 +1102,8 @@ $ CDRGEV, CDRGSX, CDRGVX, CDRVBD, CDRVES, CDRVEV, $ CDRVSG, CDRVST, CDRVSX, CDRVVX, CERRBD, $ CERRED, CERRGG, CERRHS, CERRST, ILAVER, XLAENV, - $ CDRGES3, CDRGEV3 + $ CDRGES3, CDRGEV3, + $ CCHKST2STG, CDRVST2STG, CCHKHB2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1149,7 +1150,7 @@ PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'CHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'CST' ) .OR. - $ LSAMEN( 3, PATH, 'CSG' ) + $ LSAMEN( 3, PATH, 'CSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'CBD' ) CEV = LSAMEN( 3, PATH, 'CEV' ) CES = LSAMEN( 3, PATH, 'CES' ) @@ -1829,7 +1830,8 @@ $ WRITE( NOUT, FMT = 9980 )'CCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'CST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'CST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1859,6 +1861,17 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL CCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), + $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), + $ DR( 1, 4 ), DR( 1, 5 ), DR( 1, 6 ), + $ DR( 1, 7 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), DR( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), + $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) + ELSE CALL CCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), @@ -1868,16 +1881,26 @@ $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, $ RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL CDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL CDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT, - $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), - $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), - $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), - $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) + $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRVST', INFO END IF @@ -1910,12 +1933,18 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL CDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, - $ INFO ) +* CALL CDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, +* $ INFO ) + CALL CDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ DR( 1, 3 ), DR( 1, 4 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, RWORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRVSG', INFO END IF @@ -2278,10 +2307,15 @@ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL CERRST( 'CHB', NOUT ) - CALL CCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, - $ INFO ) +* CALL CCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, +* $ INFO ) + CALL CCHKHB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), + $ DR( 1, 2 ), DR( 1, 3 ), DR( 1, 4 ), DR( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, + $ INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CCHKHB', INFO * diff --git a/TESTING/EIG/cchkhb2stg.f b/TESTING/EIG/cchkhb2stg.f new file mode 100644 index 00000000..d4aba4b9 --- /dev/null +++ b/TESTING/EIG/cchkhb2stg.f @@ -0,0 +1,880 @@ +*> \brief \b CCHKHBSTG +* +* @generated from zchkhb2stg.f, fortran z -> c, Sun Nov 6 00:22:35 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHBSTG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RWORK RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ) +* COMPLEX A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHBSTG tests the reduction of a Hermitian band matrix to tridiagonal +*> from, used with the Hermitian eigenvalue problem. +*> +*> CHBTRD factors a Hermitian band matrix A as U S U* , where * means +*> conjugate transpose, S is symmetric tridiagonal, and U is unitary. +*> CHBTRD can use either just the lower or just the upper triangle +*> of A; CCHKHBSTG checks both cases. +*> +*> CHETRD_HB2ST factors a Hermitian band matrix A as U S U* , +*> where * means conjugate transpose, S is symmetric tridiagonal, and U is +*> unitary. CHETRD_HB2ST can use either just the lower or just +*> the upper triangle of A; CCHKHBSTG checks both cases. +*> +*> DSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSBTRD "U" (used as reference for DSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "L". +*> +*> When CCHKHBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the hermitian banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with +*> UPLO='U' +*> +*> (2) | I - UU* | / ( n ulp ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with +*> UPLO='L' +*> +*> (4) | I - UU* | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D2 is computed by +*> CHETRD_HB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D3 is computed by +*> CHETRD_HB2ST with UPLO='L' +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CCHKHBSTG 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] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> CCHKHBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. 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, CCHKHBSTG +*> 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 CCHKHBSTG 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] 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 matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by CHBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by CHBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX array, dimension (LDU, max(NN)) +*> Used to hold the unitary matrix computed by CHBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \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( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (4) +*> 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 +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 CCHKHB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, 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, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + REAL RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ) + COMPLEX A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, + $ TEN = 10.0E+0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS, + $ NMATS, NMAX, NTEST, NTESTT + REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SLASUM, XERBLA, CHBT21, CHBTRD, CLACPY, CLASET, + $ CLATMR, CLATMS, CHBTRD_HB2ST, CSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CCHKHBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, WORK, + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call CHBTRD to compute S and U from upper triangle. +* + CALL CLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL CHBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL CHBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 1 ) ) +* +* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofDSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the DSBTRD and used as reference to compare +* with the DSYTRD_SB2ST routine +* +* Compute D1 from the DSBTRD and used as reference for the +* DSYTRD_SB2ST +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D1, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* DSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL CHETRD_HB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the DSYTRD_SB2ST Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = CONJG( A( K+1-JR, JC+JR ) ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call CHBTRD to compute S and U from lower triangle +* + CALL CLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL CHBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL CHBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 3 ) ) +* +* DSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL CHETRD_HB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D3, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 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 = 9998 )'CHB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 )'unitary', '*', + $ 'conjugate transpose', ( '*', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL SLASUM( 'CHB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' CCHKHBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( / 1X, A3, + $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines' + $ ) + 9997 FORMAT( ' Matrix types (see SCHK23 for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of CCHKHBSTG +* + END diff --git a/TESTING/EIG/cchkst2stg.f b/TESTING/EIG/cchkst2stg.f new file mode 100644 index 00000000..84bf432a --- /dev/null +++ b/TESTING/EIG/cchkst2stg.f @@ -0,0 +1,2145 @@ +*> \brief \b CCHKST2STG +* +* @generated from zchkst2stg.f, fortran z -> c, Fri Nov 4 15:45:07 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), +* $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), +* $ WA1( * ), WA2( * ), WA3( * ), WR( * ) +* COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKST2STG checks the Hermitian eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> CHETRD. For that, we call the standard CHETRD and compute D1 using +*> DSTEQR, then we call the 2-stage CHETRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using DSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the CCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> CHETRD factors A as U S U* , where * means conjugate transpose, +*> S is real symmetric tridiagonal, and U is unitary. +*> CHETRD can use either just the lower or just the upper triangle +*> of A; CCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> CHPTRD does the same as CHETRD, except that A and V are stored +*> in "packed" format. +*> +*> CUNGTR constructs the matrix U from the contents of V and TAU. +*> +*> CUPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> CSTEQR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> SSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> CPTEQR factors S as Z4 D4 Z4* , for a +*> Hermitian positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> SSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> CSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> CSTEDC factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input unitary matrix, usually the output +*> from CHETRD/CUNGTR or CHPTRD/CUPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> CSTEMR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). CSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When CCHKST2STG 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 Hermitian eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='U', ... ) +*> +*> (2) | I - UV* | / ( n ulp ) CUNGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> CHETRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via DSTEQR('N',...) +*> +*> (4) | I - UV* | / ( n ulp ) CUNGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> CHETRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via DSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for CHPTRD and CUPGTR. +*> +*> (9) | S - Z D Z* | / ( |S| n ulp ) CSTEQR('V',...) +*> +*> (10) | I - ZZ* | / ( n ulp ) CSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) CSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) SSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> SSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) CPTEQR('V',...) +*> +*> (15) | I - Z4 Z4* | / ( n ulp ) CPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) CPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y* | / ( |S| n ulp ) SSTEBZ, CSTEIN +*> +*> (21) | I - Y Y* | / ( n ulp ) SSTEBZ, CSTEIN +*> +*> (22) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('I') +*> +*> (23) | I - ZZ* | / ( n ulp ) CSTEDC('I') +*> +*> (24) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('V') +*> +*> (25) | I - ZZ* | / ( n ulp ) CSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) CSTEDC('V') and +*> CSTEDC('N') +*> +*> Test 27 is disabled at the moment because CSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> CSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> CSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because CSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'I') +*> +*> (30) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> CSTEMR('N', 'I') vs. CSTEMR('V', 'I') +*> +*> (32) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'V') +*> +*> (33) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> CSTEMR('N', 'V') vs. CSTEMR('V', 'V') +*> +*> (35) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'A') +*> +*> (36) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> CSTEMR('N', 'A') vs. CSTEMR('V', 'A') +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CCHKST2STG 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, CCHKST2STG +*> 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 CCHKST2STG 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] 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 of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is COMPLEX array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by CHETRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> CHETRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CPTEQR(V). +*> CPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by CPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix computed by CHETRD + CUNGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by CHETRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in CHETRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as CUNGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is COMPLEX array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array of +*> dimension( max(NN) ) +*> The Householder factors computed by CHETRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix of eigenvectors computed by CSTEQR, +*> CPTEQR, and CSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The number of entries in LRWORK (dimension( ??? ) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (26) +*> 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 +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If CLATMR, CLATMS, CHETRD, CUNGTR, CSTEQR, SSTERF, +*> or CUNMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 CCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), + $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ WA1( * ), WA2( * ), WA3( * ), WR( * ) + COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL CRANGE + PARAMETER ( CRANGE = .FALSE. ) + LOGICAL CREL + PARAMETER ( CREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP, + $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN, + $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3, + $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX, + $ NSPLIT, NTEST, NTESTT, LH, LW + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + REAL DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLABAD, SLASUM, SSTEBZ, SSTECH, SSTERF, + $ XERBLA, CCOPY, CHET21, CHETRD, CHPT21, CHPTRD, + $ CLACPY, CLASET, CLATMR, CLATMS, CPTEQR, CSTEDC, + $ CSTEMR, CSTEIN, CSTEQR, CSTT21, CSTT22, CUNGTR, + $ CUPGTR, CHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'CHETRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LRWEDC = 1 + 3*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LRWEDC = 7 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) + TEMP2 = SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF*TEMP2 ) THEN + A( I-1, I ) = A( I-1, I )* + $ ( HALF*TEMP2 / ( UNFL+TEMP1 ) ) + A( I, I-1 ) = CONJG( A( I-1, I ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call CHETRD and CUNGTR to compute S and U from +* upper triangle. +* + CALL CLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL CHETRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHETRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL CUNGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUNGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL CHET21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 1 ) ) + CALL CHET21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL CSTEQR( 'N', N, D1, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( 'U', N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL CHETRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 3 + CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL CLACPY( 'L', N, N, A, LDA, V, LDU ) + CALL CHETRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 4 + CALL CSTEQR( 'N', N, D3, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Skip the DSYTRD for lower that since we replaced its testing +* 3 and 4 by the 2-stage one. + GOTO 101 +* +* Call CHETRD and CUNGTR to compute S and U from +* lower triangle, do tests. +* + CALL CLACPY( 'L', N, N, A, LDA, V, LDU ) +* + NTEST = 3 + CALL CHETRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHETRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CLACPY( 'L', N, N, V, LDU, U, LDU ) +* + NTEST = 4 + CALL CUNGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUNGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CHET21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 3 ) ) + CALL CHET21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 4 ) ) +* +*after skipping old tests 3 4 back to the normal +* + 101 CONTINUE +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call CHPTRD and CUPGTR to compute S and U from AP +* + CALL CCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL CHPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL CUPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL CHPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 5 ) ) + CALL CHPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call CHPTRD and CUPGTR to compute S and U from AP +* + CALL CCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL CHPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL CUPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CUPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CHPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 7 ) ) + CALL CHPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 8 ) ) +* +* Call CSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 9 + CALL CSTEQR( 'V', N, D1, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 11 + CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 12 + CALL SSTERF( N, D3, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL SSTECH( N, SD, SE, D1, TEMP1, RWORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call CPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL SCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 14 + CALL CPTEQR( 'V', N, D4, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL CSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RWORK, RESULT( 14 ) ) +* +* Compute D5 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 16 + CALL CPTEQR( 'N', N, D5, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call SSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL SSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL SSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call CSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call SSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL SSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL CSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, RWORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL CSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 20 ) ) +* +* Call CSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + INDE = 1 + INDRWK = INDE + N + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 22 + CALL CSTEDC( 'I', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 22 ) ) +* +* Call CSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 24 + CALL CSTEDC( 'V', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 24 ) ) +* +* Call CSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 26 + CALL CSTEDC( 'N', N, D2, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test CSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call CSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. CREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL CSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( CRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL CSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call CSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + IF( CRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL CSTEMR( 'V', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* +* +* Call CSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 31 + CALL CSTEMR( 'N', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call CSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) + CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL CSTEMR( 'V', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, M, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL CSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RWORK, RESULT( 32 ) ) +* +* Call CSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 34 + CALL CSTEMR( 'N', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call CSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 35 +* + CALL CSTEMR( 'V', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL CSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RWORK, RESULT( 35 ) ) +* +* Call CSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 37 + CALL CSTEMR( 'N', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 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 = 9998 )'CST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9987 ) + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0E0 ) THEN + WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9988 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL SLASUM( 'CST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' CCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see CCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 ) + 9988 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 1P, E10.3 ) +* + 9987 FORMAT( / 'Test performed: see CCHKST2STG for details.', / ) +* End of CCHKST2STG +* + END diff --git a/TESTING/EIG/cdrvsg2stg.f b/TESTING/EIG/cdrvsg2stg.f new file mode 100644 index 00000000..3a624568 --- /dev/null +++ b/TESTING/EIG/cdrvsg2stg.f @@ -0,0 +1,1384 @@ +*> \brief \b CDRVSG2STG +* +* @generated from zdrvsg2stg.f, fortran z -> c, Sun Nov 6 14:01:09 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, +* $ NSIZES, NTYPES, NWORK +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL D( * ), RESULT( * ), RWORK( * ) +* COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVSG2STG checks the complex Hermitian generalized eigenproblem +*> drivers. +*> +*> CHEGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> CHEGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> CHEGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> CHPGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> CHPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> CHPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> CHBGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> CHBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> CHBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> When CDRVSG2STG 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 A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) CHEGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> CHEGV and D2 is computed by +*> CHEGV_2STAGE. This test is +*> only performed for DSYGV +*> +*> (2) as (1) but calling CHPGV +*> (3) as (1) but calling CHBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling CHPGV +*> (6) as (4) but calling CHBGV +*> +*> (7) CHEGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling CHPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling CHPGV +*> +*> (11) CHEGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling CHPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling CHPGV +*> +*> CHEGVD, CHPGVD and CHBGVD performed the same 14 tests. +*> +*> CHEGVX, CHPGVX and CHBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" 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. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, CDRVSG2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 CDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B COMPLEX array, dimension (LDB , max(NN)) +*> Used to hold the Hermitian positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D REAL array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z COMPLEX array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of ZZ. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB COMPLEX array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB COMPLEX array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP COMPLEX array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP COMPLEX array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK COMPLEX array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 2*N + N**2 where N = max( NN(j), 2 ). +*> Not modified. +*> +*> RWORK REAL array, dimension (LRWORK) +*> Workspace. +*> Modified. +*> +*> LRWORK INTEGER +*> The number of entries in RWORK. This must be at least +*> max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where +*> N = max( NN(j) ) and lg( N ) = smallest integer k such +*> that 2**k >= N . +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK)) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in IWORK. This must be at least +*> 2 + 5*max( NN(j) ). +*> Not modified. +*> +*> RESULT REAL array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LRWORK too small. +*> -25: LIWORK too small. +*> If CLATMR, CLATMS, CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, +*> CHPGVD, CHEGVX, CHPGVX, CHBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 CDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, RWORK, LRWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* + IMPLICIT NONE +* +* -- 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, LDB, LDZ, LIWORK, LRWORK, NOUNIT, + $ NSIZES, NTYPES, NWORK + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL D( * ), D2( * ), RESULT( * ), RWORK( * ) + COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 10.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLARND + EXTERNAL LSAME, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL SLABAD, SLAFTS, SLASUM, XERBLA, CHBGV, CHBGVD, + $ CHBGVX, CHEGV, CHEGVD, CHEGVX, CHPGV, CHPGVD, + $ CHPGVX, CLACPY, CLASET, CLATMR, CLATMS, CSGT01, + $ CHEGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* 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( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LRWORK ) THEN + INFO = -23 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LIWORK ) THEN + INFO = -25 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK, IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, CHBGVD, +* CHEGVX, CHPGVX and CHBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL CLATMS( N, N, 'U', ISEED, 'P', RWORK, 5, TEN, + $ ONE, KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test CHEGV +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHEGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test CHEGVD +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHEGVX +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL CHEGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL CLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL CLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL CHEGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test CHPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL CHPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL CHPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL CHPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL CHPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL CHPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST CHBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL CHBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* TEST CHBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL CHBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, RWORK, + $ LRWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test CHBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL CHBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL CHBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL CHBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL CSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'CSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL SLASUM( 'CSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* + 9999 FORMAT( ' CDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* +* End of CDRVSG2STG +* + END diff --git a/TESTING/EIG/cdrvst2stg.f b/TESTING/EIG/cdrvst2stg.f new file mode 100644 index 00000000..ab1af355 --- /dev/null +++ b/TESTING/EIG/cdrvst2stg.f @@ -0,0 +1,2118 @@ +*> \brief \b CDRVST2STG +* +* @generated from zdrvst2stg.f, fortran z -> c, Sat Nov 5 23:41:02 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, +* LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL D1( * ), D2( * ), D3( * ), RESULT( * ), +* $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) +* COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVST2STG checks the Hermitian eigenvalue problem drivers. +*> +*> CHEEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix, +*> using a divide-and-conquer algorithm. +*> +*> CHEEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> CHEEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix +*> using the Relatively Robust Representation where it can. +*> +*> CHPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage, using a divide-and-conquer algorithm. +*> +*> CHPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> CHBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix, +*> using a divide-and-conquer algorithm. +*> +*> CHBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> CHEEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> CHPEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> CHBEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> When CDRVST2STG 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 appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, CDRVST2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 CDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by CSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by CSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> WA1 REAL array, dimension +*> +*> WA2 REAL array, dimension +*> +*> WA3 REAL array, dimension +*> +*> U COMPLEX array, dimension (LDU, max(NN)) +*> The unitary matrix computed by CHETRD + CUNGC3. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V COMPLEX array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by CHETRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU COMPLEX array, dimension (max(NN)) +*> The Householder factors computed by CHETRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z COMPLEX array, dimension (LDU, max(NN)) +*> The unitary matrix of eigenvectors computed by CHEEVD, +*> CHEEVX, CHPEVD, CHPEVX, CHBEVD, and CHBEVX. +*> Modified. +*> +*> WORK - COMPLEX array of dimension ( LWORK ) +*> Workspace. +*> Modified. +*> +*> LWORK - INTEGER +*> The number of entries in WORK. This must be at least +*> 2*max( NN(j), 2 )**2. +*> Not modified. +*> +*> RWORK REAL array, dimension (3*max(NN)) +*> Workspace. +*> Modified. +*> +*> LRWORK - INTEGER +*> The number of entries in RWORK. +*> +*> IWORK INTEGER array, dimension (6*max(NN)) +*> Workspace. +*> Modified. +*> +*> LIWORK - INTEGER +*> The number of entries in IWORK. +*> +*> RESULT REAL array, dimension (??) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If SLATMR, SLATMS, CHETRD, SORGC3, CSTEQR, SSTERF, +*> or SORMC2 returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 CDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, + $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, 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, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL D1( * ), D2( * ), D3( * ), RESULT( * ), + $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) + COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, + $ TEN = 10.0E+0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX, + $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC, + $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX, + $ NTEST, NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SLABAD, SLAFTS, XERBLA, CHBEV, CHBEVD, + $ CHBEVX, CHEEV, CHEEVD, CHEEVR, CHEEVX, CHET21, + $ CHET22, CHPEV, CHPEVD, CHPEVX, CLACPY, CLASET, + $ CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE, + $ CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE, + $ CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_SY2SB, + $ CHETRD_SB2ST, CLATMR, CLATMS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + 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 +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -22 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* + DO 1220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = MAX( 2*N+N*N, 2*N*N ) + LRWEDC = 1 + 4*N + 2*N*LGN + 3*N**2 + LIWEDC = 3 + 5*N + ELSE + LWEDC = 2 + LRWEDC = 8 + LIWEDC = 8 + END IF + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1210 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 band Hermitian, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) ) + CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK, + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* Perform tests storing upper or lower triangular +* part of matrix. +* + DO 1200 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* Call CHEEVD and CHEEVX. +* + CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL CHEEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do tests 1 and 2. +* + CALL CHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL CHEEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 120 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 120 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 130 CONTINUE + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL CHEEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 4 and 5. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CHEEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 140 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 140 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 150 CONTINUE + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL CHEEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do tests 7 and 8. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL CHEEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do test 9. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 160 CONTINUE + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL CHEEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* +* Do tests 10 and 11. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL CHEEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF +* +* Do test 12. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 170 CONTINUE +* +* Call CHPEVD and CHPEVX. +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 190 J = 1, N + DO 180 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 180 CONTINUE + 190 CONTINUE + ELSE + INDX = 1 + DO 210 J = 1, N + DO 200 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 200 CONTINUE + 210 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do tests 13 and 14. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 230 J = 1, N + DO 220 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 220 CONTINUE + 230 CONTINUE + ELSE + INDX = 1 + DO 250 J = 1, N + DO 240 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 240 CONTINUE + 250 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 15. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 260 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 270 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 290 J = 1, N + DO 280 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 280 CONTINUE + 290 CONTINUE + ELSE + INDX = 1 + DO 310 J = 1, N + DO 300 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 300 CONTINUE + 310 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL CHPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do tests 16 and 17. +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 330 J = 1, N + DO 320 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 320 CONTINUE + 330 CONTINUE + ELSE + INDX = 1 + DO 350 J = 1, N + DO 340 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 340 CONTINUE + 350 CONTINUE + END IF +* + CALL CHPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 360 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 360 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 390 J = 1, N + DO 380 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 380 CONTINUE + 390 CONTINUE + ELSE + INDX = 1 + DO 410 J = 1, N + DO 400 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 400 CONTINUE + 410 CONTINUE + END IF +* + CALL CHPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do tests 19 and 20. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 430 J = 1, N + DO 420 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 420 CONTINUE + 430 CONTINUE + ELSE + INDX = 1 + DO 450 J = 1, N + DO 440 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 440 CONTINUE + 450 CONTINUE + END IF +* + CALL CHPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do test 21. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 460 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 480 J = 1, N + DO 470 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 470 CONTINUE + 480 CONTINUE + ELSE + INDX = 1 + DO 500 J = 1, N + DO 490 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 490 CONTINUE + 500 CONTINUE + END IF +* + CALL CHPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 550 + END IF + END IF +* +* Do tests 22 and 23. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 520 J = 1, N + DO 510 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 510 CONTINUE + 520 CONTINUE + ELSE + INDX = 1 + DO 540 J = 1, N + DO 530 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 530 CONTINUE + 540 CONTINUE + END IF +* + CALL CHPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF +* +* Do test 24. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 550 CONTINUE +* +* Call CHBEVD and CHBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 570 J = 1, N + DO 560 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 560 CONTINUE + 570 CONTINUE + ELSE + DO 590 J = 1, N + DO 580 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 580 CONTINUE + 590 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL CHBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEVD(V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do tests 25 and 26. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 610 J = 1, N + DO 600 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 600 CONTINUE + 610 CONTINUE + ELSE + DO 630 J = 1, N + DO 620 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 620 CONTINUE + 630 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL CHBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, + $ Z, LDU, WORK, LWORK, RWORK, + $ LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do test 27. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 640 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 640 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 650 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 670 J = 1, N + DO 660 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 660 CONTINUE + 670 CONTINUE + ELSE + DO 690 J = 1, N + DO 680 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 680 CONTINUE + 690 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL CHBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA1, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHBEVX(V,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do tests 28 and 29. +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 710 J = 1, N + DO 700 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 700 CONTINUE + 710 CONTINUE + ELSE + DO 730 J = 1, N + DO 720 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 720 CONTINUE + 730 CONTINUE + END IF +* + CALL CHBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do test 30. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 740 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 740 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 750 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 770 J = 1, N + DO 760 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 760 CONTINUE + 770 CONTINUE + ELSE + DO 790 J = 1, N + DO 780 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 780 CONTINUE + 790 CONTINUE + END IF +* + CALL CHBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEVX(V,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do tests 31 and 32. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 810 J = 1, N + DO 800 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 800 CONTINUE + 810 CONTINUE + ELSE + DO 830 J = 1, N + DO 820 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 820 CONTINUE + 830 CONTINUE + END IF + CALL CHBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do test 33. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 840 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 860 J = 1, N + DO 850 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 850 CONTINUE + 860 CONTINUE + ELSE + DO 880 J = 1, N + DO 870 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 870 CONTINUE + 880 CONTINUE + END IF + CALL CHBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEVX(V,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 930 + END IF + END IF +* +* Do tests 34 and 35. +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 900 J = 1, N + DO 890 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 890 CONTINUE + 900 CONTINUE + ELSE + DO 920 J = 1, N + DO 910 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 910 CONTINUE + 920 CONTINUE + END IF + CALL CHBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF +* +* Do test 36. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 930 CONTINUE +* +* Call CHEEV +* + CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL CHEEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do tests 37 and 38 +* + CALL CHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL CHEEV_2STAGE( 'N', UPLO, N, A, LDU, D3, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do test 39 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 940 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 940 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 950 CONTINUE +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Call CHPEV +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 970 J = 1, N + DO 960 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 960 CONTINUE + 970 CONTINUE + ELSE + INDX = 1 + DO 990 J = 1, N + DO 980 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 980 CONTINUE + 990 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEV( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do tests 40 and 41. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL CHPEV( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do test 42 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1040 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1040 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1050 CONTINUE +* +* Call CHBEV +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1070 J = 1, N + DO 1060 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1060 CONTINUE + 1070 CONTINUE + ELSE + DO 1090 J = 1, N + DO 1080 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1080 CONTINUE + 1090 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL CHBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'CHBEV(V,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1140 + END IF + END IF +* +* Do tests 43 and 44. +* + CALL CHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1110 J = 1, N + DO 1100 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1100 CONTINUE + 1110 CONTINUE + ELSE + DO 1130 J = 1, N + DO 1120 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1120 CONTINUE + 1130 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL CHBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'CHBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1140 + END IF + END IF +* + 1140 CONTINUE +* +* Do test 45. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1150 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + CALL CLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + CALL CHEEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do tests 45 and 46 (or ... ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CHEEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do test 47 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1160 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1160 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1170 CONTINUE +* + NTEST = NTEST + 1 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 48 and 49 (or +??) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 50 (or +??) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1180 CONTINUE +* + NTEST = NTEST + 1 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CHEEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1190 + END IF + END IF +* +* Do tests 51 and 52 (or +??) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL CHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL CHEEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'CHEEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF +* +* Do test 52 (or +??) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL CLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* +* +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1190 CONTINUE +* + 1200 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'CST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1210 CONTINUE + 1220 CONTINUE +* +* Summary +* + CALL ALASVM( 'CST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' CDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( ' CDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', KD=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, + $ ')' ) +* + RETURN +* +* End of CDRVST2STG +* + END diff --git a/TESTING/EIG/cerrst.f b/TESTING/EIG/cerrst.f index 14e4bfbe..c15bf5f4 100644 --- a/TESTING/EIG/cerrst.f +++ b/TESTING/EIG/cerrst.f @@ -25,6 +25,10 @@ *> CUNGTR, CUPMTR, CSTEQR, CSTEIN, CPTEQR, CHBTRD, *> CHEEV, CHEEVX, CHEEVD, CHBEV, CHBEVX, CHBEVD, *> CHPEV, CHPEVX, CHPEVD, and CSTEDC. +*> CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE, +*> CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE, +*> CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_SY2SB, +*> CHETRD_SB2ST *> \endverbatim * * Arguments: @@ -93,7 +97,11 @@ EXTERNAL CHBEV, CHBEVD, CHBEVX, CHBTRD, CHEEV, CHEEVD, $ CHEEVR, CHEEVX, CHETRD, CHKXER, CHPEV, CHPEVD, $ CHPEVX, CHPTRD, CPTEQR, CSTEDC, CSTEIN, CSTEQR, - $ CUNGTR, CUNMTR, CUPGTR, CUPMTR + $ CUNGTR, CUNMTR, CUPGTR, CUPMTR, + $ CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE, + $ CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE, + $ CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_SY2SB, + $ CHETRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -151,6 +159,103 @@ CALL CHKXER( 'CHETRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* CHETRD_2STAGE +* + SRNAMT = 'CHETRD_2STAGE' + INFOT = 1 + CALL CHETRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHETRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* CHETRD_HE2HB +* + SRNAMT = 'CHETRD_HE2HB' + INFOT = 1 + CALL CHETRD_HE2HB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HE2HB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_HE2HB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_HE2HB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRD_HE2HB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHETRD_HE2HB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'CHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* CHETRD_HB2ST +* + SRNAMT = 'CHETRD_HB2ST' + INFOT = 1 + CALL CHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_HB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * CUNGTR * SRNAMT = 'CUNGTR' @@ -377,6 +482,63 @@ CALL CHKXER( 'CHEEVD', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* CHEEVD_2STAGE +* + SRNAMT = 'CHEEVD_2STAGE' + INFOT = 1 + CALL CHEEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 3, +* $ RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 0, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 18, IW, 12, INFO ) +* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 1, IW, 0, INFO ) + CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 +* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 25, IW, 11, INFO ) +* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * CHEEV * SRNAMT = 'CHEEV ' @@ -397,6 +559,29 @@ CALL CHKXER( 'CHEEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* CHEEV_2STAGE +* + SRNAMT = 'CHEEV_2STAGE ' + INFOT = 1 + CALL CHEEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHEEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEV_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, RW, INFO ) + CALL CHKXER( 'CHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * CHEEVX * SRNAMT = 'CHEEVX' @@ -441,6 +626,65 @@ CALL CHKXER( 'CHEEVX', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* CHEEVX_2STAGE +* + SRNAMT = 'CHEEVX_2STAGE' + INFOT = 1 + CALL CHEEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + INFOT = 4 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHEEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL CHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I1, INFO ) + CALL CHKXER( 'CHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * CHEEVR * SRNAMT = 'CHEEVR' @@ -508,6 +752,90 @@ CALL CHKXER( 'CHEEVR', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* CHEEVR_2STAGE +* + SRNAMT = 'CHEEVR_2STAGE' + N = 1 + INFOT = 1 + CALL CHEEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHEEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHEEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHEEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHEEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHEEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHEEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 0, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N-1, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N-1, IW( 2*N-1 ), + $ 10*N, INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 22 + CALL CHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N, IW, 10*N-1, + $ INFO ) + CALL CHKXER( 'CHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * CHPEVD * SRNAMT = 'CHPEVD' @@ -646,6 +974,47 @@ CALL CHKXER( 'CHBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* CHETRD_HB2ST +* + SRNAMT = 'CHETRD_HB2ST' + INFOT = 1 + CALL CHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRD_HB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRD_HB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRD_HB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'CHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * CHBEVD * SRNAMT = 'CHBEVD' @@ -711,6 +1080,75 @@ CALL CHKXER( 'CHBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 15 * +* CHBEVD_2STAGE +* + SRNAMT = 'CHBEVD_2STAGE' + INFOT = 1 + CALL CHBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, + $ W, 2, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 0, + $ W, 8, RW, 25, IW, 12, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 0, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 1, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 2, RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 0, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 2, IW, 12, INFO ) +* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 0, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 2, IW, 0, INFO ) + CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 15 +* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 25, IW, 2, INFO ) +* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * CHBEV * SRNAMT = 'CHBEV ' @@ -734,6 +1172,43 @@ CALL CHKXER( 'CHBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* CHBEV_2STAGE +* + SRNAMT = 'CHBEV_2STAGE ' + INFOT = 1 + CALL CHBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CHBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 0, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'CHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * CHBEVX * SRNAMT = 'CHBEVX' @@ -781,6 +1256,74 @@ $ 0.0, M, X, Z, 1, W, RW, IW, I3, INFO ) CALL CHKXER( 'CHBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 11 +* +* CHBEVX_2STAGE +* + SRNAMT = 'CHBEVX_2STAGE' + INFOT = 1 + CALL CHBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 1 + CALL CHBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 4 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL CHBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, +* $ 0.0D0, 0.0D0, 0, 0, 0.0D0, +* $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) +* CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 1, 2, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL CHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 END IF * * Print a summary line. diff --git a/TESTING/EIG/dchkee.f b/TESTING/EIG/dchkee.f index b723687a..4d342085 100644 --- a/TESTING/EIG/dchkee.f +++ b/TESTING/EIG/dchkee.f @@ -1106,7 +1106,8 @@ $ DDRGEV, DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, $ DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD, $ DERRED, DERRGG, DERRHS, DERRST, ILAVER, XLAENV, - $ DDRGES3, DDRGEV3 + $ DDRGES3, DDRGEV3, + $ DCHKST2STG, DDRVST2STG, DCHKSB2STG, DDRVSG2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1153,7 +1154,7 @@ PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'DHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'DST' ) .OR. - $ LSAMEN( 3, PATH, 'DSG' ) + $ LSAMEN( 3, PATH, 'DSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) DEV = LSAMEN( 3, PATH, 'DEV' ) DES = LSAMEN( 3, PATH, 'DES' ) @@ -1839,7 +1840,8 @@ $ WRITE( NOUT, FMT = 9980 )'DCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1869,6 +1871,15 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL DCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), + $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL DCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), @@ -1876,16 +1887,26 @@ $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL DDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), + $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL DDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), $ D( 1, 10 ), D( 1, 11 ), A( 1, 2 ), NMAX, $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DDRVST', INFO END IF @@ -1918,11 +1939,17 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, IWORK, LIWORK, RESULT, INFO ) + CALL DDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ D( 1, 3 ), D( 1, 3 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DDRVSG', INFO END IF @@ -2282,9 +2309,13 @@ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL DERRST( 'DSB', NOUT ) - CALL DCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) +* CALL DCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) + CALL DCHKSB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DCHKSB', INFO * diff --git a/TESTING/EIG/dchksb2stg.f b/TESTING/EIG/dchksb2stg.f new file mode 100644 index 00000000..adac168c --- /dev/null +++ b/TESTING/EIG/dchksb2stg.f @@ -0,0 +1,870 @@ +*> \brief \b DCHKSBSTG +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ), +* $ U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKSBSTG tests the reduction of a symmetric band matrix to tridiagonal +*> form, used with the symmetric eigenvalue problem. +*> +*> DSBTRD factors a symmetric band matrix A as U S U' , where ' means +*> transpose, S is symmetric tridiagonal, and U is orthogonal. +*> DSBTRD can use either just the lower or just the upper triangle +*> of A; DCHKSBSTG checks both cases. +*> +*> DSYTRD_SB2ST factors a symmetric band matrix A as U S U' , +*> where ' means transpose, S is symmetric tridiagonal, and U is +*> orthogonal. DSYTRD_SB2ST can use either just the lower or just +*> the upper triangle of A; DCHKSBSTG checks both cases. +*> +*> DSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSBTRD "U" (used as reference for DSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "L". +*> +*> When DCHKSBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the symmetric banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with +*> UPLO='U' +*> +*> (2) | I - UU' | / ( n ulp ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with +*> UPLO='L' +*> +*> (4) | I - UU' | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D2 is computed by +*> DSYTRD_SB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D3 is computed by +*> DSYTRD_SB2ST with UPLO='L' +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DCHKSBSTG 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] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> DCHKSBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. 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, DCHKSBSTG +*> 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 DCHKSBSTG 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] 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 matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by DSBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by DSBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> Used to hold the orthogonal matrix computed by DSBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \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 +*> max( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (4) +*> 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 +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 DCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, 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, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ), + $ U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TEN = 10.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS, + $ NMATS, NMAX, NTEST, NTESTT + DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLASET, DLASUM, DLATMR, DLATMS, DSBT21, + $ DSBTRD, XERBLA, DSBTRD_SB2ST, DSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DCHKSBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK( N+1 ), IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call DSBTRD to compute S and U from upper triangle. +* + CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL DSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL DSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 1 ) ) +* +* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofDSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the DSBTRD and used as reference to compare +* with the DSYTRD_SB2ST routine +* +* Compute D1 from the DSBTRD and used as reference for the +* DSYTRD_SB2ST +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* DSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL DSYTRD_SB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the DSYTRD_SB2ST Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = A( K+1-JR, JC+JR ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call DSBTRD to compute S and U from lower triangle +* + CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL DSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL DSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 3 ) ) +* +* DSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL DSYTRD_SB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 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 = 9998 )'DSB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''', + $ 'transpose', ( '''', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL DLASUM( 'DSB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' DCHKSBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, + $ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' ) + 9997 FORMAT( ' Matrix types (see DCHKSBSTG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of DCHKSBSTG +* + END diff --git a/TESTING/EIG/dchkst2stg.f b/TESTING/EIG/dchkst2stg.f new file mode 100644 index 00000000..29190691 --- /dev/null +++ b/TESTING/EIG/dchkst2stg.f @@ -0,0 +1,2120 @@ +*> \brief \b DCHKST2STG +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ), +* $ D3( * ), D4( * ), D5( * ), RESULT( * ), +* $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKST2STG checks the symmetric eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> DSYTRD. For that, we call the standard DSYTRD and compute D1 using +*> DSTEQR, then we call the 2-stage DSYTRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using DSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the DCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> DSYTRD factors A as U S U' , where ' means transpose, +*> S is symmetric tridiagonal, and U is orthogonal. +*> DSYTRD can use either just the lower or just the upper triangle +*> of A; DCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> DSPTRD does the same as DSYTRD, except that A and V are stored +*> in "packed" format. +*> +*> DORGTR constructs the matrix U from the contents of V and TAU. +*> +*> DOPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> DSTEQR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> DSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> DPTEQR factors S as Z4 D4 Z4' , for a +*> symmetric positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> DSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> DSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> DSTEDC factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input orthogonal matrix, usually the output +*> from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> DSTEMR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). DSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When DCHKST2STG 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 symmetric eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... ) +*> +*> (2) | I - UV' | / ( n ulp ) DORGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> DSYTRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via DSTEQR('N',...) +*> +*> (4) | I - UV' | / ( n ulp ) DORGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> DSYTRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via DSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for DSPTRD and DOPGTR. +*> +*> (9) | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...) +*> +*> (10) | I - ZZ' | / ( n ulp ) DSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) DSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) DSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> DSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...) +*> +*> (15) | I - Z4 Z4' | / ( n ulp ) DPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) DPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y' | / ( |S| n ulp ) DSTEBZ, SSTEIN +*> +*> (21) | I - Y Y' | / ( n ulp ) DSTEBZ, SSTEIN +*> +*> (22) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('I') +*> +*> (23) | I - ZZ' | / ( n ulp ) DSTEDC('I') +*> +*> (24) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('V') +*> +*> (25) | I - ZZ' | / ( n ulp ) DSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) DSTEDC('V') and +*> DSTEDC('N') +*> +*> Test 27 is disabled at the moment because DSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because DSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'I') +*> +*> (30) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEMR('N', 'I') vs. SSTEMR('V', 'I') +*> +*> (32) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'V') +*> +*> (33) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEMR('N', 'V') vs. SSTEMR('V', 'V') +*> +*> (35) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'A') +*> +*> (36) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEMR('N', 'A') vs. SSTEMR('V', 'A') +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DCHKST2STG 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, DCHKST2STG +*> 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 DCHKST2STG 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] 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 of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by DSYTRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> DSYTRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DPTEQR(V). +*> DPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix computed by DSYTRD + DORGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by DSYTRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in DSYTRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as DORGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is DOUBLE PRECISION array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The Householder factors computed by DSYTRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix of eigenvectors computed by DSTEQR, +*> DPTEQR, and DSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (26) +*> 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 +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF, +*> or DORMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 DCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, IWORK, LIWORK, 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, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ), + $ D3( * ), D4( * ), D5( * ), RESULT( * ), + $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL SRANGE + PARAMETER ( SRANGE = .FALSE. ) + LOGICAL SREL + PARAMETER ( SREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, + $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, + $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, + $ NMATS, NMAX, NSPLIT, NTEST, NTESTT, LH, LW + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + DOUBLE PRECISION DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLACPY, DLASET, DLASUM, DLATMR, + $ DLATMS, DOPGTR, DORGTR, DPTEQR, DSPT21, DSPTRD, + $ DSTEBZ, DSTECH, DSTEDC, DSTEMR, DSTEIN, DSTEQR, + $ DSTERF, DSTT21, DSTT22, DSYT21, DSYTRD, XERBLA, + $ DSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'DSYTRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) / + $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I, + $ I ) ) ) + A( I, I-1 ) = A( I-1, I ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call DSYTRD and DORGTR to compute S and U from +* upper triangle. +* + CALL DLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL DSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL DORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DORGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL DSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 1 ) ) + CALL DSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( "U", N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL DSYTRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL DLACPY( "L", N, N, A, LDA, V, LDU ) + CALL DSYTRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL DSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Skip the DSYTRD for lower that since we replaced its testing +* 3 and 4 by the 2-stage one. + GOTO 101 +* +* Call DSYTRD and DORGTR to compute S and U from +* lower triangle, do tests. +* + CALL DLACPY( 'L', N, N, A, LDA, V, LDU ) +* + NTEST = 3 + CALL DSYTRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DLACPY( 'L', N, N, V, LDU, U, LDU ) +* + NTEST = 4 + CALL DORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DORGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DSYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 3 ) ) + CALL DSYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 4 ) ) +* +*after skipping old tests 3 4 back to the normal +* + 101 CONTINUE +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call DSPTRD and DOPGTR to compute S and U from AP +* + CALL DCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL DSPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL DOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DOPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL DSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 5 ) ) + CALL DSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call DSPTRD and DOPGTR to compute S and U from AP +* + CALL DCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL DSPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL DOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DOPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 7 ) ) + CALL DSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 8 ) ) +* +* Call DSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 9 + CALL DSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 11 + CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 12 + CALL DSTERF( N, D3, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL DSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call DPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL DCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 14 + CALL DPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL DSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RESULT( 14 ) ) +* +* Compute D5 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 16 + CALL DPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call DSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call DSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call DSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL DSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, + $ RESULT( 20 ) ) +* +* Call DSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 22 + CALL DSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 22 ) ) +* +* Call DSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 24 + CALL DSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 24 ) ) +* +* Call DSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 26 + CALL DSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test DSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call DSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. SREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL DSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( SRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL DSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call DSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + IF( SRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL DSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* + CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 29 ) ) +* +* Call DSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 31 + CALL DSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call DSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL DSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 32 ) ) +* +* Call DSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 34 + CALL DSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call DSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 35 +* + CALL DSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RESULT( 35 ) ) +* +* Call DSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 37 + CALL DSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 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 = 9998 )'DST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9988 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR, + $ RESULT( JR ) + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL DLASUM( 'DST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' DCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see DCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2, + $ ', test(', I2, ')=', G10.3 ) +* + 9988 FORMAT( / 'Test performed: see DCHKST2STG for details.', / ) +* End of DCHKST2STG +* + END diff --git a/TESTING/EIG/ddrvsg2stg.f b/TESTING/EIG/ddrvsg2stg.f new file mode 100644 index 00000000..b26b7777 --- /dev/null +++ b/TESTING/EIG/ddrvsg2stg.f @@ -0,0 +1,1364 @@ +*> \brief \b DDRVSG2STG +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, IWORK, LIWORK, +* RESULT, INFO ) +* +* IMPLICIT NONE +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, +* $ NTYPES, NWORK +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), +* $ RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVSG2STG checks the real symmetric generalized eigenproblem +*> drivers. +*> +*> DSYGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> DSYGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> DSYGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> DSPGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> DSPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> DSPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> DSBGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> DSBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> DSBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> When DDRVSG2STG 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 A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) DSYGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> DSYGV and D2 is computed by +*> DSYGV_2STAGE. This test is +*> only performed for DSYGV +*> +*> (2) as (1) but calling DSPGV +*> (3) as (1) but calling DSBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling DSPGV +*> (6) as (4) but calling DSBGV +*> +*> (7) DSYGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling DSPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling DSPGV +*> +*> (11) DSYGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling DSPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling DSPGV +*> +*> DSYGVD, DSPGVD and DSBGVD performed the same 14 tests. +*> +*> DSYGVX, DSPGVX and DSBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" 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. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRVSG2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 DDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A DOUBLE PRECISION array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A and AB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B DOUBLE PRECISION array, dimension (LDB , max(NN)) +*> Used to hold the symmetric positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B and BB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z DOUBLE PRECISION array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of Z. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB DOUBLE PRECISION array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB DOUBLE PRECISION array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP DOUBLE PRECISION array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP DOUBLE PRECISION array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK DOUBLE PRECISION array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and +*> lg( N ) = smallest integer k such that 2**k >= N. +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in WORK. This must be at least 6*N. +*> Not modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LIWORK too small. +*> If DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, +*> DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*> ---------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 DDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK, + $ RESULT, INFO ) +* + IMPLICIT NONE +* +* -- 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, LDB, LDZ, LIWORK, NOUNIT, NSIZES, + $ NTYPES, NWORK + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), + $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL LSAME, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLACPY, DLAFTS, DLASET, DLASUM, DLATMR, + $ DLATMS, DSBGV, DSBGVD, DSBGVX, DSGT01, DSPGV, + $ DSPGVD, DSPGVX, DSYGV, DSYGVD, DSYGVX, XERBLA, + $ DSYGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* 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( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* symmetric, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* symmetric, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL DLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* symmetric banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, SSBGVD, +* DSYGVX, DSPGVX, and DSBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL DLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE, + $ KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test DSYGV +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSYGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test DSYGVD +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSYGVX +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL DSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test DSPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL DSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL DSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL DSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL DSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL DSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST DSBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL DSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* TEST DSBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL DSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test DSBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL DSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL DSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL DSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'DSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL DLASUM( 'DSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* +* End of DDRVSG2STG +* + 9999 FORMAT( ' DDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + END diff --git a/TESTING/EIG/ddrvst2stg.f b/TESTING/EIG/ddrvst2stg.f new file mode 100644 index 00000000..75385fda --- /dev/null +++ b/TESTING/EIG/ddrvst2stg.f @@ -0,0 +1,2874 @@ +*> \brief \b DDRVST2STG +* +* @precisions fortran d -> s +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, +* WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ), +* $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), +* $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVST2STG checks the symmetric eigenvalue problem drivers. +*> +*> DSTEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> DSTEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> DSTEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix +*> using the Relatively Robust Representation where it can. +*> +*> DSYEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> DSYEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> DSYEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix +*> using the Relatively Robust Representation where it can. +*> +*> DSPEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> DSPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> DSBEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> DSBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> DSYEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix using +*> a divide and conquer algorithm. +*> +*> DSPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage, using a divide and conquer algorithm. +*> +*> DSBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix, +*> using a divide and conquer algorithm. +*> +*> When DDRVST2STG 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 appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" eigenvalues +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRVST2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 DDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A DOUBLE PRECISION array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> D4 DOUBLE PRECISION array, dimension +*> +*> EVEIGS DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues as computed by DSTEV('N', ... ) +*> (I reserve the right to change this to the output of +*> whichever algorithm computes the most accurate eigenvalues). +*> +*> WA1 DOUBLE PRECISION array, dimension +*> +*> WA2 DOUBLE PRECISION array, dimension +*> +*> WA3 DOUBLE PRECISION array, dimension +*> +*> U DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The orthogonal matrix computed by DSYTRD + DORGTR. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by DSYTRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU DOUBLE PRECISION array, dimension (max(NN)) +*> The Householder factors computed by DSYTRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The orthogonal matrix of eigenvectors computed by DSTEQR, +*> DPTEQR, and DSTEIN. +*> Modified. +*> +*> WORK DOUBLE PRECISION array, dimension (LWORK) +*> Workspace. +*> Modified. +*> +*> LWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Not modified. +*> +*> IWORK INTEGER array, +*> dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Workspace. +*> Modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (105) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF, +*> or DORMTR returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> +*> The tests performed are: Routine tested +*> 1= | A - U S U' | / ( |A| n ulp ) DSTEV('V', ... ) +*> 2= | I - U U' | / ( n ulp ) DSTEV('V', ... ) +*> 3= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEV('N', ... ) +*> 4= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','A', ... ) +*> 5= | I - U U' | / ( n ulp ) DSTEVX('V','A', ... ) +*> 6= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVX('N','A', ... ) +*> 7= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','A', ... ) +*> 8= | I - U U' | / ( n ulp ) DSTEVR('V','A', ... ) +*> 9= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVR('N','A', ... ) +*> 10= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','I', ... ) +*> 11= | I - U U' | / ( n ulp ) DSTEVX('V','I', ... ) +*> 12= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','I', ... ) +*> 13= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','V', ... ) +*> 14= | I - U U' | / ( n ulp ) DSTEVX('V','V', ... ) +*> 15= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','V', ... ) +*> 16= | A - U S U' | / ( |A| n ulp ) DSTEVD('V', ... ) +*> 17= | I - U U' | / ( n ulp ) DSTEVD('V', ... ) +*> 18= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVD('N', ... ) +*> 19= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','I', ... ) +*> 20= | I - U U' | / ( n ulp ) DSTEVR('V','I', ... ) +*> 21= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','I', ... ) +*> 22= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','V', ... ) +*> 23= | I - U U' | / ( n ulp ) DSTEVR('V','V', ... ) +*> 24= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','V', ... ) +*> +*> 25= | A - U S U' | / ( |A| n ulp ) DSYEV('L','V', ... ) +*> 26= | I - U U' | / ( n ulp ) DSYEV('L','V', ... ) +*> 27= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEV_2STAGE('L','N', ... ) +*> 28= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','A', ... ) +*> 29= | I - U U' | / ( n ulp ) DSYEVX('L','V','A', ... ) +*> 30= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX_2STAGE('L','N','A', ... ) +*> 31= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','I', ... ) +*> 32= | I - U U' | / ( n ulp ) DSYEVX('L','V','I', ... ) +*> 33= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX_2STAGE('L','N','I', ... ) +*> 34= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','V', ... ) +*> 35= | I - U U' | / ( n ulp ) DSYEVX('L','V','V', ... ) +*> 36= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX_2STAGE('L','N','V', ... ) +*> 37= | A - U S U' | / ( |A| n ulp ) DSPEV('L','V', ... ) +*> 38= | I - U U' | / ( n ulp ) DSPEV('L','V', ... ) +*> 39= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEV('L','N', ... ) +*> 40= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','A', ... ) +*> 41= | I - U U' | / ( n ulp ) DSPEVX('L','V','A', ... ) +*> 42= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','A', ... ) +*> 43= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','I', ... ) +*> 44= | I - U U' | / ( n ulp ) DSPEVX('L','V','I', ... ) +*> 45= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','I', ... ) +*> 46= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','V', ... ) +*> 47= | I - U U' | / ( n ulp ) DSPEVX('L','V','V', ... ) +*> 48= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','V', ... ) +*> 49= | A - U S U' | / ( |A| n ulp ) DSBEV('L','V', ... ) +*> 50= | I - U U' | / ( n ulp ) DSBEV('L','V', ... ) +*> 51= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEV_2STAGE('L','N', ... ) +*> 52= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','A', ... ) +*> 53= | I - U U' | / ( n ulp ) DSBEVX('L','V','A', ... ) +*> 54= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX_2STAGE('L','N','A', ... ) +*> 55= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','I', ... ) +*> 56= | I - U U' | / ( n ulp ) DSBEVX('L','V','I', ... ) +*> 57= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX_2STAGE('L','N','I', ... ) +*> 58= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','V', ... ) +*> 59= | I - U U' | / ( n ulp ) DSBEVX('L','V','V', ... ) +*> 60= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX_2STAGE('L','N','V', ... ) +*> 61= | A - U S U' | / ( |A| n ulp ) DSYEVD('L','V', ... ) +*> 62= | I - U U' | / ( n ulp ) DSYEVD('L','V', ... ) +*> 63= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVD_2STAGE('L','N', ... ) +*> 64= | A - U S U' | / ( |A| n ulp ) DSPEVD('L','V', ... ) +*> 65= | I - U U' | / ( n ulp ) DSPEVD('L','V', ... ) +*> 66= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVD('L','N', ... ) +*> 67= | A - U S U' | / ( |A| n ulp ) DSBEVD('L','V', ... ) +*> 68= | I - U U' | / ( n ulp ) DSBEVD('L','V', ... ) +*> 69= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVD_2STAGE('L','N', ... ) +*> 70= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','A', ... ) +*> 71= | I - U U' | / ( n ulp ) DSYEVR('L','V','A', ... ) +*> 72= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR_2STAGE('L','N','A', ... ) +*> 73= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','I', ... ) +*> 74= | I - U U' | / ( n ulp ) DSYEVR('L','V','I', ... ) +*> 75= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR_2STAGE('L','N','I', ... ) +*> 76= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','V', ... ) +*> 77= | I - U U' | / ( n ulp ) DSYEVR('L','V','V', ... ) +*> 78= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR_2STAGE('L','N','V', ... ) +*> +*> Tests 25 through 78 are repeated (as tests 79 through 132) +*> with UPLO='U' +*> +*> To be added in 1999 +*> +*> 79= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','A', ... ) +*> 80= | I - U U' | / ( n ulp ) DSPEVR('L','V','A', ... ) +*> 81= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','A', ... ) +*> 82= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','I', ... ) +*> 83= | I - U U' | / ( n ulp ) DSPEVR('L','V','I', ... ) +*> 84= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','I', ... ) +*> 85= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','V', ... ) +*> 86= | I - U U' | / ( n ulp ) DSPEVR('L','V','V', ... ) +*> 87= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','V', ... ) +*> 88= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','A', ... ) +*> 89= | I - U U' | / ( n ulp ) DSBEVR('L','V','A', ... ) +*> 90= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','A', ... ) +*> 91= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','I', ... ) +*> 92= | I - U U' | / ( n ulp ) DSBEVR('L','V','I', ... ) +*> 93= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','I', ... ) +*> 94= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','V', ... ) +*> 95= | I - U U' | / ( n ulp ) DSBEVR('L','V','V', ... ) +*> 96= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','V', ... ) +*> \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 DDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, + $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, + $ IWORK, LIWORK, 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, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ), + $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), + $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TEN = 10.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW, + $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2, + $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, DLACPY, DLAFTS, DLASET, DLATMR, + $ DLATMS, DSBEV, DSBEVD, DSBEVX, DSPEV, DSPEVD, + $ DSPEVX, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSTT21, + $ DSTT22, DSYEV, DSYEVD, DSYEVR, DSYEVX, DSYT21, + $ DSYEVD_2STAGE, DSYEVR_2STAGE, DSYEVX_2STAGE, + $ DSYEV_2STAGE, DSBEV_2STAGE, DSBEVD_2STAGE, + $ DSBEVX_2STAGE, DSYTRD_2STAGE, DSYTRD_SY2SB, + $ DSYTRD_SB2ST, DSYT22, XERBLA +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* Keep ftrnchek happy +* + VL = ZERO + VU = ZERO +* +* 1) Check for errors +* + NTESTT = 0 + 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 +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -21 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* +* + DO 1740 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 +c LIWEDC = 6 + 6*N + 5*N*LGN + LIWEDC = 3 + 5*N + ELSE + LWEDC = 9 +c LIWEDC = 12 + LIWEDC = 8 + END IF + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1730 JTYPE = 1, MTYPES +* + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1730 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 band symmetric, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Symmetric banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) ) + CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ), + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) If matrix is tridiagonal, call DSTEV and DSTEVX. +* + IF( JTYPE.LE.7 ) THEN + NTEST = 1 + DO 120 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 120 CONTINUE + DO 130 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 130 CONTINUE + SRNAMT = 'DSTEV' + CALL DSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEV(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + RESULT( 2 ) = ULPINV + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do tests 1 and 2. +* + DO 140 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 140 CONTINUE + DO 150 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 150 CONTINUE + CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 1 ) ) +* + NTEST = 3 + DO 160 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 160 CONTINUE + SRNAMT = 'DSTEV' + CALL DSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEV(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 170 CONTINUE + RESULT( 3 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 180 CONTINUE +* + NTEST = 4 + DO 190 I = 1, N + EVEIGS( I ) = D3( I ) + D1( I ) = DBLE( A( I, I ) ) + 190 CONTINUE + DO 200 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 200 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + RESULT( 5 ) = ULPINV + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 4 and 5. +* + DO 210 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 210 CONTINUE + DO 220 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 220 CONTINUE + CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 4 ) ) +* + NTEST = 6 + DO 230 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 230 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 240 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 240 CONTINUE + RESULT( 6 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 250 CONTINUE +* + NTEST = 7 + DO 260 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 260 CONTINUE + DO 270 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 270 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + RESULT( 8 ) = ULPINV + GO TO 320 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 7 and 8. +* + DO 280 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 280 CONTINUE + DO 290 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 290 CONTINUE + CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 7 ) ) +* + NTEST = 9 + DO 300 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 300 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 320 + END IF + END IF +* +* Do test 9. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 310 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 310 CONTINUE + RESULT( 9 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 320 CONTINUE +* +* + NTEST = 10 + DO 330 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 330 CONTINUE + DO 340 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 340 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 10 ) = ULPINV + RESULT( 11 ) = ULPINV + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do tests 10 and 11. +* + DO 350 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 350 CONTINUE + DO 360 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 360 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 10 ) ) +* +* + NTEST = 12 + DO 370 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 370 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do test 12. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 380 CONTINUE +* + NTEST = 12 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 390 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 390 CONTINUE + DO 400 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 400 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF +* +* Do tests 13 and 14. +* + DO 410 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 410 CONTINUE + DO 420 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 420 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 13 ) ) +* + NTEST = 15 + DO 430 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 430 CONTINUE + SRNAMT = 'DSTEVX' + CALL DSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* +* Do test 15. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 440 CONTINUE +* + NTEST = 16 + DO 450 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 450 CONTINUE + DO 460 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 460 CONTINUE + SRNAMT = 'DSTEVD' + CALL DSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVD(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + RESULT( 17 ) = ULPINV + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do tests 16 and 17. +* + DO 470 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 470 CONTINUE + DO 480 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 480 CONTINUE + CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 16 ) ) +* + NTEST = 18 + DO 490 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 490 CONTINUE + SRNAMT = 'DSTEVD' + CALL DSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVD(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 500 J = 1, N + TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ), + $ ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) ) + 500 CONTINUE + RESULT( 18 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 510 CONTINUE +* + NTEST = 19 + DO 520 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 520 CONTINUE + DO 530 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 530 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* DO tests 19 and 20. +* + DO 540 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 540 CONTINUE + DO 550 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 550 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 19 ) ) +* +* + NTEST = 21 + DO 560 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 560 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* Do test 21. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 570 CONTINUE +* + NTEST = 21 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 580 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 580 CONTINUE + DO 590 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 590 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF +* +* Do tests 22 and 23. +* + DO 600 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 600 CONTINUE + DO 610 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 610 CONTINUE + CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 22 ) ) +* + NTEST = 24 + DO 620 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 620 CONTINUE + SRNAMT = 'DSTEVR' + CALL DSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* +* Do test 24. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 630 CONTINUE +* +* +* + ELSE +* + DO 640 I = 1, 24 + RESULT( I ) = ZERO + 640 CONTINUE + NTEST = 24 + END IF +* +* Perform remaining tests storing upper or lower triangular +* part of matrix. +* + DO 1720 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* 4) Call DSYEV and DSYEVX. +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'DSYEV' + CALL DSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do tests 25 and 26 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEV_2STAGE' + CALL DSYEV_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do test 27 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 650 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 650 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 660 CONTINUE + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'DSYEVX' + CALL DSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do tests 28 and 29 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEVX_2STAGE' + CALL DSYEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do test 30 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 680 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX' + CALL DSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do tests 31 and 32 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX_2STAGE' + CALL DSYEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do test 33 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 690 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX' + CALL DSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 34 and 35 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVX_2STAGE' + CALL DSYEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 36 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 700 CONTINUE +* +* 5) Call DSPEV and DSPEVX. +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 720 J = 1, N + DO 710 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 710 CONTINUE + 720 CONTINUE + ELSE + INDX = 1 + DO 740 J = 1, N + DO 730 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 730 CONTINUE + 740 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSPEV' + CALL DSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do tests 37 and 38 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 760 J = 1, N + DO 750 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 750 CONTINUE + 760 CONTINUE + ELSE + INDX = 1 + DO 780 J = 1, N + DO 770 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 770 CONTINUE + 780 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSPEV' + CALL DSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do test 39 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 790 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 790 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 800 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 820 J = 1, N + DO 810 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 810 CONTINUE + 820 CONTINUE + ELSE + INDX = 1 + DO 840 J = 1, N + DO 830 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 830 CONTINUE + 840 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do tests 40 and 41 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 860 J = 1, N + DO 850 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 850 CONTINUE + 860 CONTINUE + ELSE + INDX = 1 + DO 880 J = 1, N + DO 870 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 870 CONTINUE + 880 CONTINUE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do test 42 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 890 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 890 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 900 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 920 J = 1, N + DO 910 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 910 CONTINUE + 920 CONTINUE + ELSE + INDX = 1 + DO 940 J = 1, N + DO 930 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 930 CONTINUE + 940 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 990 + END IF + END IF +* +* Do tests 43 and 44 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 960 J = 1, N + DO 950 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 950 CONTINUE + 960 CONTINUE + ELSE + INDX = 1 + DO 980 J = 1, N + DO 970 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 970 CONTINUE + 980 CONTINUE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF +* +* Do test 45 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 990 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1080 + END IF + END IF +* +* Do tests 46 and 47 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1050 J = 1, N + DO 1040 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1040 CONTINUE + 1050 CONTINUE + ELSE + INDX = 1 + DO 1070 J = 1, N + DO 1060 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1060 CONTINUE + 1070 CONTINUE + END IF +* + SRNAMT = 'DSPEVX' + CALL DSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF +* +* Do test 48 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1080 CONTINUE +* +* 6) Call DSBEV and DSBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1100 J = 1, N + DO 1090 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1090 CONTINUE + 1100 CONTINUE + ELSE + DO 1120 J = 1, N + DO 1110 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1110 CONTINUE + 1120 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSBEV' + CALL DSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 49 and 50 (or ... ) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1140 J = 1, N + DO 1130 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1130 CONTINUE + 1140 CONTINUE + ELSE + DO 1160 J = 1, N + DO 1150 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1150 CONTINUE + 1160 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSBEV_2STAGE' + CALL DSBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 51 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1170 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1180 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 1200 J = 1, N + DO 1190 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1190 CONTINUE + 1200 CONTINUE + ELSE + DO 1220 J = 1, N + DO 1210 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1210 CONTINUE + 1220 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSBEVX' + CALL DSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do tests 52 and 53 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1240 J = 1, N + DO 1230 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1230 CONTINUE + 1240 CONTINUE + ELSE + DO 1260 J = 1, N + DO 1250 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1250 CONTINUE + 1260 CONTINUE + END IF +* + SRNAMT = 'DSBEVX_2STAGE' + CALL DSBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do test 54 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1270 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) ) + 1270 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1280 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1300 J = 1, N + DO 1290 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1290 CONTINUE + 1300 CONTINUE + ELSE + DO 1320 J = 1, N + DO 1310 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1310 CONTINUE + 1320 CONTINUE + END IF +* + SRNAMT = 'DSBEVX' + CALL DSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do tests 55 and 56 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1340 J = 1, N + DO 1330 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1330 CONTINUE + 1340 CONTINUE + ELSE + DO 1360 J = 1, N + DO 1350 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1350 CONTINUE + 1360 CONTINUE + END IF +* + SRNAMT = 'DSBEVX_2STAGE' + CALL DSBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do test 57 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1390 J = 1, N + DO 1380 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1380 CONTINUE + 1390 CONTINUE + ELSE + DO 1410 J = 1, N + DO 1400 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1400 CONTINUE + 1410 CONTINUE + END IF +* + SRNAMT = 'DSBEVX' + CALL DSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1460 + END IF + END IF +* +* Do tests 58 and 59 (or +54) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1430 J = 1, N + DO 1420 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1420 CONTINUE + 1430 CONTINUE + ELSE + DO 1450 J = 1, N + DO 1440 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1440 CONTINUE + 1450 CONTINUE + END IF +* + SRNAMT = 'DSBEVX_2STAGE' + CALL DSBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF +* +* Do test 60 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1460 CONTINUE +* +* 7) Call DSYEVD +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'DSYEVD' + CALL DSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do tests 61 and 62 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEVD_2STAGE' + CALL DSYEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do test 63 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1470 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1470 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1480 CONTINUE +* +* 8) Call DSPEVD. +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1500 J = 1, N + DO 1490 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1490 CONTINUE + 1500 CONTINUE + ELSE + INDX = 1 + DO 1520 J = 1, N + DO 1510 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1510 CONTINUE + 1520 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSPEVD' + CALL DSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do tests 64 and 65 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1540 J = 1, N + DO 1530 I = 1, J +* + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1530 CONTINUE + 1540 CONTINUE + ELSE + INDX = 1 + DO 1560 J = 1, N + DO 1550 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1550 CONTINUE + 1560 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSPEVD' + CALL DSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do test 66 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1570 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1570 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + 1580 CONTINUE +* +* 9) Call DSBEVD. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1600 J = 1, N + DO 1590 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1590 CONTINUE + 1600 CONTINUE + ELSE + DO 1620 J = 1, N + DO 1610 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1610 CONTINUE + 1620 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'DSBEVD' + CALL DSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSBEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do tests 67 and 68 (or +54) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1640 J = 1, N + DO 1630 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1630 CONTINUE + 1640 CONTINUE + ELSE + DO 1660 J = 1, N + DO 1650 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1650 CONTINUE + 1660 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'DSBEVD_2STAGE' + CALL DSBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do test 69 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1680 CONTINUE +* +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + SRNAMT = 'DSYEVR' + CALL DSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do tests 70 and 71 (or ... ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'DSYEVR_2STAGE' + CALL DSYEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do test 72 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1690 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1690 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1700 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR' + CALL DSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do tests 73 and 74 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR_2STAGE' + CALL DSYEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do test 75 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1710 CONTINUE +* + NTEST = NTEST + 1 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR' + CALL DSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 76 and 77 (or +54) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'DSYEVR_2STAGE' + CALL DSYEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'DSYEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 78 (or +54) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + 1720 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST +* + CALL DLAFTS( 'DST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1730 CONTINUE + 1740 CONTINUE +* +* Summary +* + CALL ALASVM( 'DST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' DDRVST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + RETURN +* +* End of DDRVST2STG +* + END diff --git a/TESTING/EIG/derrst.f b/TESTING/EIG/derrst.f index dfb3452e..9f149fe0 100644 --- a/TESTING/EIG/derrst.f +++ b/TESTING/EIG/derrst.f @@ -25,6 +25,10 @@ *> DOPGTR, DOPMTR, DSTEQR, SSTERF, SSTEBZ, SSTEIN, DPTEQR, DSBTRD, *> DSYEV, SSYEVX, SSYEVD, DSBEV, SSBEVX, SSBEVD, *> DSPEV, SSPEVX, SSPEVD, DSTEV, SSTEVX, SSTEVD, and SSTEDC. +*> DSYEVD_2STAGE, DSYEVR_2STAGE, DSYEVX_2STAGE, +*> DSYEV_2STAGE, DSBEV_2STAGE, DSBEVD_2STAGE, +*> DSBEVX_2STAGE, DSYTRD_2STAGE, DSYTRD_SY2SB, +*> DSYTRD_SB2ST *> \endverbatim * * Arguments: @@ -94,7 +98,11 @@ $ DSBEV, DSBEVD, DSBEVX, DSBTRD, DSPEV, DSPEVD, $ DSPEVX, DSPTRD, DSTEBZ, DSTEDC, DSTEIN, DSTEQR, $ DSTERF, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSYEV, - $ DSYEVD, DSYEVR, DSYEVX, DSYTRD + $ DSYEVD, DSYEVR, DSYEVX, DSYTRD, + $ DSYEVD_2STAGE, DSYEVR_2STAGE, DSYEVX_2STAGE, + $ DSYEV_2STAGE, DSBEV_2STAGE, DSBEVD_2STAGE, + $ DSBEVX_2STAGE, DSYTRD_2STAGE, DSYTRD_SY2SB, + $ DSYTRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -152,6 +160,103 @@ CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* DSYTRD_2STAGE +* + SRNAMT = 'DSYTRD_2STAGE' + INFOT = 1 + CALL DSYTRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYTRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* DSYTRD_SY2SB +* + SRNAMT = 'DSYTRD_SY2SB' + INFOT = 1 + CALL DSYTRD_SY2SB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SY2SB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_SY2SB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_SY2SB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRD_SY2SB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYTRD_SY2SB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* DSYTRD_SB2ST +* + SRNAMT = 'DSYTRD_SB2ST' + INFOT = 1 + CALL DSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_SB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DORGTR * SRNAMT = 'DORGTR' @@ -536,6 +641,44 @@ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* DSYEVD_2STAGE +* + SRNAMT = 'DSYEVD_2STAGE' + INFOT = 1 + CALL DSYEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL DSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO ) +* CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, IW, 0, INFO ) + CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL DSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO ) +* CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DSYEVR * SRNAMT = 'DSYEVR' @@ -591,6 +734,74 @@ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* DSYEVR_2STAGE +* + SRNAMT = 'DSYEVR_2STAGE' + N = 1 + INFOT = 1 + CALL DSYEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSYEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 0, IW( 2*N+1 ), 10*N, + $ INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL DSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 0, + $ INFO ) + CALL CHKXER( 'DSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 +* * DSYEV * SRNAMT = 'DSYEV ' @@ -611,6 +822,29 @@ CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* DSYEV_2STAGE +* + SRNAMT = 'DSYEV_2STAGE ' + INFOT = 1 + CALL DSYEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEV_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * DSYEVX * SRNAMT = 'DSYEVX' @@ -663,6 +897,75 @@ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* DSYEVX_2STAGE +* + SRNAMT = 'DSYEVX_2STAGE' + INFOT = 1 + CALL DSYEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSYEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + INFOT = 4 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 2, 0.0D0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 16, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL DSYEVX_2STAGE( 'N', 'A', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * DSPEVD * SRNAMT = 'DSPEVD' @@ -786,6 +1089,47 @@ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* DSYTRD_SB2ST +* + SRNAMT = 'DSYTRD_SB2ST' + INFOT = 1 + CALL DSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRD_SB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRD_SB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'DSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DSBEVD * SRNAMT = 'DSBEVD' @@ -829,6 +1173,60 @@ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* DSBEVD_2STAGE +* + SRNAMT = 'DSBEVD_2STAGE' + INFOT = 1 + CALL DSBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, + $ 4, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL DSBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, +* $ 25, IW, 12, INFO ) +* CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 0, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEVD_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, + $ 3, IW, 1, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL DSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 18, IW, 12, INFO ) +* CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 0, INFO ) + CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL DSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 25, IW, 11, INFO ) +* CALL CHKXER( 'DSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 12 + NT = NT + 9 +* * DSBEV * SRNAMT = 'DSBEV ' @@ -852,6 +1250,35 @@ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* DSBEV_2STAGE +* + SRNAMT = 'DSBEV_2STAGE ' + INFOT = 1 + CALL DSBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 0, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEV_2STAGE( 'N', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'DSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * DSBEVX * SRNAMT = 'DSBEVX' @@ -866,6 +1293,7 @@ INFOT = 3 CALL DSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0, $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0, $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO ) @@ -907,6 +1335,72 @@ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO ) CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 13 +* +* DSBEVX_2STAGE +* + SRNAMT = 'DSBEVX_2STAGE' + INFOT = 1 + CALL DSBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL DSBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL DSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0D0, +* $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 2, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 2, 1, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 2, 1, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 1, 2, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 18 +* CALL DSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0D0, +* $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL DSBEVX_2STAGE( 'N', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, + $ 0.0D0, 0, 0, 0.0D0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'DSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 15 + NT = NT + 13 END IF * * Print a summary line. diff --git a/TESTING/EIG/ilaenv.f b/TESTING/EIG/ilaenv.f index 90f80077..6fca6fcb 100644 --- a/TESTING/EIG/ilaenv.f +++ b/TESTING/EIG/ilaenv.f @@ -229,6 +229,16 @@ C ILAENV = 0 * WRITE(*,*) 'ISPEC = ',ISPEC,' ILAENV =',ILAENV * ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * + ELSE IF(( ISPEC.GE.17 ) .AND. (ISPEC.LE.21)) THEN +* +* 17 <= ISPEC <= 21: 2stage eigenvalues SVD routines. +* + IF( ISPEC.EQ.17 ) THEN + ILAENV = IPARMS( 1 ) + ELSE + ILAENV = IPARAM2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + ENDIF +* ELSE * * Invalid value for ISPEC diff --git a/TESTING/EIG/schkee.f b/TESTING/EIG/schkee.f index 99d717e0..7651c0a3 100644 --- a/TESTING/EIG/schkee.f +++ b/TESTING/EIG/schkee.f @@ -1106,7 +1106,8 @@ $ SDRGEV, SDRGSX, SDRGVX, SDRVBD, SDRVES, SDRVEV, $ SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD, $ SERRED, SERRGG, SERRHS, SERRST, ILAVER, XLAENV, - $ SDRGES3, SDRGEV3 + $ SDRGES3, SDRGEV3, + $ SCHKST2STG, SDRVST2STG, SCHKSB2STG, SDRVSG2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1153,7 +1154,8 @@ PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'SHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'SST' ) .OR. - $ LSAMEN( 3, PATH, 'SSG' ) + $ LSAMEN( 3, PATH, 'SSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) + SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'SBD' ) SEV = LSAMEN( 3, PATH, 'SEV' ) SES = LSAMEN( 3, PATH, 'SES' ) @@ -1839,7 +1841,8 @@ $ WRITE( NOUT, FMT = 9980 )'SCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'SST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'SST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1869,6 +1872,15 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL SCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), + $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL SCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), @@ -1876,16 +1888,26 @@ $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL SDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), + $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL SDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRVST', INFO END IF @@ -1918,11 +1940,17 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL SDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* CALL SDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, IWORK, LIWORK, RESULT, INFO ) + CALL SDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ D( 1, 3 ), D( 1, 3 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRVSG', INFO END IF @@ -2284,9 +2312,13 @@ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL SERRST( 'SSB', NOUT ) - CALL SCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) +* CALL SCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) + CALL SCHKSB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SCHKSB', INFO * diff --git a/TESTING/EIG/schksb2stg.f b/TESTING/EIG/schksb2stg.f new file mode 100644 index 00000000..02163695 --- /dev/null +++ b/TESTING/EIG/schksb2stg.f @@ -0,0 +1,870 @@ +*> \brief \b SCHKSBSTG +* +* @generated from dchksb2stg.f, fortran d -> s, Sun Nov 6 00:12:41 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ), +* $ U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKSBSTG tests the reduction of a symmetric band matrix to tridiagonal +*> form, used with the symmetric eigenvalue problem. +*> +*> SSBTRD factors a symmetric band matrix A as U S U' , where ' means +*> transpose, S is symmetric tridiagonal, and U is orthogonal. +*> SSBTRD can use either just the lower or just the upper triangle +*> of A; SCHKSBSTG checks both cases. +*> +*> SSYTRD_SB2ST factors a symmetric band matrix A as U S U' , +*> where ' means transpose, S is symmetric tridiagonal, and U is +*> orthogonal. SSYTRD_SB2ST can use either just the lower or just +*> the upper triangle of A; SCHKSBSTG checks both cases. +*> +*> SSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of SSBTRD "U" (used as reference for SSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of SSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of SSYTRD_SB2ST "L". +*> +*> When SCHKSBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the symmetric banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with +*> UPLO='U' +*> +*> (2) | I - UU' | / ( n ulp ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with +*> UPLO='L' +*> +*> (4) | I - UU' | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> SSBTRD with UPLO='U' and +*> D2 is computed by +*> SSYTRD_SB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> SSBTRD with UPLO='U' and +*> D3 is computed by +*> SSYTRD_SB2ST with UPLO='L' +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SCHKSBSTG 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] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> SCHKSBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. 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, SCHKSBSTG +*> 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 SCHKSBSTG 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] 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 matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by SSBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by SSBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is REAL array, dimension (LDU, max(NN)) +*> Used to hold the orthogonal matrix computed by SSBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \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 +*> max( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (4) +*> 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 +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 SCHKSB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, 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, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ), + $ U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ TEN = 10.0E0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS, + $ NMATS, NMAX, NTEST, NTESTT + REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SLACPY, SLASET, SLASUM, SLATMR, SLATMS, SSBT21, + $ SSBTRD, XERBLA, SSBTRD_SB2ST, SSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SCHKSBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK( N+1 ), IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call SSBTRD to compute S and U from upper triangle. +* + CALL SLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL SSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL SSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 1 ) ) +* +* Before converting A into lower for SSBTRD, run SSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofSSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the SSBTRD and used as reference to compare +* with the SSYTRD_SB2ST routine +* +* Compute D1 from the SSBTRD and used as reference for the +* SSYTRD_SB2ST +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* SSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the SSBTRD. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL SSYTRD_SB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the SSYTRD_SB2ST Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = A( K+1-JR, JC+JR ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call SSBTRD to compute S and U from lower triangle +* + CALL SLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL SSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL SSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RESULT( 3 ) ) +* +* SSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the SSBTRD. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL SSYTRD_SB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 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 = 9998 )'SSB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''', + $ 'transpose', ( '''', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL SLASUM( 'SSB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' SCHKSBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, + $ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' ) + 9997 FORMAT( ' Matrix types (see SCHKSBSTG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of SCHKSBSTG +* + END diff --git a/TESTING/EIG/schkst2stg.f b/TESTING/EIG/schkst2stg.f new file mode 100644 index 00000000..8db1cf73 --- /dev/null +++ b/TESTING/EIG/schkst2stg.f @@ -0,0 +1,2120 @@ +*> \brief \b SCHKST2STG +* +* @generated from dchkst2stg.f, fortran d -> s, Sat Nov 5 22:51:30 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), AP( * ), D1( * ), D2( * ), +* $ D3( * ), D4( * ), D5( * ), RESULT( * ), +* $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKST2STG checks the symmetric eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> SSYTRD. For that, we call the standard SSYTRD and compute D1 using +*> SSTEQR, then we call the 2-stage SSYTRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using SSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the SCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> SSYTRD factors A as U S U' , where ' means transpose, +*> S is symmetric tridiagonal, and U is orthogonal. +*> SSYTRD can use either just the lower or just the upper triangle +*> of A; SCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> SSPTRD does the same as SSYTRD, except that A and V are stored +*> in "packed" format. +*> +*> SORGTR constructs the matrix U from the contents of V and TAU. +*> +*> SOPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> SSTEQR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> SSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> SPTEQR factors S as Z4 D4 Z4' , for a +*> symmetric positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> SSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> SSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> SSTEDC factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input orthogonal matrix, usually the output +*> from SSYTRD/SORGTR or SSPTRD/SOPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> SSTEMR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). SSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When SCHKST2STG 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 symmetric eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='U', ... ) +*> +*> (2) | I - UV' | / ( n ulp ) SORGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> SSYTRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via SSTEQR('N',...) +*> +*> (4) | I - UV' | / ( n ulp ) SORGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> SSYTRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via SSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for SSPTRD and SOPGTR. +*> +*> (9) | S - Z D Z' | / ( |S| n ulp ) SSTEQR('V',...) +*> +*> (10) | I - ZZ' | / ( n ulp ) SSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) SSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) SSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> SSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...) +*> +*> (15) | I - Z4 Z4' | / ( n ulp ) SPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) SPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y' | / ( |S| n ulp ) SSTEBZ, SSTEIN +*> +*> (21) | I - Y Y' | / ( n ulp ) SSTEBZ, SSTEIN +*> +*> (22) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('I') +*> +*> (23) | I - ZZ' | / ( n ulp ) SSTEDC('I') +*> +*> (24) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('V') +*> +*> (25) | I - ZZ' | / ( n ulp ) SSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and +*> SSTEDC('N') +*> +*> Test 27 is disabled at the moment because SSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because SSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'I') +*> +*> (30) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'I') vs. SSTEMR('V', 'I') +*> +*> (32) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'V') +*> +*> (33) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'V') vs. SSTEMR('V', 'V') +*> +*> (35) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'A') +*> +*> (36) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'A') vs. SSTEMR('V', 'A') +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SCHKST2STG 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, SCHKST2STG +*> 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 SCHKST2STG 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] 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 of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is REAL array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by SSYTRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> SSYTRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(V). +*> SPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is REAL array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix computed by SSYTRD + SORGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is REAL array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by SSYTRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in SSYTRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as SORGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is REAL array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array of +*> dimension( max(NN) ) +*> The Householder factors computed by SSYTRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix of eigenvectors computed by SSTEQR, +*> SPTEQR, and SSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (26) +*> 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 +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, +*> or SORMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 SCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, IWORK, LIWORK, 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, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), AP( * ), D1( * ), D2( * ), + $ D3( * ), D4( * ), D5( * ), RESULT( * ), + $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL SRANGE + PARAMETER ( SRANGE = .FALSE. ) + LOGICAL SREL + PARAMETER ( SREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, + $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, + $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, + $ NMATS, NMAX, NSPLIT, NTEST, NTESTT, LH, LW + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + REAL DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLABAD, SLACPY, SLASET, SLASUM, SLATMR, + $ SLATMS, SOPGTR, SORGTR, SPTEQR, SSPT21, SSPTRD, + $ SSTEBZ, SSTECH, SSTEDC, SSTEMR, SSTEIN, SSTEQR, + $ SSTERF, SSTT21, SSTT22, SSYT21, SSYTRD, XERBLA, + $ SSYTRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'SSYTRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) / + $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I, + $ I ) ) ) + A( I, I-1 ) = A( I-1, I ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call SSYTRD and SORGTR to compute S and U from +* upper triangle. +* + CALL SLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL SSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL SORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SORGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL SSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 1 ) ) + CALL SSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D1, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( "U", N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL SSYTRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL SLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL SLACPY( "L", N, N, A, LDA, V, LDU ) + CALL SSYTRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL SSTEQR( 'N', N, D3, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Skip the SSYTRD for lower that since we replaced its testing +* 3 and 4 by the 2-stage one. + GOTO 101 +* +* Call SSYTRD and SORGTR to compute S and U from +* lower triangle, do tests. +* + CALL SLACPY( 'L', N, N, A, LDA, V, LDU ) +* + NTEST = 3 + CALL SSYTRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SLACPY( 'L', N, N, V, LDU, U, LDU ) +* + NTEST = 4 + CALL SORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SORGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SSYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 3 ) ) + CALL SSYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 4 ) ) +* +*after skipping old tests 3 4 back to the normal +* + 101 CONTINUE +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call SSPTRD and SOPGTR to compute S and U from AP +* + CALL SCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL SSPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL SOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SOPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL SSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 5 ) ) + CALL SSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call SSPTRD and SOPGTR to compute S and U from AP +* + CALL SCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL SSPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL SOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SOPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 7 ) ) + CALL SSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RESULT( 8 ) ) +* +* Call SSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 9 + CALL SSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 11 + CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL SCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 12 + CALL SSTERF( N, D3, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL SSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call SPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL SCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 14 + CALL SPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL SSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RESULT( 14 ) ) +* +* Compute D5 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 16 + CALL SPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call SSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL SSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL SSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ WORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call SSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call SSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL SSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL SSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, + $ RESULT( 20 ) ) +* +* Call SSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 22 + CALL SSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 22 ) ) +* +* Call SSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 24 + CALL SSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ RESULT( 24 ) ) +* +* Call SSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 26 + CALL SSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test SSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call SSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. SREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL SSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( SRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL SSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK, LWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call SSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + IF( SRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL SSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* + CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 29 ) ) +* +* Call SSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 31 + CALL SSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call SSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL SSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RESULT( 32 ) ) +* +* Call SSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 34 + CALL SSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call SSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 35 +* + CALL SSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RESULT( 35 ) ) +* +* Call SSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 37 + CALL SSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 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 = 9998 )'SST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Symmetric' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9988 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR, + $ RESULT( JR ) + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL SLASUM( 'SST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' SCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see SCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2, + $ ', test(', I2, ')=', G10.3 ) +* + 9988 FORMAT( / 'Test performed: see SCHKST2STG for details.', / ) +* End of SCHKST2STG +* + END diff --git a/TESTING/EIG/sdrvsg2stg.f b/TESTING/EIG/sdrvsg2stg.f new file mode 100644 index 00000000..c39af7fd --- /dev/null +++ b/TESTING/EIG/sdrvsg2stg.f @@ -0,0 +1,1365 @@ +*> \brief \b SDRVSG2STG +* +* @generated from ddrvsg2stg.f, fortran d -> s, Sun Nov 6 13:47:49 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, IWORK, LIWORK, +* RESULT, INFO ) +* +* IMPLICIT NONE +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, +* $ NTYPES, NWORK +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), +* $ RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVSG2STG checks the real symmetric generalized eigenproblem +*> drivers. +*> +*> SSYGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> SSYGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> SSYGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem. +*> +*> SSPGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> SSPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> SSPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite generalized +*> eigenproblem in packed storage. +*> +*> SSBGV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> SSBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> SSBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric-definite banded +*> generalized eigenproblem. +*> +*> When SDRVSG2STG 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 A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) SSYGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> SSYGV and D2 is computed by +*> SSYGV_2STAGE. This test is +*> only performed for SSYGV +*> +*> (2) as (1) but calling SSPGV +*> (3) as (1) but calling SSBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling SSPGV +*> (6) as (4) but calling SSBGV +*> +*> (7) SSYGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling SSPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling SSPGV +*> +*> (11) SSYGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling SSPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling SSPGV +*> +*> SSYGVD, SSPGVD and SSBGVD performed the same 14 tests. +*> +*> SSYGVX, SSPGVX and SSBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" 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. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRVSG2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 SDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. real) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A REAL array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A and AB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B REAL array, dimension (LDB , max(NN)) +*> Used to hold the symmetric positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B and BB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D REAL array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z REAL array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of Z. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB REAL array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB REAL array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP REAL array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP REAL array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK REAL array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and +*> lg( N ) = smallest integer k such that 2**k >= N. +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in WORK. This must be at least 6*N. +*> Not modified. +*> +*> RESULT REAL array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LIWORK too small. +*> If SLATMR, SLATMS, SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, +*> SSBGVD, SSYGVX, SSPGVX or SSBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*> ---------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup real_eig +* +* ===================================================================== + SUBROUTINE SDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK, + $ RESULT, INFO ) +* + IMPLICIT NONE +* +* -- 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, LDB, LDZ, LIWORK, NOUNIT, NSIZES, + $ NTYPES, NWORK + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), + $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLARND + EXTERNAL LSAME, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL SLABAD, SLACPY, SLAFTS, SLASET, SLASUM, SLATMR, + $ SLATMS, SSBGV, SSBGVD, SSBGVX, SSGT01, SSPGV, + $ SSPGVD, SSPGVX, SSYGV, SSYGVD, SSYGVX, XERBLA, + $ SSYGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* 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( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* symmetric, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* symmetric, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL SLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* symmetric banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, SSBGVD, +* SSYGVX, SSPGVX, and SSBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL SLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE, + $ KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test SSYGV +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSYGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test SSYGVD +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSYGVX +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL SSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test SSPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL SSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL SSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL SSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL SSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL SSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST SSBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL SSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* TEST SSBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL SSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* Test SSBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL SSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL SSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL SSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'SSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL SLASUM( 'SSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* +* End of SDRVSG2STG +* + 9999 FORMAT( ' SDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + END diff --git a/TESTING/EIG/sdrvst2stg.f b/TESTING/EIG/sdrvst2stg.f new file mode 100644 index 00000000..727706a8 --- /dev/null +++ b/TESTING/EIG/sdrvst2stg.f @@ -0,0 +1,2874 @@ +*> \brief \b SDRVST2STG +* +* @generated from ddrvst2stg.f, fortran d -> s, Sun Nov 6 00:06:01 2016 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, +* WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), D1( * ), D2( * ), D3( * ), +* $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), +* $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVST2STG checks the symmetric eigenvalue problem drivers. +*> +*> SSTEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> SSTEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix. +*> +*> SSTEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric tridiagonal matrix +*> using the Relatively Robust Representation where it can. +*> +*> SSYEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> SSYEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix. +*> +*> SSYEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix +*> using the Relatively Robust Representation where it can. +*> +*> SSPEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> SSPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage. +*> +*> SSBEV computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> SSBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix. +*> +*> SSYEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix using +*> a divide and conquer algorithm. +*> +*> SSPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric matrix in packed +*> storage, using a divide and conquer algorithm. +*> +*> SSBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a real symmetric band matrix, +*> using a divide and conquer algorithm. +*> +*> When SDRVST2STG 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 appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" eigenvalues +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRVST2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 SDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A REAL array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> D4 REAL array, dimension +*> +*> EVEIGS REAL array, dimension (max(NN)) +*> The eigenvalues as computed by SSTEV('N', ... ) +*> (I reserve the right to change this to the output of +*> whichever algorithm computes the most accurate eigenvalues). +*> +*> WA1 REAL array, dimension +*> +*> WA2 REAL array, dimension +*> +*> WA3 REAL array, dimension +*> +*> U REAL array, dimension (LDU, max(NN)) +*> The orthogonal matrix computed by SSYTRD + SORGTR. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V REAL array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by SSYTRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU REAL array, dimension (max(NN)) +*> The Householder factors computed by SSYTRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z REAL array, dimension (LDU, max(NN)) +*> The orthogonal matrix of eigenvectors computed by SSTEQR, +*> SPTEQR, and SSTEIN. +*> Modified. +*> +*> WORK REAL array, dimension (LWORK) +*> Workspace. +*> Modified. +*> +*> LWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Not modified. +*> +*> IWORK INTEGER array, +*> dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Workspace. +*> Modified. +*> +*> RESULT REAL array, dimension (105) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, +*> or SORMTR returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> +*> The tests performed are: Routine tested +*> 1= | A - U S U' | / ( |A| n ulp ) SSTEV('V', ... ) +*> 2= | I - U U' | / ( n ulp ) SSTEV('V', ... ) +*> 3= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEV('N', ... ) +*> 4= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','A', ... ) +*> 5= | I - U U' | / ( n ulp ) SSTEVX('V','A', ... ) +*> 6= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVX('N','A', ... ) +*> 7= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','A', ... ) +*> 8= | I - U U' | / ( n ulp ) SSTEVR('V','A', ... ) +*> 9= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVR('N','A', ... ) +*> 10= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','I', ... ) +*> 11= | I - U U' | / ( n ulp ) SSTEVX('V','I', ... ) +*> 12= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','I', ... ) +*> 13= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','V', ... ) +*> 14= | I - U U' | / ( n ulp ) SSTEVX('V','V', ... ) +*> 15= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','V', ... ) +*> 16= | A - U S U' | / ( |A| n ulp ) SSTEVD('V', ... ) +*> 17= | I - U U' | / ( n ulp ) SSTEVD('V', ... ) +*> 18= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVD('N', ... ) +*> 19= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','I', ... ) +*> 20= | I - U U' | / ( n ulp ) SSTEVR('V','I', ... ) +*> 21= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','I', ... ) +*> 22= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','V', ... ) +*> 23= | I - U U' | / ( n ulp ) SSTEVR('V','V', ... ) +*> 24= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','V', ... ) +*> +*> 25= | A - U S U' | / ( |A| n ulp ) SSYEV('L','V', ... ) +*> 26= | I - U U' | / ( n ulp ) SSYEV('L','V', ... ) +*> 27= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEV_2STAGE('L','N', ... ) +*> 28= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','A', ... ) +*> 29= | I - U U' | / ( n ulp ) SSYEVX('L','V','A', ... ) +*> 30= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX_2STAGE('L','N','A', ... ) +*> 31= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','I', ... ) +*> 32= | I - U U' | / ( n ulp ) SSYEVX('L','V','I', ... ) +*> 33= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX_2STAGE('L','N','I', ... ) +*> 34= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','V', ... ) +*> 35= | I - U U' | / ( n ulp ) SSYEVX('L','V','V', ... ) +*> 36= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX_2STAGE('L','N','V', ... ) +*> 37= | A - U S U' | / ( |A| n ulp ) SSPEV('L','V', ... ) +*> 38= | I - U U' | / ( n ulp ) SSPEV('L','V', ... ) +*> 39= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEV('L','N', ... ) +*> 40= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','A', ... ) +*> 41= | I - U U' | / ( n ulp ) SSPEVX('L','V','A', ... ) +*> 42= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','A', ... ) +*> 43= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','I', ... ) +*> 44= | I - U U' | / ( n ulp ) SSPEVX('L','V','I', ... ) +*> 45= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','I', ... ) +*> 46= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','V', ... ) +*> 47= | I - U U' | / ( n ulp ) SSPEVX('L','V','V', ... ) +*> 48= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','V', ... ) +*> 49= | A - U S U' | / ( |A| n ulp ) SSBEV('L','V', ... ) +*> 50= | I - U U' | / ( n ulp ) SSBEV('L','V', ... ) +*> 51= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEV_2STAGE('L','N', ... ) +*> 52= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','A', ... ) +*> 53= | I - U U' | / ( n ulp ) SSBEVX('L','V','A', ... ) +*> 54= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX_2STAGE('L','N','A', ... ) +*> 55= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','I', ... ) +*> 56= | I - U U' | / ( n ulp ) SSBEVX('L','V','I', ... ) +*> 57= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX_2STAGE('L','N','I', ... ) +*> 58= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','V', ... ) +*> 59= | I - U U' | / ( n ulp ) SSBEVX('L','V','V', ... ) +*> 60= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX_2STAGE('L','N','V', ... ) +*> 61= | A - U S U' | / ( |A| n ulp ) SSYEVD('L','V', ... ) +*> 62= | I - U U' | / ( n ulp ) SSYEVD('L','V', ... ) +*> 63= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVD_2STAGE('L','N', ... ) +*> 64= | A - U S U' | / ( |A| n ulp ) SSPEVD('L','V', ... ) +*> 65= | I - U U' | / ( n ulp ) SSPEVD('L','V', ... ) +*> 66= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVD('L','N', ... ) +*> 67= | A - U S U' | / ( |A| n ulp ) SSBEVD('L','V', ... ) +*> 68= | I - U U' | / ( n ulp ) SSBEVD('L','V', ... ) +*> 69= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVD_2STAGE('L','N', ... ) +*> 70= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','A', ... ) +*> 71= | I - U U' | / ( n ulp ) SSYEVR('L','V','A', ... ) +*> 72= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR_2STAGE('L','N','A', ... ) +*> 73= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','I', ... ) +*> 74= | I - U U' | / ( n ulp ) SSYEVR('L','V','I', ... ) +*> 75= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR_2STAGE('L','N','I', ... ) +*> 76= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','V', ... ) +*> 77= | I - U U' | / ( n ulp ) SSYEVR('L','V','V', ... ) +*> 78= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR_2STAGE('L','N','V', ... ) +*> +*> Tests 25 through 78 are repeated (as tests 79 through 132) +*> with UPLO='U' +*> +*> To be added in 1999 +*> +*> 79= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','A', ... ) +*> 80= | I - U U' | / ( n ulp ) SSPEVR('L','V','A', ... ) +*> 81= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','A', ... ) +*> 82= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','I', ... ) +*> 83= | I - U U' | / ( n ulp ) SSPEVR('L','V','I', ... ) +*> 84= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','I', ... ) +*> 85= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','V', ... ) +*> 86= | I - U U' | / ( n ulp ) SSPEVR('L','V','V', ... ) +*> 87= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','V', ... ) +*> 88= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','A', ... ) +*> 89= | I - U U' | / ( n ulp ) SSBEVR('L','V','A', ... ) +*> 90= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','A', ... ) +*> 91= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','I', ... ) +*> 92= | I - U U' | / ( n ulp ) SSBEVR('L','V','I', ... ) +*> 93= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','I', ... ) +*> 94= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','V', ... ) +*> 95= | I - U U' | / ( n ulp ) SSBEVR('L','V','V', ... ) +*> 96= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','V', ... ) +*> \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 SDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, + $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, + $ IWORK, LIWORK, 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, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), D1( * ), D2( * ), D3( * ), + $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), + $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ TEN = 10.0E0 ) + REAL HALF + PARAMETER ( HALF = 0.5E+0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW, + $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2, + $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SLABAD, SLACPY, SLAFTS, SLASET, SLATMR, + $ SLATMS, SSBEV, SSBEVD, SSBEVX, SSPEV, SSPEVD, + $ SSPEVX, SSTEV, SSTEVD, SSTEVR, SSTEVX, SSTT21, + $ SSTT22, SSYEV, SSYEVD, SSYEVR, SSYEVX, SSYT21, + $ SSYEVD_2STAGE, SSYEVR_2STAGE, SSYEVX_2STAGE, + $ SSYEV_2STAGE, SSBEV_2STAGE, SSBEVD_2STAGE, + $ SSBEVX_2STAGE, SSYTRD_2STAGE, SSYTRD_SY2SB, + $ SSYTRD_SB2ST, SSYT22, XERBLA +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* Keep ftrnchek happy +* + VL = ZERO + VU = ZERO +* +* 1) Check for errors +* + NTESTT = 0 + 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 +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -21 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* +* + DO 1740 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 +c LIWEDC = 6 + 6*N + 5*N*LGN + LIWEDC = 3 + 5*N + ELSE + LWEDC = 9 +c LIWEDC = 12 + LIWEDC = 8 + END IF + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1730 JTYPE = 1, MTYPES +* + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1730 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 band symmetric, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Symmetric, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Symmetric banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) ) + CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ), + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) If matrix is tridiagonal, call SSTEV and SSTEVX. +* + IF( JTYPE.LE.7 ) THEN + NTEST = 1 + DO 120 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 120 CONTINUE + DO 130 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 130 CONTINUE + SRNAMT = 'SSTEV' + CALL SSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEV(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + RESULT( 2 ) = ULPINV + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do tests 1 and 2. +* + DO 140 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 140 CONTINUE + DO 150 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 150 CONTINUE + CALL SSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 1 ) ) +* + NTEST = 3 + DO 160 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 160 CONTINUE + SRNAMT = 'SSTEV' + CALL SSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEV(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 170 CONTINUE + RESULT( 3 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 180 CONTINUE +* + NTEST = 4 + DO 190 I = 1, N + EVEIGS( I ) = D3( I ) + D1( I ) = REAL( A( I, I ) ) + 190 CONTINUE + DO 200 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 200 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + RESULT( 5 ) = ULPINV + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 4 and 5. +* + DO 210 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 210 CONTINUE + DO 220 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 220 CONTINUE + CALL SSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 4 ) ) +* + NTEST = 6 + DO 230 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 230 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 250 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 240 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 240 CONTINUE + RESULT( 6 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 250 CONTINUE +* + NTEST = 7 + DO 260 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 260 CONTINUE + DO 270 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 270 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + RESULT( 8 ) = ULPINV + GO TO 320 + END IF + END IF + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF +* +* Do tests 7 and 8. +* + DO 280 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 280 CONTINUE + DO 290 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 290 CONTINUE + CALL SSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK, + $ RESULT( 7 ) ) +* + NTEST = 9 + DO 300 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 300 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 320 + END IF + END IF +* +* Do test 9. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 310 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), + $ ABS( EVEIGS( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) ) + 310 CONTINUE + RESULT( 9 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 320 CONTINUE +* +* + NTEST = 10 + DO 330 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 330 CONTINUE + DO 340 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 340 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 10 ) = ULPINV + RESULT( 11 ) = ULPINV + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do tests 10 and 11. +* + DO 350 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 350 CONTINUE + DO 360 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 360 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 10 ) ) +* +* + NTEST = 12 + DO 370 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 370 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 380 + END IF + END IF +* +* Do test 12. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 380 CONTINUE +* + NTEST = 12 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 390 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 390 CONTINUE + DO 400 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 400 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 13 ) = ULPINV + RESULT( 14 ) = ULPINV + RESULT( 15 ) = ULPINV + GO TO 440 + END IF +* +* Do tests 13 and 14. +* + DO 410 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 410 CONTINUE + DO 420 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 420 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 13 ) ) +* + NTEST = 15 + DO 430 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 430 CONTINUE + SRNAMT = 'SSTEVX' + CALL SSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 15 ) = ULPINV + GO TO 440 + END IF + END IF +* +* Do test 15. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 440 CONTINUE +* + NTEST = 16 + DO 450 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 450 CONTINUE + DO 460 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 460 CONTINUE + SRNAMT = 'SSTEVD' + CALL SSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVD(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + RESULT( 17 ) = ULPINV + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do tests 16 and 17. +* + DO 470 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 470 CONTINUE + DO 480 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 480 CONTINUE + CALL SSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK, + $ RESULT( 16 ) ) +* + NTEST = 18 + DO 490 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 490 CONTINUE + SRNAMT = 'SSTEVD' + CALL SSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVD(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 510 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 500 J = 1, N + TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ), + $ ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) ) + 500 CONTINUE + RESULT( 18 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 510 CONTINUE +* + NTEST = 19 + DO 520 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 520 CONTINUE + DO 530 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 530 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* DO tests 19 and 20. +* + DO 540 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 540 CONTINUE + DO 550 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 550 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 19 ) ) +* +* + NTEST = 21 + DO 560 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 560 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,I)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 21 ) = ULPINV + GO TO 570 + END IF + END IF +* +* Do test 21. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 ) +* + 570 CONTINUE +* + NTEST = 21 + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF* + $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF* + $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3, + $ TEN*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + DO 580 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 580 CONTINUE + DO 590 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 590 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* + IF( M2.EQ.0 .AND. N.GT.0 ) THEN + RESULT( 22 ) = ULPINV + RESULT( 23 ) = ULPINV + RESULT( 24 ) = ULPINV + GO TO 630 + END IF +* +* Do tests 22 and 23. +* + DO 600 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 600 CONTINUE + DO 610 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 610 CONTINUE + CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK, + $ MAX( 1, M2 ), RESULT( 22 ) ) +* + NTEST = 24 + DO 620 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 620 CONTINUE + SRNAMT = 'SSTEVR' + CALL SSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 630 + END IF + END IF +* +* Do test 24. +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* + 630 CONTINUE +* +* +* + ELSE +* + DO 640 I = 1, 24 + RESULT( I ) = ZERO + 640 CONTINUE + NTEST = 24 + END IF +* +* Perform remaining tests storing upper or lower triangular +* part of matrix. +* + DO 1720 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* 4) Call SSYEV and SSYEVX. +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'SSYEV' + CALL SSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do tests 25 and 26 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEV_2STAGE' + CALL SSYEV_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do test 27 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 650 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 650 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 660 CONTINUE + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'SSYEVX' + CALL SSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do tests 28 and 29 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEVX_2STAGE' + CALL SSYEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 680 + END IF + END IF +* +* Do test 30 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 680 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX' + CALL SSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do tests 31 and 32 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX_2STAGE' + CALL SSYEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 690 + END IF + END IF +* +* Do test 33 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 690 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX' + CALL SSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 34 and 35 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVX_2STAGE' + CALL SSYEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK, + $ LWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 36 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 700 CONTINUE +* +* 5) Call SSPEV and SSPEVX. +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 720 J = 1, N + DO 710 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 710 CONTINUE + 720 CONTINUE + ELSE + INDX = 1 + DO 740 J = 1, N + DO 730 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 730 CONTINUE + 740 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSPEV' + CALL SSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do tests 37 and 38 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 760 J = 1, N + DO 750 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 750 CONTINUE + 760 CONTINUE + ELSE + INDX = 1 + DO 780 J = 1, N + DO 770 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 770 CONTINUE + 780 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSPEV' + CALL SSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 800 + END IF + END IF +* +* Do test 39 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 790 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 790 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 800 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 820 J = 1, N + DO 810 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 810 CONTINUE + 820 CONTINUE + ELSE + INDX = 1 + DO 840 J = 1, N + DO 830 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 830 CONTINUE + 840 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do tests 40 and 41 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 860 J = 1, N + DO 850 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 850 CONTINUE + 860 CONTINUE + ELSE + INDX = 1 + DO 880 J = 1, N + DO 870 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 870 CONTINUE + 880 CONTINUE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 900 + END IF + END IF +* +* Do test 42 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 890 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 890 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 900 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 920 J = 1, N + DO 910 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 910 CONTINUE + 920 CONTINUE + ELSE + INDX = 1 + DO 940 J = 1, N + DO 930 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 930 CONTINUE + 940 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 990 + END IF + END IF +* +* Do tests 43 and 44 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 960 J = 1, N + DO 950 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 950 CONTINUE + 960 CONTINUE + ELSE + INDX = 1 + DO 980 J = 1, N + DO 970 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 970 CONTINUE + 980 CONTINUE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 990 + END IF +* +* Do test 45 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 990 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1080 + END IF + END IF +* +* Do tests 46 and 47 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1050 J = 1, N + DO 1040 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1040 CONTINUE + 1050 CONTINUE + ELSE + INDX = 1 + DO 1070 J = 1, N + DO 1060 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1060 CONTINUE + 1070 CONTINUE + END IF +* + SRNAMT = 'SSPEVX' + CALL SSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1080 + END IF +* +* Do test 48 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1080 CONTINUE +* +* 6) Call SSBEV and SSBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1100 J = 1, N + DO 1090 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1090 CONTINUE + 1100 CONTINUE + ELSE + DO 1120 J = 1, N + DO 1110 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1110 CONTINUE + 1120 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSBEV' + CALL SSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 49 and 50 (or ... ) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1140 J = 1, N + DO 1130 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1130 CONTINUE + 1140 CONTINUE + ELSE + DO 1160 J = 1, N + DO 1150 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1150 CONTINUE + 1160 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSBEV_2STAGE' + CALL SSBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 51 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1170 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1170 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1180 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 1200 J = 1, N + DO 1190 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1190 CONTINUE + 1200 CONTINUE + ELSE + DO 1220 J = 1, N + DO 1210 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1210 CONTINUE + 1220 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSBEVX' + CALL SSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do tests 52 and 53 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1240 J = 1, N + DO 1230 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1230 CONTINUE + 1240 CONTINUE + ELSE + DO 1260 J = 1, N + DO 1250 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1250 CONTINUE + 1260 CONTINUE + END IF +* + SRNAMT = 'SSBEVX_2STAGE' + CALL SSBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1280 + END IF + END IF +* +* Do test 54 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1270 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) ) + 1270 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1280 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1300 J = 1, N + DO 1290 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1290 CONTINUE + 1300 CONTINUE + ELSE + DO 1320 J = 1, N + DO 1310 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1310 CONTINUE + 1320 CONTINUE + END IF +* + SRNAMT = 'SSBEVX' + CALL SSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do tests 55 and 56 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1340 J = 1, N + DO 1330 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1330 CONTINUE + 1340 CONTINUE + ELSE + DO 1360 J = 1, N + DO 1350 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1350 CONTINUE + 1360 CONTINUE + END IF +* + SRNAMT = 'SSBEVX_2STAGE' + CALL SSBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1370 + END IF + END IF +* +* Do test 57 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 1390 J = 1, N + DO 1380 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1380 CONTINUE + 1390 CONTINUE + ELSE + DO 1410 J = 1, N + DO 1400 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1400 CONTINUE + 1410 CONTINUE + END IF +* + SRNAMT = 'SSBEVX' + CALL SSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1460 + END IF + END IF +* +* Do tests 58 and 59 (or +54) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 1430 J = 1, N + DO 1420 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1420 CONTINUE + 1430 CONTINUE + ELSE + DO 1450 J = 1, N + DO 1440 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1440 CONTINUE + 1450 CONTINUE + END IF +* + SRNAMT = 'SSBEVX_2STAGE' + CALL SSBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, M3, WA3, + $ Z, LDU, WORK, LWORK, IWORK, IWORK( 5*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1460 + END IF +* +* Do test 60 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 1460 CONTINUE +* +* 7) Call SSYEVD +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'SSYEVD' + CALL SSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do tests 61 and 62 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEVD_2STAGE' + CALL SSYEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1480 + END IF + END IF +* +* Do test 63 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1470 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1470 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1480 CONTINUE +* +* 8) Call SSPEVD. +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1500 J = 1, N + DO 1490 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1490 CONTINUE + 1500 CONTINUE + ELSE + INDX = 1 + DO 1520 J = 1, N + DO 1510 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1510 CONTINUE + 1520 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSPEVD' + CALL SSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do tests 64 and 65 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1540 J = 1, N + DO 1530 I = 1, J +* + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1530 CONTINUE + 1540 CONTINUE + ELSE + INDX = 1 + DO 1560 J = 1, N + DO 1550 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1550 CONTINUE + 1560 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSPEVD' + CALL SSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1580 + END IF + END IF +* +* Do test 66 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1570 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1570 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + 1580 CONTINUE +* +* 9) Call SSBEVD. +* + IF( JTYPE.LE.7 ) THEN + KD = 1 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1600 J = 1, N + DO 1590 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1590 CONTINUE + 1600 CONTINUE + ELSE + DO 1620 J = 1, N + DO 1610 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1610 CONTINUE + 1620 CONTINUE + END IF +* + NTEST = NTEST + 1 + SRNAMT = 'SSBEVD' + CALL SSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSBEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do tests 67 and 68 (or +54) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1640 J = 1, N + DO 1630 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1630 CONTINUE + 1640 CONTINUE + ELSE + DO 1660 J = 1, N + DO 1650 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1650 CONTINUE + 1660 CONTINUE + END IF +* + NTEST = NTEST + 2 + SRNAMT = 'SSBEVD_2STAGE' + CALL SSBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1680 + END IF + END IF +* +* Do test 69 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1670 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1670 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1680 CONTINUE +* +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + SRNAMT = 'SSYEVR' + CALL SSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do tests 70 and 71 (or ... ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + SRNAMT = 'SSYEVR_2STAGE' + CALL SSYEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1700 + END IF + END IF +* +* Do test 72 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1690 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1690 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1700 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR' + CALL SSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do tests 73 and 74 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR_2STAGE' + CALL SSYEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1710 + END IF + END IF +* +* Do test 75 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1710 CONTINUE +* + NTEST = NTEST + 1 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR' + CALL SSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ IWORK(2*N+1), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 700 + END IF + END IF +* +* Do tests 76 and 77 (or +54) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) + SRNAMT = 'SSYEVR_2STAGE' + CALL SSYEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, IWORK, + $ WORK, LWORK, IWORK(2*N+1), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'SSYEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 700 + END IF +* +* Do test 78 (or +54) +* + TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + 1720 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST +* + CALL SLAFTS( 'SST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1730 CONTINUE + 1740 CONTINUE +* +* Summary +* + CALL ALASVM( 'SST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' SDRVST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + RETURN +* +* End of SDRVST2STG +* + END diff --git a/TESTING/EIG/serrst.f b/TESTING/EIG/serrst.f index 266e9ec1..dd341aea 100644 --- a/TESTING/EIG/serrst.f +++ b/TESTING/EIG/serrst.f @@ -25,6 +25,10 @@ *> SOPGTR, SOPMTR, SSTEQR, SSTERF, SSTEBZ, SSTEIN, SPTEQR, SSBTRD, *> SSYEV, SSYEVX, SSYEVD, SSBEV, SSBEVX, SSBEVD, *> SSPEV, SSPEVX, SSPEVD, SSTEV, SSTEVX, SSTEVD, and SSTEDC. +*> SSYEVD_2STAGE, SSYEVR_2STAGE, SSYEVX_2STAGE, +*> SSYEV_2STAGE, SSBEV_2STAGE, SSBEVD_2STAGE, +*> SSBEVX_2STAGE, SSYTRD_2STAGE, SSYTRD_SY2SB, +*> SSYTRD_SB2ST *> \endverbatim * * Arguments: @@ -94,7 +98,11 @@ $ SSBEV, SSBEVD, SSBEVX, SSBTRD, SSPEV, SSPEVD, $ SSPEVX, SSPTRD, SSTEBZ, SSTEDC, SSTEIN, SSTEQR, $ SSTERF, SSTEV, SSTEVD, SSTEVR, SSTEVX, SSYEV, - $ SSYEVD, SSYEVR, SSYEVX, SSYTRD + $ SSYEVD, SSYEVR, SSYEVX, SSYTRD, + $ SSYEVD_2STAGE, SSYEVR_2STAGE, SSYEVX_2STAGE, + $ SSYEV_2STAGE, SSBEV_2STAGE, SSBEVD_2STAGE, + $ SSBEVX_2STAGE, SSYTRD_2STAGE, SSYTRD_SY2SB, + $ SSYTRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -152,6 +160,103 @@ CALL CHKXER( 'SSYTRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* SSYTRD_2STAGE +* + SRNAMT = 'SSYTRD_2STAGE' + INFOT = 1 + CALL SSYTRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYTRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSYTRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* SSYTRD_SY2SB +* + SRNAMT = 'SSYTRD_SY2SB' + INFOT = 1 + CALL SSYTRD_SY2SB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SY2SB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_SY2SB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_SY2SB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRD_SY2SB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYTRD_SY2SB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_SY2SB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* SSYTRD_SB2ST +* + SRNAMT = 'SSYTRD_SB2ST' + INFOT = 1 + CALL SSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_SB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSYTRD_SB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SORGTR * SRNAMT = 'SORGTR' @@ -536,6 +641,44 @@ CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* SSYEVD_2STAGE +* + SRNAMT = 'SSYEVD_2STAGE' + INFOT = 1 + CALL SSYEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL SSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO ) +* CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, IW, 0, INFO ) + CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL SSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO ) +* CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SSYEVR * SRNAMT = 'SSYEVR' @@ -589,6 +732,74 @@ CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* SSYEVR_2STAGE +* + SRNAMT = 'SSYEVR_2STAGE' + N = 1 + INFOT = 1 + CALL SSYEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSYEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0E0, 0.0E0, 2, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 0, IW( 2*N+1 ), 10*N, + $ INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL SSYEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 1, 0.0E0, + $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 0, + $ INFO ) + CALL CHKXER( 'SSYEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 +* * SSYEV * SRNAMT = 'SSYEV ' @@ -609,6 +820,29 @@ CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* SSYEV_2STAGE +* + SRNAMT = 'SSYEV_2STAGE ' + INFOT = 1 + CALL SSYEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEV_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SSYEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * SSYEVX * SRNAMT = 'SSYEVX' @@ -661,6 +895,75 @@ CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* SSYEVX_2STAGE +* + SRNAMT = 'SSYEVX_2STAGE' + INFOT = 1 + CALL SSYEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSYEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0E0, 1.0E0, 1, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + INFOT = 4 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 1, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 2, 1, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0E0, 0.0E0, 2, 1, 0.0E0, + $ M, X, Z, 1, W, 16, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 1, 2, 0.0E0, + $ M, X, Z, 1, W, 8, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 0, W, 16, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL SSYEVX_2STAGE( 'N', 'A', 'U', 1, A, 1, + $ 0.0E0, 0.0E0, 0, 0, 0.0E0, + $ M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSYEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * SSPEVD * SRNAMT = 'SSPEVD' @@ -784,6 +1087,47 @@ CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* SSYTRD_SB2ST +* + SRNAMT = 'SSYTRD_SB2ST' + INFOT = 1 + CALL SSYTRD_SB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRD_SB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRD_SB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSYTRD_SB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'SSYTRD_SB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SSBEVD * SRNAMT = 'SSBEVD' @@ -827,6 +1171,60 @@ CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* SSBEVD_2STAGE +* + SRNAMT = 'SSBEVD_2STAGE' + INFOT = 1 + CALL SSBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, + $ 1, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, + $ 4, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL SSBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, +* $ 25, IW, 12, INFO ) +* CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 0, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEVD_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, + $ 3, IW, 1, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL SSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 18, IW, 12, INFO ) +* CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, + $ 1, IW, 0, INFO ) + CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL SSBEVD_2STAGE( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, +* $ 25, IW, 11, INFO ) +* CALL CHKXER( 'SSBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 12 + NT = NT + 9 +* * SSBEV * SRNAMT = 'SSBEV ' @@ -850,6 +1248,35 @@ CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* SSBEV_2STAGE +* + SRNAMT = 'SSBEV_2STAGE ' + INFOT = 1 + CALL SSBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, Z, 0, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEV_2STAGE( 'N', 'U', 0, 0, A, 1, X, Z, 1, W, 0, INFO ) + CALL CHKXER( 'SSBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * SSBEVX * SRNAMT = 'SSBEVX' @@ -864,6 +1291,7 @@ INFOT = 3 CALL SSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0, $ 0.0, M, X, Z, 1, W, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0, $ 0.0, M, X, Z, 1, W, IW, I3, INFO ) @@ -905,6 +1333,72 @@ $ 0.0, M, X, Z, 1, W, IW, I3, INFO ) CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 13 +* +* SSBEVX_2STAGE +* + SRNAMT = 'SSBEVX_2STAGE' + INFOT = 1 + CALL SSBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL SSBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL SSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0E0, +* $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 2, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 2, 1, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 2, 1, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SSBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 1, 2, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 18 +* CALL SSBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0E0, +* $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) +* CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL SSBEVX_2STAGE( 'N', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0E0, + $ 0.0E0, 0, 0, 0.0E0, M, X, Z, 1, W, 0, IW, I3, INFO ) + CALL CHKXER( 'SSBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* NT = NT + 15 + NT = NT + 13 END IF * * Print a summary line. diff --git a/TESTING/EIG/zchkee.f b/TESTING/EIG/zchkee.f index 9ca71cee..768ed7c8 100644 --- a/TESTING/EIG/zchkee.f +++ b/TESTING/EIG/zchkee.f @@ -1102,7 +1102,8 @@ $ ZDRGES, ZDRGEV, ZDRGSX, ZDRGVX, ZDRVBD, ZDRVES, $ ZDRVEV, ZDRVSG, ZDRVST, ZDRVSX, ZDRVVX, $ ZERRBD, ZERRED, ZERRGG, ZERRHS, ZERRST, ILAVER, - $ ZDRGES3, ZDRGEV3 + $ ZDRGES3, ZDRGEV3, + $ ZCHKST2STG, ZDRVST2STG, ZCHKHB2STG * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1149,7 +1150,7 @@ PATH = LINE( 1: 3 ) NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'ZHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'ZST' ) .OR. - $ LSAMEN( 3, PATH, 'ZSG' ) + $ LSAMEN( 3, PATH, 'ZSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'ZBD' ) ZEV = LSAMEN( 3, PATH, 'ZEV' ) ZES = LSAMEN( 3, PATH, 'ZES' ) @@ -1829,7 +1830,8 @@ $ WRITE( NOUT, FMT = 9980 )'ZCHKHS', INFO 270 CONTINUE * - ELSE IF( LSAMEN( 3, C3, 'ZST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN + ELSE IF( LSAMEN( 3, C3, 'ZST' ) .OR. LSAMEN( 3, C3, 'SEP' ) + $ .OR. LSAMEN( 3, C3, 'SE2' ) ) THEN * * ---------------------------------- * SEP: Symmetric Eigenvalue Problem @@ -1859,6 +1861,17 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL ZCHKST2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), + $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), + $ DR( 1, 4 ), DR( 1, 5 ), DR( 1, 6 ), + $ DR( 1, 7 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), DR( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), + $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) + ELSE CALL ZCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), $ DR( 1, 1 ), DR( 1, 2 ), DR( 1, 3 ), @@ -1868,16 +1881,26 @@ $ A( 1, 4 ), A( 1, 5 ), DC( 1, 1 ), A( 1, 6 ), $ WORK, LWORK, RWORK, LWORK, IWORK, LIWORK, $ RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZCHKST', INFO END IF IF( TSTDRV ) THEN + IF( LSAMEN( 3, C3, 'SE2' ) ) THEN + CALL ZDRVST2STG( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ELSE CALL ZDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT, - $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), - $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), - $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), - $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, - $ LWORK, IWORK, LIWORK, RESULT, INFO ) + $ A( 1, 1 ), NMAX, DR( 1, 3 ), DR( 1, 4 ), + $ DR( 1, 5 ), DR( 1, 8 ), DR( 1, 9 ), + $ DR( 1, 10 ), A( 1, 2 ), NMAX, A( 1, 3 ), + $ DC( 1, 1 ), A( 1, 4 ), WORK, LWORK, RWORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + ENDIF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZDRVST', INFO END IF @@ -1910,12 +1933,18 @@ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), $ NXVAL( I ) IF( TSTCHK ) THEN - CALL ZDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, - $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, - $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, - $ INFO ) +* CALL ZDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ DR( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, RWORK, LWORK, IWORK, LIWORK, RESULT, +* $ INFO ) + CALL ZDRVSG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ DR( 1, 3 ), DR( 1, 4 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, RWORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZDRVSG', INFO END IF @@ -2276,10 +2305,15 @@ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) IF( TSTERR ) $ CALL ZERRST( 'ZHB', NOUT ) - CALL ZCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, - $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), - $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, - $ INFO ) +* CALL ZCHKHB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), DR( 1, 2 ), +* $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, +* $ INFO ) + CALL ZCHKHB2STG( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, + $ THRESH, NOUT, A( 1, 1 ), NMAX, DR( 1, 1 ), + $ DR( 1, 2 ), DR( 1, 3 ), DR( 1, 4 ), DR( 1, 5 ), + $ A( 1, 2 ), NMAX, WORK, LWORK, RWORK, RESULT, + $ INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZCHKHB', INFO * diff --git a/TESTING/EIG/zchkhb2stg.f b/TESTING/EIG/zchkhb2stg.f new file mode 100644 index 00000000..0660b6fb --- /dev/null +++ b/TESTING/EIG/zchkhb2stg.f @@ -0,0 +1,880 @@ +*> \brief \b ZCHKHBSTG +* +* @precisions fortran z -> c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHBSTG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, +* ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, +* D2, D3, U, LDU, WORK, LWORK, RWORK RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES, +* $ NWDTHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), KK( * ), NN( * ) +* DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ) +* COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHBSTG tests the reduction of a Hermitian band matrix to tridiagonal +*> from, used with the Hermitian eigenvalue problem. +*> +*> ZHBTRD factors a Hermitian band matrix A as U S U* , where * means +*> conjugate transpose, S is symmetric tridiagonal, and U is unitary. +*> ZHBTRD can use either just the lower or just the upper triangle +*> of A; ZCHKHBSTG checks both cases. +*> +*> ZHETRD_HB2ST factors a Hermitian band matrix A as U S U* , +*> where * means conjugate transpose, S is symmetric tridiagonal, and U is +*> unitary. ZHETRD_HB2ST can use either just the lower or just +*> the upper triangle of A; ZCHKHBSTG checks both cases. +*> +*> DSTEQR factors S as Z D1 Z'. +*> D1 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSBTRD "U" (used as reference for DSYTRD_SB2ST) +*> D2 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "U". +*> D3 is the matrix of eigenvalues computed when Z is not computed +*> and from the S resulting of DSYTRD_SB2ST "L". +*> +*> When ZCHKHBSTG is called, a number of matrix "sizes" ("n's"), a number +*> of bandwidths ("k's"), and a number of matrix "types" are +*> specified. For each size ("n"), each bandwidth ("k") less than or +*> equal to "n", and each type of matrix, one matrix will be generated +*> and used to test the hermitian banded reduction routine. For each +*> matrix, a number of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with +*> UPLO='U' +*> +*> (2) | I - UU* | / ( n ulp ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with +*> UPLO='L' +*> +*> (4) | I - UU* | / ( n ulp ) +*> +*> (5) | D1 - D2 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D2 is computed by +*> ZHETRD_HB2ST with UPLO='U' +*> +*> (6) | D1 - D3 | / ( |D1| ulp ) where D1 is computed by +*> DSBTRD with UPLO='U' and +*> D3 is computed by +*> ZHETRD_HB2ST with UPLO='L' +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZCHKHBSTG 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] NWDTHS +*> \verbatim +*> NWDTHS is INTEGER +*> The number of bandwidths to use. If it is zero, +*> ZCHKHBSTG does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] KK +*> \verbatim +*> KK is INTEGER array, dimension (NWDTHS) +*> An array containing the bandwidths to be used for the band +*> matrices. 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, ZCHKHBSTG +*> 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 ZCHKHBSTG 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] 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 matrix whose eigenvalues are to be +*> computed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 2 (not 1!) +*> and at least max( KK )+1. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the diagonal of the tridiagonal matrix computed +*> by ZHBTRD. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array, dimension (max(NN)) +*> Used to hold the off-diagonal of the tridiagonal matrix +*> computed by ZHBTRD. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX*16 array, dimension (LDU, max(NN)) +*> Used to hold the unitary matrix computed by ZHBTRD. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. It must be at least 1 +*> and at least max( NN ). +*> \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( LDA+1, max(NN)+1 )*max(NN). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (4) +*> 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 +*> If 0, then everything ran OK. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 ZCHKHB2STG( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, + $ ISEED, THRESH, NOUNIT, A, LDA, SD, SE, D1, + $ D2, D3, U, LDU, 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, LDU, LWORK, NOUNIT, NSIZES, NTYPES, + $ NWDTHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), KK( * ), NN( * ) + DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ D1( * ), D2( * ), D3( * ) + COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ TEN = 10.0D+0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 15 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, BADNNB + INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE, + $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS, + $ NMATS, NMAX, NTEST, NTESTT + DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, + $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ), + $ KMODE( MAXTYP ), KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLASUM, XERBLA, ZHBT21, ZHBTRD, ZLACPY, ZLASET, + $ ZLATMR, ZLATMS, ZHBTRD_HB2ST, ZSTEQR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + BADNNB = .FALSE. + KMAX = 0 + DO 20 J = 1, NSIZES + KMAX = MAX( KMAX, KK( J ) ) + IF( KK( J ).LT.0 ) + $ BADNNB = .TRUE. + 20 CONTINUE + KMAX = MIN( NMAX-1, KMAX ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NWDTHS.LT.0 ) THEN + INFO = -3 + ELSE IF( BADNNB ) THEN + INFO = -4 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.KMAX+1 ) THEN + INFO = -11 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -15 + ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZCHKHBSTG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + DO 180 JWIDTH = 1, NWDTHS + K = KK( JWIDTH ) + IF( K.GT.N ) + $ GO TO 180 + K = MAX( 0, MIN( N-1, K ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 170 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 170 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A". +* Store as "Upper"; later, we will copy to other format. +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( K+1, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA, + $ WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, WORK, + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA, + $ IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, + $ CONE, 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K, + $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, K, K, 'Q', A, LDA, + $ WORK( N+1 ), IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + IF( N.GT.1 ) + $ K = MAX( 1, K ) + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, + $ COND, ANORM, 1, 1, 'Q', A( K, 1 ), LDA, + $ WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( K, I ) ) / + $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( K, I ) = HALF*SQRT( ABS( A( K+1, + $ I-1 )*A( K+1, I ) ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call ZHBTRD to compute S and U from upper triangle. +* + CALL ZLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 1 + CALL ZHBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBTRD(U)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL ZHBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 1 ) ) +* +* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST +* otherwise matrix A will be converted to lower and then need +* to be converted back to upper in order to run the upper case +* ofDSYTRD_SB2ST +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the DSBTRD and used as reference to compare +* with the DSYTRD_SB2ST routine +* +* Compute D1 from the DSBTRD and used as reference for the +* DSYTRD_SB2ST +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D1, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* DSYTRD_SB2ST Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL ZHETRD_HB2ST( 'N', 'N', "U", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the DSYTRD_SB2ST Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D2, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Convert A from Upper-Triangle-Only storage to +* Lower-Triangle-Only storage. +* + DO 120 JC = 1, N + DO 110 JR = 0, MIN( K, N-JC ) + A( JR+1, JC ) = DCONJG( A( K+1-JR, JC+JR ) ) + 110 CONTINUE + 120 CONTINUE + DO 140 JC = N + 1 - K, N + DO 130 JR = MIN( K, N-JC ) + 1, K + A( JR+1, JC ) = ZERO + 130 CONTINUE + 140 CONTINUE +* +* Call ZHBTRD to compute S and U from lower triangle +* + CALL ZLACPY( ' ', K+1, N, A, LDA, WORK, LDA ) +* + NTEST = 3 + CALL ZHBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU, + $ WORK( LDA*N+1 ), IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBTRD(L)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 150 + END IF + END IF + NTEST = 4 +* +* Do tests 3 and 4 +* + CALL ZHBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU, + $ WORK, RWORK, RESULT( 3 ) ) +* +* DSYTRD_SB2ST Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the DSBTRD. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( ' ', K+1, N, A, LDA, U, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL ZHETRD_HB2ST( 'N', 'N', "L", N, K, U, LDU, SD, SE, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D3, RWORK, WORK, LDU, + $ RWORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 150 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 6 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT(5) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT(6) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 150 CONTINUE + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 160 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 = 9998 )'ZHB' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 )'unitary', '*', + $ 'conjugate transpose', ( '*', J = 1, 6 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE, + $ JR, RESULT( JR ) + END IF + 160 CONTINUE +* + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL DLASUM( 'ZHB', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' ZCHKHBSTG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( / 1X, A3, + $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines' + $ ) + 9997 FORMAT( ' Matrix types (see DCHK23 for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Banded Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) +* + 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',', + $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':', + $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':', + $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ', + $ ' 4= | I - U U', A1, ' | / ( n ulp )' / ' Eig check:', + $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ', + $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' ) + 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ', + $ I2, ', test(', I2, ')=', G10.3 ) +* +* End of ZCHKHBSTG +* + END diff --git a/TESTING/EIG/zchkst2stg.f b/TESTING/EIG/zchkst2stg.f new file mode 100644 index 00000000..a1aaffbc --- /dev/null +++ b/TESTING/EIG/zchkst2stg.f @@ -0,0 +1,2145 @@ +*> \brief \b ZCHKST2STG +* +* @precisions fortran z -> c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), +* $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), +* $ WA1( * ), WA2( * ), WA3( * ), WR( * ) +* COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKST2STG checks the Hermitian eigenvalue problem routines +*> using the 2-stage reduction techniques. Since the generation +*> of Q or the vectors is not available in this release, we only +*> compare the eigenvalue resulting when using the 2-stage to the +*> one considered as reference using the standard 1-stage reduction +*> ZHETRD. For that, we call the standard ZHETRD and compute D1 using +*> DSTEQR, then we call the 2-stage ZHETRD_2STAGE with Upper and Lower +*> and we compute D2 and D3 using DSTEQR and then we replaced tests +*> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that +*> the 1-stage results are OK and can be trusted. +*> This testing routine will converge to the ZCHKST in the next +*> release when vectors and generation of Q will be implemented. +*> +*> ZHETRD factors A as U S U* , where * means conjugate transpose, +*> S is real symmetric tridiagonal, and U is unitary. +*> ZHETRD can use either just the lower or just the upper triangle +*> of A; ZCHKST2STG checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> ZHPTRD does the same as ZHETRD, except that A and V are stored +*> in "packed" format. +*> +*> ZUNGTR constructs the matrix U from the contents of V and TAU. +*> +*> ZUPGTR constructs the matrix U from the contents of VP and TAU. +*> +*> ZSTEQR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> DSTERF computes D3, the matrix of eigenvalues, by the +*> PWK method, which does not yield eigenvectors. +*> +*> ZPTEQR factors S as Z4 D4 Z4* , for a +*> Hermitian positive definite tridiagonal matrix. +*> D5 is the matrix of eigenvalues computed when Z is not +*> computed. +*> +*> DSTEBZ computes selected eigenvalues. WA1, WA2, and +*> WA3 will denote eigenvalues computed to high +*> absolute accuracy, with different range options. +*> WR will denote eigenvalues computed to high relative +*> accuracy. +*> +*> ZSTEIN computes Y, the eigenvectors of S, given the +*> eigenvalues. +*> +*> ZSTEDC factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). It may also +*> update an input unitary matrix, usually the output +*> from ZHETRD/ZUNGTR or ZHPTRD/ZUPGTR ('V' option). It may +*> also just compute eigenvalues ('N' option). +*> +*> ZSTEMR factors S as Z D1 Z* , where Z is the unitary +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal ('I' option). ZSTEMR +*> uses the Relatively Robust Representation whenever possible. +*> +*> When ZCHKST2STG 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 Hermitian eigenroutines. For each matrix, a number +*> of tests will be performed: +*> +*> (1) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='U', ... ) +*> +*> (2) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='L', ... ) +*> replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D2 is the +*> eigenvalue matrix computed using S_2stage the output of +*> ZHETRD_2STAGE("N", "U",....). D1 and D2 are computed +*> via DSTEQR('N',...) +*> +*> (4) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='L', ... ) +*> replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the +*> eigenvalue matrix computed using S and D3 is the +*> eigenvalue matrix computed using S_2stage the output of +*> ZHETRD_2STAGE("N", "L",....). D1 and D3 are computed +*> via DSTEQR('N',...) +*> +*> (5-8) Same as 1-4, but for ZHPTRD and ZUPGTR. +*> +*> (9) | S - Z D Z* | / ( |S| n ulp ) ZSTEQR('V',...) +*> +*> (10) | I - ZZ* | / ( n ulp ) ZSTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) ZSTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) DSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> DSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) ZPTEQR('V',...) +*> +*> (15) | I - Z4 Z4* | / ( n ulp ) ZPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) ZPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> DSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> DSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y* | / ( |S| n ulp ) DSTEBZ, ZSTEIN +*> +*> (21) | I - Y Y* | / ( n ulp ) DSTEBZ, ZSTEIN +*> +*> (22) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('I') +*> +*> (23) | I - ZZ* | / ( n ulp ) ZSTEDC('I') +*> +*> (24) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('V') +*> +*> (25) | I - ZZ* | / ( n ulp ) ZSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) ZSTEDC('V') and +*> ZSTEDC('N') +*> +*> Test 27 is disabled at the moment because ZSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> ZSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> ZSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because ZSTEMR +*> does not handle partial specturm requests. +*> +*> (29) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'I') +*> +*> (30) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> ZSTEMR('N', 'I') vs. CSTEMR('V', 'I') +*> +*> (32) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'V') +*> +*> (33) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> ZSTEMR('N', 'V') vs. CSTEMR('V', 'V') +*> +*> (35) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'A') +*> +*> (36) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> ZSTEMR('N', 'A') vs. CSTEMR('V', 'A') +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZCHKST2STG 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, ZCHKST2STG +*> 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 ZCHKST2STG 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] 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 of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is COMPLEX*16 array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by ZHETRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> ZHETRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZPTEQR(V). +*> ZPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by ZPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by DSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by DSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX*16 array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix computed by ZHETRD + ZUNGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by ZHETRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in ZHETRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as ZUNGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is COMPLEX*16 array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array of +*> dimension( max(NN) ) +*> The Householder factors computed by ZHETRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array of +*> dimension( LDU, max(NN) ). +*> The unitary matrix of eigenvectors computed by ZSTEQR, +*> ZPTEQR, and ZSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The number of entries in LRWORK (dimension( ??? ) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (26) +*> 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 +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If ZLATMR, CLATMS, ZHETRD, ZUNGTR, ZSTEQR, DSTERF, +*> or ZUNMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 ZCHKST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), + $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), + $ WA1( * ), WA2( * ), WA3( * ), WR( * ) + COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL CRANGE + PARAMETER ( CRANGE = .FALSE. ) + LOGICAL CREL + PARAMETER ( CREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP, + $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN, + $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3, + $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX, + $ NSPLIT, NTEST, NTESTT, LH, LW + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + DOUBLE PRECISION DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLASUM, DSTEBZ, DSTECH, DSTERF, + $ XERBLA, ZCOPY, ZHET21, ZHETRD, ZHPT21, ZHPTRD, + $ ZLACPY, ZLASET, ZLATMR, ZLATMS, ZPTEQR, ZSTEDC, + $ ZSTEMR, ZSTEIN, ZSTEQR, ZSTT21, ZSTT22, ZUNGTR, + $ ZUPGTR, ZHETRD_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'ZHETRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZCHKST2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LRWEDC = 1 + 3*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LRWEDC = 7 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Positive definite, eigenvalues specified. +* + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* Positive definite tridiagonal, eigenvalues specified. +* + CALL ZLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK, IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) + TEMP2 = SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF*TEMP2 ) THEN + A( I-1, I ) = A( I-1, I )* + $ ( HALF*TEMP2 / ( UNFL+TEMP1 ) ) + A( I, I-1 ) = DCONJG( A( I-1, I ) ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call ZHETRD and ZUNGTR to compute S and U from +* upper triangle. +* + CALL ZLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL ZHETRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHETRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL ZUNGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUNGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL ZHET21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 1 ) ) + CALL ZHET21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 2 ) ) +* +* Compute D1 the eigenvalues resulting from the tridiagonal +* form using the standard 1-stage algorithm and use it as a +* reference to compare with the 2-stage technique +* +* Compute D1 from the 1-stage and used as reference for the +* 2-stage +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + CALL ZSTEQR( 'N', N, D1, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Upper case is used to compute D2. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( 'U', N, N, A, LDA, V, LDU ) + LH = MAX(1, 4*N) + LW = LWORK - LH + CALL ZHETRD_2STAGE( 'N', "U", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D2 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 3 + CALL ZSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* +* 2-STAGE TRD Lower case is used to compute D3. +* Note to set SD and SE to zero to be sure not reusing +* the one from above. Compare it with D1 computed +* using the 1-stage. +* + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SD, 1 ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, SE, 1 ) + CALL ZLACPY( 'L', N, N, A, LDA, V, LDU ) + CALL ZHETRD_2STAGE( 'N', "L", N, V, LDU, SD, SE, TAU, + $ WORK, LH, WORK( LH+1 ), LW, IINFO ) +* +* Compute D3 from the 2-stage Upper case +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 4 + CALL ZSTEQR( 'N', N, D3, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* +* Do Tests 3 and 4 which are similar to 11 and 12 but with the +* D1 computed using the standard 1-stage reduction as reference +* + NTEST = 4 + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 151 CONTINUE +* + RESULT( 3 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 4 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Skip the DSYTRD for lower that since we replaced its testing +* 3 and 4 by the 2-stage one. + GOTO 101 +* +* Call ZHETRD and ZUNGTR to compute S and U from +* lower triangle, do tests. +* + CALL ZLACPY( 'L', N, N, A, LDA, V, LDU ) +* + NTEST = 3 + CALL ZHETRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK, + $ IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHETRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZLACPY( 'L', N, N, V, LDU, U, LDU ) +* + NTEST = 4 + CALL ZUNGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUNGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZHET21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 3 ) ) + CALL ZHET21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( 4 ) ) +* +*after skipping old tests 3 4 back to the normal +* + 101 CONTINUE +* +* Store the upper triangle of A in AP +* + I = 0 + DO 120 JC = 1, N + DO 110 JR = 1, JC + I = I + 1 + AP( I ) = A( JR, JC ) + 110 CONTINUE + 120 CONTINUE +* +* Call ZHPTRD and ZUPGTR to compute S and U from AP +* + CALL ZCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 5 + CALL ZHPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 6 + CALL ZUPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUPGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 5 and 6 +* + CALL ZHPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 5 ) ) + CALL ZHPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 6 ) ) +* +* Store the lower triangle of A in AP +* + I = 0 + DO 140 JC = 1, N + DO 130 JR = JC, N + I = I + 1 + AP( I ) = A( JR, JC ) + 130 CONTINUE + 140 CONTINUE +* +* Call ZHPTRD and ZUPGTR to compute S and U from AP +* + CALL ZCOPY( NAP, AP, 1, VP, 1 ) +* + NTEST = 7 + CALL ZHPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 7 ) = ULPINV + GO TO 280 + END IF + END IF +* + NTEST = 8 + CALL ZUPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZUPGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 8 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZHPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 7 ) ) + CALL ZHPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, + $ WORK, RWORK, RESULT( 8 ) ) +* +* Call ZSTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 9 + CALL ZSTEQR( 'V', N, D1, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 9 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 11 + CALL ZSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 11 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Compute D3 (using PWK method) +* + CALL DCOPY( N, SD, 1, D3, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 12 + CALL DSTERF( N, D3, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTERF', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 12 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 9 and 10 +* + CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 9 ) ) +* +* Do Tests 11 and 12 +* + TEMP1 = ZERO + TEMP2 = ZERO + TEMP3 = ZERO + TEMP4 = ZERO +* + DO 150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) + 150 CONTINUE +* + RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) + RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) +* +* Do Test 13 -- Sturm Sequence Test of Eigenvalues +* Go up by factors of two until it succeeds +* + NTEST = 13 + TEMP1 = THRESH*( HALF-ULP ) +* + DO 160 J = 0, LOG2UI + CALL DSTECH( N, SD, SE, D1, TEMP1, RWORK, IINFO ) + IF( IINFO.EQ.0 ) + $ GO TO 170 + TEMP1 = TEMP1*TWO + 160 CONTINUE +* + 170 CONTINUE + RESULT( 13 ) = TEMP1 +* +* For positive definite matrices ( JTYPE.GT.15 ) call ZPTEQR +* and do tests 14, 15, and 16 . +* + IF( JTYPE.GT.15 ) THEN +* +* Compute D4 and Z4 +* + CALL DCOPY( N, SD, 1, D4, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 14 + CALL ZPTEQR( 'V', N, D4, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZPTEQR(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 14 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 14 and 15 +* + CALL ZSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, + $ RWORK, RESULT( 14 ) ) +* +* Compute D5 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 16 + CALL ZPTEQR( 'N', N, D5, RWORK, Z, LDU, RWORK( N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZPTEQR(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 16 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 16 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 180 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) + 180 CONTINUE +* + RESULT( 16 ) = TEMP2 / MAX( UNFL, + $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 14 ) = ZERO + RESULT( 15 ) = ZERO + RESULT( 16 ) = ZERO + END IF +* +* Call DSTEBZ with different options and do tests 17-18. +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 ) THEN + NTEST = 17 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 17 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 17 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 190 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 190 CONTINUE +* + RESULT( 17 ) = TEMP1 / TEMP2 + ELSE + RESULT( 17 ) = ZERO + END IF +* +* Now ask for all eigenvalues with high absolute accuracy. +* + NTEST = 18 + ABSTOL = UNFL + UNFL + CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 18 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do test 18 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 200 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) + 200 CONTINUE +* + RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Choose random values for IL and IU, and ask for the +* IL-th through IU-th eigenvalues. +* + NTEST = 19 + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + END IF +* + CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Determine the values VL and VU of the IL-th and IU-th +* eigenvalues and ask for all eigenvalues in this range. +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), + $ ULP*ANORM, TWO*RTUNFL ) + ELSE + VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, + $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), + $ RWORK, IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 19 ) = ULPINV + GO TO 280 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.NE.0 ) THEN + RESULT( 19 ) = ULPINV + GO TO 280 + END IF +* +* Do test 19 +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) + ELSE + TEMP3 = ZERO + END IF +* + RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) +* +* Call ZSTEIN to compute eigenvectors corresponding to +* eigenvalues in WA1. (First call DSTEBZ again, to make sure +* it returns these eigenvalues in the correct order.) +* + NTEST = 21 + CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, + $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, + $ IWORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL ZSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, + $ LDU, RWORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEIN', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 20 ) = ULPINV + RESULT( 21 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 20 and 21 +* + CALL ZSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 20 ) ) +* +* Call ZSTEDC(I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + INDE = 1 + INDRWK = INDE + N + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 22 + CALL ZSTEDC( 'I', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(I)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 22 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 22 and 23 +* + CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 22 ) ) +* +* Call ZSTEDC(V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 24 + CALL ZSTEDC( 'V', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 24 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 24 and 25 +* + CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, + $ RESULT( 24 ) ) +* +* Call ZSTEDC(N) to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 26 + CALL ZSTEDC( 'N', N, D2, RWORK( INDE ), Z, LDU, WORK, LWEDC, + $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 26 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 26 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 210 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 210 CONTINUE +* + RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Only test ZSTEMR if IEEE compliant +* + IF( ILAENV( 10, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. + $ ILAENV( 11, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN +* +* Call ZSTEMR, do test 27 (relative eigenvalue accuracy) +* +* If S is positive definite and diagonally dominant, +* ask for all eigenvalues with high relative accuracy. +* + VL = ZERO + VU = ZERO + IL = 0 + IU = 0 + IF( JTYPE.EQ.21 .AND. CREL ) THEN + NTEST = 27 + ABSTOL = UNFL + UNFL + CALL ZSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,A,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 27 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 27 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / + $ ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 220 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / + $ ( ABSTOL+ABS( D4( J ) ) ) ) + 220 CONTINUE +* + RESULT( 27 ) = TEMP1 / TEMP2 +* + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF +* + IF( CRANGE ) THEN + NTEST = 28 + ABSTOL = UNFL + UNFL + CALL ZSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, + $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK, LRWORK, IWORK( 2*N+1 ), + $ LWORK-2*N, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,I,rel)', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 28 ) = ULPINV + GO TO 270 + END IF + END IF +* +* +* Do test 28 +* + TEMP2 = TWO*( TWO*N-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 +* + TEMP1 = ZERO + DO 230 J = IL, IU + TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ + $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) + 230 CONTINUE +* + RESULT( 28 ) = TEMP1 / TEMP2 + ELSE + RESULT( 28 ) = ZERO + END IF + ELSE + RESULT( 27 ) = ZERO + RESULT( 28 ) = ZERO + END IF +* +* Call ZSTEMR(V,I) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + IF( CRANGE ) THEN + NTEST = 29 + IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IF( IU.LT.IL ) THEN + ITEMP = IU + IU = IL + IL = ITEMP + END IF + CALL ZSTEMR( 'V', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 29 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 29 and 30 +* +* +* Call ZSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 31 + CALL ZSTEMR( 'N', 'I', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(N,I)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 31 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 31 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 240 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 240 CONTINUE +* + RESULT( 31 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* +* Call ZSTEMR(V,V) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) + CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) +* + NTEST = 32 +* + IF( N.GT.0 ) THEN + IF( IL.NE.1 ) THEN + VL = D2( IL ) - MAX( HALF* + $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D2( IU ) + MAX( HALF* + $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, + $ TWO*RTUNFL ) + ELSE + VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), + $ ULP*ANORM, TWO*RTUNFL ) + END IF + ELSE + VL = ZERO + VU = ONE + END IF +* + CALL ZSTEMR( 'V', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, M, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 32 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 32 and 33 +* + CALL ZSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, + $ M, RWORK, RESULT( 32 ) ) +* +* Call ZSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 34 + CALL ZSTEMR( 'N', 'V', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(N,V)', IINFO, + $ N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 34 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 250 J = 1, IU - IL + 1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 250 CONTINUE +* + RESULT( 34 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + ELSE + RESULT( 29 ) = ZERO + RESULT( 30 ) = ZERO + RESULT( 31 ) = ZERO + RESULT( 32 ) = ZERO + RESULT( 33 ) = ZERO + RESULT( 34 ) = ZERO + END IF +* +* +* Call ZSTEMR(V,A) to compute D1 and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 35 +* + CALL ZSTEMR( 'V', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 35 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Tests 35 and 36 +* + CALL ZSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, + $ RWORK, RESULT( 35 ) ) +* +* Call ZSTEMR to compute D2, do tests. +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, RWORK, 1 ) +* + NTEST = 37 + CALL ZSTEMR( 'N', 'A', N, D5, RWORK, VL, VU, IL, IU, + $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, + $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), + $ LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(N,A)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 37 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do Test 34 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 260 CONTINUE +* + RESULT( 37 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) + END IF + 270 CONTINUE + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 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 = 9998 )'ZST' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Hermitian' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9987 ) + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0D0 ) THEN + WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9988 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL DLASUM( 'ZST', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' ZCHKST2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see ZCHKST2STG for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 ) + 9988 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I3, ' is', 1P, D10.3 ) +* + 9987 FORMAT( / 'Test performed: see ZCHKST2STG for details.', / ) +* End of ZCHKST2STG +* + END diff --git a/TESTING/EIG/zdrvsg2stg.f b/TESTING/EIG/zdrvsg2stg.f new file mode 100644 index 00000000..f75ce60c --- /dev/null +++ b/TESTING/EIG/zdrvsg2stg.f @@ -0,0 +1,1384 @@ +*> \brief \b ZDRVSG2STG +* +* @precisions fortran z -> c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT, +* $ NSIZES, NTYPES, NWORK +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION D( * ), RESULT( * ), RWORK( * ) +* COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVSG2STG checks the complex Hermitian generalized eigenproblem +*> drivers. +*> +*> ZHEGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> ZHEGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem using a divide and conquer algorithm. +*> +*> ZHEGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem. +*> +*> ZHPGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> ZHPGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage using a divide and +*> conquer algorithm. +*> +*> ZHPGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite generalized +*> eigenproblem in packed storage. +*> +*> ZHBGV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> ZHBGVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem using a divide and conquer +*> algorithm. +*> +*> ZHBGVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian-definite banded +*> generalized eigenproblem. +*> +*> When ZDRVSG2STG 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 A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) ZHEGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> ZHEGV and D2 is computed by +*> ZHEGV_2STAGE. This test is +*> only performed for DSYGV +*> +*> (2) as (1) but calling ZHPGV +*> (3) as (1) but calling ZHBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling ZHPGV +*> (6) as (4) but calling ZHBGV +*> +*> (7) ZHEGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling ZHPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling ZHPGV +*> +*> (11) ZHEGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling ZHPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling ZHPGV +*> +*> ZHEGVD, ZHPGVD and ZHBGVD performed the same 14 tests. +*> +*> ZHEGVX, ZHPGVX and ZHBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" 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. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Hermitian matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZDRVSG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, ZDRVSG2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 ZDRVSG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX*16 array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B COMPLEX*16 array, dimension (LDB , max(NN)) +*> Used to hold the Hermitian positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z COMPLEX*16 array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of ZZ. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB COMPLEX*16 array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB COMPLEX*16 array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP COMPLEX*16 array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP COMPLEX*16 array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK COMPLEX*16 array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 2*N + N**2 where N = max( NN(j), 2 ). +*> Not modified. +*> +*> RWORK DOUBLE PRECISION array, dimension (LRWORK) +*> Workspace. +*> Modified. +*> +*> LRWORK INTEGER +*> The number of entries in RWORK. This must be at least +*> max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where +*> N = max( NN(j) ) and lg( N ) = smallest integer k such +*> that 2**k >= N . +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK)) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in IWORK. This must be at least +*> 2 + 5*max( NN(j) ). +*> Not modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LRWORK too small. +*> -25: LIWORK too small. +*> If ZLATMR, CLATMS, ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, +*> ZHPGVD, ZHEGVX, CHPGVX, ZHBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 ZDRVSG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, RWORK, LRWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* + IMPLICIT NONE +* +* -- 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, LDB, LDZ, LIWORK, LRWORK, NOUNIT, + $ NSIZES, NTYPES, NWORK + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION D( * ), D2( * ), RESULT( * ), RWORK( * ) + COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 10.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 = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL LSAME, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLAFTS, DLASUM, XERBLA, ZHBGV, ZHBGVD, + $ ZHBGVX, ZHEGV, ZHEGVD, ZHEGVX, ZHPGV, ZHPGVD, + $ ZHPGVX, ZLACPY, ZLASET, ZLATMR, ZLATMS, ZSGT01, + $ ZHEGV_2STAGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* 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( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LRWORK ) THEN + INFO = -23 + ELSE IF( 2*MAX( NMAX, 2 )**2.GT.LIWORK ) THEN + INFO = -25 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZDRVSG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK, IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, CHBGVD, +* ZHEGVX, ZHPGVX and ZHBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL ZLATMS( N, N, 'U', ISEED, 'P', RWORK, 5, TEN, + $ ONE, KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test ZHEGV +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHEGV_2STAGE +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGV_2STAGE( IBTYPE, 'N', UPLO, N, Z, LDZ, + $ BB, LDB, D2, WORK, NWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEGV_2STAGE(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* +C CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, +C $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Do Tests | D1 - D2 | / ( |D1| ulp ) +* D1 computed using the standard 1-stage reduction as reference +* D2 computed using the 2-stage reduction +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 151 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D( J ) ), + $ ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) ) + 151 CONTINUE +* + RESULT( NTEST ) = TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* +* Test ZHEGVD +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHEGVX +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* +* since we do not know the exact eigenvalues of this +* eigenpair, we just set VL and VU as constants. +* It is quite possible that there are no eigenvalues +* in this interval. +* + VL = ZERO + VU = ANORM + CALL ZHEGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVX(V,V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* + CALL ZLACPY( ' ', N, N, A, LDA, AB, LDA ) + CALL ZLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL ZHEGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB, + $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z, + $ LDZ, WORK, NWORK, RWORK, IWORK( N+1 ), + $ IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEGVX(V,I,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 100 CONTINUE +* +* Test ZHPGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 120 J = 1, N + DO 110 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 110 CONTINUE + 120 CONTINUE + ELSE + IJ = 1 + DO 140 J = 1, N + DO 130 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 130 CONTINUE + 140 CONTINUE + END IF +* + CALL ZHPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHPGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 160 J = 1, N + DO 150 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 150 CONTINUE + 160 CONTINUE + ELSE + IJ = 1 + DO 180 J = 1, N + DO 170 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 170 CONTINUE + 180 CONTINUE + END IF +* + CALL ZHPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ, + $ WORK, NWORK, RWORK, LRWORK, IWORK, + $ LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHPGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 200 J = 1, N + DO 190 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 190 CONTINUE + 200 CONTINUE + ELSE + IJ = 1 + DO 220 J = 1, N + DO 210 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 210 CONTINUE + 220 CONTINUE + END IF +* + CALL ZHPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVX(V,A' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 240 J = 1, N + DO 230 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 230 CONTINUE + 240 CONTINUE + ELSE + IJ = 1 + DO 260 J = 1, N + DO 250 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 250 CONTINUE + 260 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL ZHPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVX(V,V' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into packed storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + IJ = 1 + DO 280 J = 1, N + DO 270 I = 1, J + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 270 CONTINUE + 280 CONTINUE + ELSE + IJ = 1 + DO 300 J = 1, N + DO 290 I = J, N + AP( IJ ) = A( I, J ) + BP( IJ ) = B( I, J ) + IJ = IJ + 1 + 290 CONTINUE + 300 CONTINUE + END IF +* + CALL ZHPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL, + $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK, + $ RWORK, IWORK( N+1 ), IWORK, INFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPGVX(V,I' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 310 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + 310 CONTINUE +* + IF( IBTYPE.EQ.1 ) THEN +* +* TEST ZHBGV +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 340 J = 1, N + DO 320 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 320 CONTINUE + DO 330 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 330 CONTINUE + 340 CONTINUE + ELSE + DO 370 J = 1, N + DO 350 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 350 CONTINUE + DO 360 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 360 CONTINUE + 370 CONTINUE + END IF +* + CALL ZHBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB, + $ D, Z, LDZ, WORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGV(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* TEST ZHBGVD +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 400 J = 1, N + DO 380 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 380 CONTINUE + DO 390 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 390 CONTINUE + 400 CONTINUE + ELSE + DO 430 J = 1, N + DO 410 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 410 CONTINUE + DO 420 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 420 CONTINUE + 430 CONTINUE + END IF +* + CALL ZHBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB, + $ LDB, D, Z, LDZ, WORK, NWORK, RWORK, + $ LRWORK, IWORK, LIWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVD(V,' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* +* Test ZHBGVX +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 460 J = 1, N + DO 440 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 440 CONTINUE + DO 450 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 450 CONTINUE + 460 CONTINUE + ELSE + DO 490 J = 1, N + DO 470 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 470 CONTINUE + DO 480 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 480 CONTINUE + 490 CONTINUE + END IF +* + CALL ZHBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVX(V,A' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 520 J = 1, N + DO 500 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 500 CONTINUE + DO 510 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 510 CONTINUE + 520 CONTINUE + ELSE + DO 550 J = 1, N + DO 530 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 530 CONTINUE + DO 540 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 540 CONTINUE + 550 CONTINUE + END IF +* + VL = ZERO + VU = ANORM + CALL ZHBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVX(V,V' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 1 +* +* Copy the matrices into band storage. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 580 J = 1, N + DO 560 I = MAX( 1, J-KA ), J + AB( KA+1+I-J, J ) = A( I, J ) + 560 CONTINUE + DO 570 I = MAX( 1, J-KB ), J + BB( KB+1+I-J, J ) = B( I, J ) + 570 CONTINUE + 580 CONTINUE + ELSE + DO 610 J = 1, N + DO 590 I = J, MIN( N, J+KA ) + AB( 1+I-J, J ) = A( I, J ) + 590 CONTINUE + DO 600 I = J, MIN( N, J+KB ) + BB( 1+I-J, J ) = B( I, J ) + 600 CONTINUE + 610 CONTINUE + END IF +* + CALL ZHBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA, + $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL, + $ IU, ABSTOL, M, D, Z, LDZ, WORK, RWORK, + $ IWORK( N+1 ), IWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBGVX(V,I' // + $ UPLO // ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 620 + END IF + END IF +* +* Do Test +* + CALL ZSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RWORK, RESULT( NTEST ) ) +* + END IF +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'ZSG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL DLASUM( 'ZSG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* + 9999 FORMAT( ' ZDRVSG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* +* End of ZDRVSG2STG +* + END diff --git a/TESTING/EIG/zdrvst2stg.f b/TESTING/EIG/zdrvst2stg.f new file mode 100644 index 00000000..0b33f52d --- /dev/null +++ b/TESTING/EIG/zdrvst2stg.f @@ -0,0 +1,2118 @@ +*> \brief \b ZDRVST2STG +* +* @precisions fortran z -> s d c +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, +* LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, +* $ NSIZES, NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION D1( * ), D2( * ), D3( * ), RESULT( * ), +* $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVST2STG checks the Hermitian eigenvalue problem drivers. +*> +*> ZHEEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix, +*> using a divide-and-conquer algorithm. +*> +*> ZHEEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> ZHEEVR computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix +*> using the Relatively Robust Representation where it can. +*> +*> ZHPEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage, using a divide-and-conquer algorithm. +*> +*> ZHPEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> ZHBEVD computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix, +*> using a divide-and-conquer algorithm. +*> +*> ZHBEVX computes selected eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> ZHEEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix. +*> +*> ZHPEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian matrix in packed +*> storage. +*> +*> ZHBEV computes all eigenvalues and, optionally, +*> eigenvectors of a complex Hermitian band matrix. +*> +*> When ZDRVST2STG 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 appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" 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) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is unitary and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is unitary and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is unitary and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZDRVST2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN 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. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, ZDRVST2STG +*> 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. . +*> Not modified. +*> +*> DOTYPE 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. +*> Not modified. +*> +*> ISEED 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 ZDRVST2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH 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. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A COMPLEX*16 array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by ZSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by ZSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by DSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> WA1 DOUBLE PRECISION array, dimension +*> +*> WA2 DOUBLE PRECISION array, dimension +*> +*> WA3 DOUBLE PRECISION array, dimension +*> +*> U COMPLEX*16 array, dimension (LDU, max(NN)) +*> The unitary matrix computed by ZHETRD + ZUNGC3. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V COMPLEX*16 array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by ZHETRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU COMPLEX*16 array, dimension (max(NN)) +*> The Householder factors computed by ZHETRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z COMPLEX*16 array, dimension (LDU, max(NN)) +*> The unitary matrix of eigenvectors computed by ZHEEVD, +*> ZHEEVX, ZHPEVD, CHPEVX, ZHBEVD, and CHBEVX. +*> Modified. +*> +*> WORK - COMPLEX*16 array of dimension ( LWORK ) +*> Workspace. +*> Modified. +*> +*> LWORK - INTEGER +*> The number of entries in WORK. This must be at least +*> 2*max( NN(j), 2 )**2. +*> Not modified. +*> +*> RWORK DOUBLE PRECISION array, dimension (3*max(NN)) +*> Workspace. +*> Modified. +*> +*> LRWORK - INTEGER +*> The number of entries in RWORK. +*> +*> IWORK INTEGER array, dimension (6*max(NN)) +*> Workspace. +*> Modified. +*> +*> LIWORK - INTEGER +*> The number of entries in IWORK. +*> +*> RESULT DOUBLE PRECISION array, dimension (??) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If DLATMR, SLATMS, ZHETRD, DORGC3, ZSTEQR, DSTERF, +*> or DORMC2 returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \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 ZDRVST2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, WA1, WA2, WA3, U, + $ LDU, V, TAU, Z, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, 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, LDU, LIWORK, LRWORK, LWORK, NOUNIT, + $ NSIZES, NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION D1( * ), D2( * ), D3( * ), RESULT( * ), + $ RWORK( * ), WA1( * ), WA2( * ), WA3( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ TEN = 10.0D+0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX, + $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC, + $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX, + $ NTEST, NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, DLAFTS, XERBLA, ZHBEV, ZHBEVD, + $ ZHBEVX, ZHEEV, ZHEEVD, ZHEEVR, ZHEEVX, ZHET21, + $ ZHET22, ZHPEV, ZHPEVD, ZHPEVX, ZLACPY, ZLASET, + $ ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE, + $ ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE, + $ ZHBEVX_2STAGE, ZHETRD_2STAGE, ZHETRD_SY2SB, + $ ZHETRD_SB2ST, ZLATMR, ZLATMS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + 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 +* +* 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( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -22 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZDRVST2STG', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* + DO 1220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = MAX( 2*N+N*N, 2*N*N ) + LRWEDC = 1 + 4*N + 2*N*LGN + 3*N**2 + LIWEDC = 3 + 5*N + ELSE + LWEDC = 2 + LRWEDC = 8 + LIWEDC = 8 + END IF + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1210 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log Hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random Hermitian +* =9 band Hermitian, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Diagonal Matrix, [Eigen]values Specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Hermitian, eigenvalues specified +* + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* Diagonal, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* Hermitian, random eigenvalues +* + CALL ZLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* Hermitian banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) ) + CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK, + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* Perform tests storing upper or lower triangular +* part of matrix. +* + DO 1200 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* Call ZHEEVD and CHEEVX. +* + CALL ZLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL ZHEEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC, + $ RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do tests 1 and 2. +* + CALL ZHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL ZHEEVD_2STAGE( 'N', UPLO, N, A, LDU, D3, WORK, + $ LWORK, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 130 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 120 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 120 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 130 CONTINUE + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL ZHEEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do tests 4 and 5. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZHEEVX_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 150 + END IF + END IF +* +* Do test 6. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 140 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 140 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 150 CONTINUE + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL ZHEEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do tests 7 and 8. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL ZHEEVX_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 160 + END IF + END IF +* +* Do test 9. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 160 CONTINUE + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 1 +* + CALL ZHEEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, RWORK, + $ IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* +* Do tests 10 and 11. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + CALL ZHEEVX_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ WORK, LWORK, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 170 + END IF +* +* Do test 12. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 170 CONTINUE +* +* Call ZHPEVD and CHPEVX. +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 190 J = 1, N + DO 180 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 180 CONTINUE + 190 CONTINUE + ELSE + INDX = 1 + DO 210 J = 1, N + DO 200 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 200 CONTINUE + 210 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEVD( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVD(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do tests 13 and 14. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 230 J = 1, N + DO 220 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 220 CONTINUE + 230 CONTINUE + ELSE + INDX = 1 + DO 250 J = 1, N + DO 240 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 240 CONTINUE + 250 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEVD( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), LWEDC, RWORK, LRWEDC, IWORK, + $ LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVD(N,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 270 + END IF + END IF +* +* Do test 15. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 260 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 260 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array WORK with the upper or lower triangular part +* of the matrix in packed form. +* + 270 CONTINUE + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 290 J = 1, N + DO 280 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 280 CONTINUE + 290 CONTINUE + ELSE + INDX = 1 + DO 310 J = 1, N + DO 300 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 300 CONTINUE + 310 CONTINUE + END IF +* + NTEST = NTEST + 1 +* + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) ) + IF( IL.NE.1 ) THEN + VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + IF( IU.NE.N ) THEN + VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + ELSE IF( N.GT.0 ) THEN + VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ), + $ TEN*ULP*TEMP3, TEN*RTUNFL ) + END IF + ELSE + TEMP3 = ZERO + VL = ZERO + VU = ONE + END IF +* + CALL ZHPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do tests 16 and 17. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 330 J = 1, N + DO 320 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 320 CONTINUE + 330 CONTINUE + ELSE + INDX = 1 + DO 350 J = 1, N + DO 340 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 340 CONTINUE + 350 CONTINUE + END IF +* + CALL ZHPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 370 + END IF + END IF +* +* Do test 18. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 360 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 360 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 370 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 390 J = 1, N + DO 380 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 380 CONTINUE + 390 CONTINUE + ELSE + INDX = 1 + DO 410 J = 1, N + DO 400 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 400 CONTINUE + 410 CONTINUE + END IF +* + CALL ZHPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do tests 19 and 20. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 430 J = 1, N + DO 420 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 420 CONTINUE + 430 CONTINUE + ELSE + INDX = 1 + DO 450 J = 1, N + DO 440 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 440 CONTINUE + 450 CONTINUE + END IF +* + CALL ZHPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 460 + END IF + END IF +* +* Do test 21. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 460 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 480 J = 1, N + DO 470 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 470 CONTINUE + 480 CONTINUE + ELSE + INDX = 1 + DO 500 J = 1, N + DO 490 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 490 CONTINUE + 500 CONTINUE + END IF +* + CALL ZHPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 550 + END IF + END IF +* +* Do tests 22 and 23. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 520 J = 1, N + DO 510 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 510 CONTINUE + 520 CONTINUE + ELSE + INDX = 1 + DO 540 J = 1, N + DO 530 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 530 CONTINUE + 540 CONTINUE + END IF +* + CALL ZHPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU, + $ ABSTOL, M3, WA3, Z, LDU, V, RWORK, IWORK, + $ IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEVX(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 550 + END IF +* +* Do test 24. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 550 CONTINUE +* +* Call ZHBEVD and CHBEVX. +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 570 J = 1, N + DO 560 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 560 CONTINUE + 570 CONTINUE + ELSE + DO 590 J = 1, N + DO 580 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 580 CONTINUE + 590 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL ZHBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ LWEDC, RWORK, LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEVD(V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do tests 25 and 26. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 610 J = 1, N + DO 600 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 600 CONTINUE + 610 CONTINUE + ELSE + DO 630 J = 1, N + DO 620 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 620 CONTINUE + 630 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL ZHBEVD_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, + $ Z, LDU, WORK, LWORK, RWORK, + $ LRWEDC, IWORK, LIWEDC, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVD_2STAGE(N,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 650 + END IF + END IF +* +* Do test 27. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 640 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 640 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 650 CONTINUE + IF( IUPLO.EQ.1 ) THEN + DO 670 J = 1, N + DO 660 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 660 CONTINUE + 670 CONTINUE + ELSE + DO 690 J = 1, N + DO 680 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 680 CONTINUE + 690 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL ZHBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M, WA1, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHBEVX(V,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do tests 28 and 29. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 710 J = 1, N + DO 700 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 700 CONTINUE + 710 CONTINUE + ELSE + DO 730 J = 1, N + DO 720 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 720 CONTINUE + 730 CONTINUE + END IF +* + CALL ZHBEVX_2STAGE( 'N', 'A', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M2, WA2, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVX_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 750 + END IF + END IF +* +* Do test 30. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 740 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 740 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 750 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 770 J = 1, N + DO 760 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 760 CONTINUE + 770 CONTINUE + ELSE + DO 790 J = 1, N + DO 780 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 780 CONTINUE + 790 CONTINUE + END IF +* + CALL ZHBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEVX(V,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do tests 31 and 32. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 810 J = 1, N + DO 800 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 800 CONTINUE + 810 CONTINUE + ELSE + DO 830 J = 1, N + DO 820 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 820 CONTINUE + 830 CONTINUE + END IF + CALL ZHBEVX_2STAGE( 'N', 'I', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVX_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 840 + END IF + END IF +* +* Do test 33. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 840 CONTINUE + NTEST = NTEST + 1 + IF( IUPLO.EQ.1 ) THEN + DO 860 J = 1, N + DO 850 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 850 CONTINUE + 860 CONTINUE + ELSE + DO 880 J = 1, N + DO 870 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 870 CONTINUE + 880 CONTINUE + END IF + CALL ZHBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL, + $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEVX(V,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 930 + END IF + END IF +* +* Do tests 34 and 35. +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 +* + IF( IUPLO.EQ.1 ) THEN + DO 900 J = 1, N + DO 890 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 890 CONTINUE + 900 CONTINUE + ELSE + DO 920 J = 1, N + DO 910 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 910 CONTINUE + 920 CONTINUE + END IF + CALL ZHBEVX_2STAGE( 'N', 'V', UPLO, N, KD, V, LDU, + $ U, LDU, VL, VU, IL, IU, ABSTOL, + $ M3, WA3, Z, LDU, WORK, LWORK, + $ RWORK, IWORK, IWORK( 5*N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEVX_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 930 + END IF +* +* Do test 36. +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + 930 CONTINUE +* +* Call ZHEEV +* + CALL ZLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + CALL ZHEEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, RWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do tests 37 and 38 +* + CALL ZHET21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + CALL ZHEEV_2STAGE( 'N', UPLO, N, A, LDU, D3, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 950 + END IF + END IF +* +* Do test 39 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 940 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 940 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 950 CONTINUE +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* Call ZHPEV +* +* Load array WORK with the upper or lower triangular +* part of the matrix in packed form. +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 970 J = 1, N + DO 960 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 960 CONTINUE + 970 CONTINUE + ELSE + INDX = 1 + DO 990 J = 1, N + DO 980 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 980 CONTINUE + 990 CONTINUE + END IF +* + NTEST = NTEST + 1 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEV( 'V', UPLO, N, WORK, D1, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do tests 40 and 41. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + INDX = 1 + DO 1010 J = 1, N + DO 1000 I = 1, J + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1000 CONTINUE + 1010 CONTINUE + ELSE + INDX = 1 + DO 1030 J = 1, N + DO 1020 I = J, N + WORK( INDX ) = A( I, J ) + INDX = INDX + 1 + 1020 CONTINUE + 1030 CONTINUE + END IF +* + NTEST = NTEST + 2 + INDWRK = N*( N+1 ) / 2 + 1 + CALL ZHPEV( 'N', UPLO, N, WORK, D3, Z, LDU, + $ WORK( INDWRK ), RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHPEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1050 + END IF + END IF +* +* Do test 42 +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1040 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1040 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1050 CONTINUE +* +* Call ZHBEV +* + IF( JTYPE.LE.7 ) THEN + KD = 0 + ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN + KD = MAX( N-1, 0 ) + ELSE + KD = IHBW + END IF +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + IF( IUPLO.EQ.1 ) THEN + DO 1070 J = 1, N + DO 1060 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1060 CONTINUE + 1070 CONTINUE + ELSE + DO 1090 J = 1, N + DO 1080 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1080 CONTINUE + 1090 CONTINUE + END IF +* + NTEST = NTEST + 1 + CALL ZHBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK, + $ RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'ZHBEV(V,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1140 + END IF + END IF +* +* Do tests 43 and 44. +* + CALL ZHET21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + IF( IUPLO.EQ.1 ) THEN + DO 1110 J = 1, N + DO 1100 I = MAX( 1, J-KD ), J + V( KD+1+I-J, J ) = A( I, J ) + 1100 CONTINUE + 1110 CONTINUE + ELSE + DO 1130 J = 1, N + DO 1120 I = J, MIN( N, J+KD ) + V( 1+I-J, J ) = A( I, J ) + 1120 CONTINUE + 1130 CONTINUE + END IF +* + NTEST = NTEST + 2 + CALL ZHBEV_2STAGE( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, + $ WORK, LWORK, RWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9998 ) + $ 'ZHBEV_2STAGE(N,' // UPLO // ')', + $ IINFO, N, KD, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1140 + END IF + END IF +* + 1140 CONTINUE +* +* Do test 45. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1150 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 1150 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + CALL ZLACPY( ' ', N, N, A, LDA, V, LDU ) + NTEST = NTEST + 1 + CALL ZHEEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVR(V,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do tests 45 and 46 (or ... ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V, + $ LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZHEEVR_2STAGE( 'N', 'A', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M2, WA2, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVR_2STAGE(N,A,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1170 + END IF + END IF +* +* Do test 47 (or ... ) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 1160 J = 1, N + TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) ) + 1160 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 1170 CONTINUE +* + NTEST = NTEST + 1 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVR(V,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do tests 48 and 49 (or +??) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR_2STAGE( 'N', 'I', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVR_2STAGE(N,I,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1180 + END IF + END IF +* +* Do test 50 (or +??) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, ULP*TEMP3 ) + 1180 CONTINUE +* + NTEST = NTEST + 1 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU, + $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK, + $ RWORK, LRWORK, IWORK( 2*N+1 ), LIWORK-2*N, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZHEEVR(V,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 1190 + END IF + END IF +* +* Do tests 51 and 52 (or +??) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* + CALL ZHET22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU, + $ V, LDU, TAU, WORK, RWORK, RESULT( NTEST ) ) +* + NTEST = NTEST + 2 + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) + CALL ZHEEVR_2STAGE( 'N', 'V', UPLO, N, A, LDU, VL, VU, + $ IL, IU, ABSTOL, M3, WA3, Z, LDU, + $ IWORK, WORK, LWORK, RWORK, LRWORK, + $ IWORK( 2*N+1 ), LIWORK-2*N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 ) + $ 'ZHEEVR_2STAGE(N,V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF + END IF +* + IF( M3.EQ.0 .AND. N.GT.0 ) THEN + RESULT( NTEST ) = ULPINV + GO TO 1190 + END IF +* +* Do test 52 (or +??) +* + TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) + TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) + IF( N.GT.0 ) THEN + TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) ) + ELSE + TEMP3 = ZERO + END IF + RESULT( NTEST ) = ( TEMP1+TEMP2 ) / + $ MAX( UNFL, TEMP3*ULP ) +* + CALL ZLACPY( ' ', N, N, V, LDU, A, LDA ) +* +* +* +* +* Load array V with the upper or lower triangular part +* of the matrix in band form. +* + 1190 CONTINUE +* + 1200 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'ZST', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1210 CONTINUE + 1220 CONTINUE +* +* Summary +* + CALL ALASVM( 'ZST', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' ZDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + 9998 FORMAT( ' ZDRVST2STG: ', A, ' returned INFO=', I6, / 9X, 'N=', I6, + $ ', KD=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, + $ ')' ) +* + RETURN +* +* End of ZDRVST2STG +* + END diff --git a/TESTING/EIG/zerrst.f b/TESTING/EIG/zerrst.f index 92c9e52c..8afa1dce 100644 --- a/TESTING/EIG/zerrst.f +++ b/TESTING/EIG/zerrst.f @@ -1,5 +1,7 @@ *> \brief \b ZERRST * +* @precisions fortran z -> c +* * =========== DOCUMENTATION =========== * * Online html documentation available at @@ -25,6 +27,10 @@ *> ZUNGTR, ZUPMTR, ZSTEQR, CSTEIN, ZPTEQR, ZHBTRD, *> ZHEEV, CHEEVX, CHEEVD, ZHBEV, CHBEVX, CHBEVD, *> ZHPEV, CHPEVX, CHPEVD, and ZSTEDC. +*> ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE, +*> ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE, +*> ZHBEVX_2STAGE, ZHETRD_2STAGE, ZHETRD_SY2SB, +*> ZHETRD_SB2ST *> \endverbatim * * Arguments: @@ -93,7 +99,11 @@ EXTERNAL CHKXER, ZHBEV, ZHBEVD, ZHBEVX, ZHBTRD, ZHEEV, $ ZHEEVD, ZHEEVR, ZHEEVX, ZHETRD, ZHPEV, ZHPEVD, $ ZHPEVX, ZHPTRD, ZPTEQR, ZSTEDC, ZSTEIN, ZSTEQR, - $ ZUNGTR, ZUNMTR, ZUPGTR, ZUPMTR + $ ZUNGTR, ZUNMTR, ZUPGTR, ZUPMTR, + $ ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE, + $ ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE, + $ ZHBEVX_2STAGE, ZHETRD_2STAGE, ZHETRD_SY2SB, + $ ZHETRD_SB2ST * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -151,6 +161,103 @@ CALL CHKXER( 'ZHETRD', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* ZHETRD_2STAGE +* + SRNAMT = 'ZHETRD_2STAGE' + INFOT = 1 + CALL ZHETRD_2STAGE( '/', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHETRD_2STAGE( 'H', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_2STAGE( 'N', '/', 0, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_2STAGE( 'N', 'U', -1, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_2STAGE( 'N', 'U', 2, A, 1, D, E, TAU, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZHETRD_2STAGE( 'N', 'U', 0, A, 1, D, E, TAU, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 7 +* +* ZHETRD_HE2HB +* + SRNAMT = 'ZHETRD_HE2HB' + INFOT = 1 + CALL ZHETRD_HE2HB( '/', 0, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HE2HB( 'U', -1, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_HE2HB( 'U', 0, -1, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_HE2HB( 'U', 2, 0, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRD_HE2HB( 'U', 0, 2, A, 1, C, 1, TAU, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHETRD_HE2HB( 'U', 0, 0, A, 1, C, 1, TAU, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_HE2HB', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* +* ZHETRD_HB2ST +* + SRNAMT = 'ZHETRD_HB2ST' + INFOT = 1 + CALL ZHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'Y', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'Y', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_HB2ST( 'Y', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHETRD_HB2ST( 'Y', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * ZUNGTR * SRNAMT = 'ZUNGTR' @@ -377,6 +484,63 @@ CALL CHKXER( 'ZHEEVD', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* ZHEEVD_2STAGE +* + SRNAMT = 'ZHEEVD_2STAGE' + INFOT = 1 + CALL ZHEEVD_2STAGE( '/', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEVD_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEVD_2STAGE( 'N', '/', 0, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEVD_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 0, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, + $ RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 8 +* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 3, +* $ RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 0, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, + $ RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 10 +* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 18, IW, 12, INFO ) +* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZHEEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, + $ RW, 1, IW, 0, INFO ) + CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 +* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8, +* $ RW, 25, IW, 11, INFO ) +* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * ZHEEV * SRNAMT = 'ZHEEV ' @@ -397,6 +561,29 @@ CALL CHKXER( 'ZHEEV ', INFOT, NOUT, LERR, OK ) NT = NT + 5 * +* ZHEEV_2STAGE +* + SRNAMT = 'ZHEEV_2STAGE ' + INFOT = 1 + CALL ZHEEV_2STAGE( '/', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEV_2STAGE( 'V', 'U', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEV_2STAGE( 'N', '/', 0, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEV_2STAGE( 'N', 'U', -1, A, 1, X, W, 1, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHEEV_2STAGE( 'N', 'U', 2, A, 1, X, W, 3, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEV_2STAGE( 'N', 'U', 2, A, 2, X, W, 2, RW, INFO ) + CALL CHKXER( 'ZHEEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 6 +* * ZHEEVX * SRNAMT = 'ZHEEVX' @@ -441,6 +628,65 @@ CALL CHKXER( 'ZHEEVX', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* ZHEEVX_2STAGE +* + SRNAMT = 'ZHEEVX_2STAGE' + INFOT = 1 + CALL ZHEEVX_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEVX_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEVX_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEVX_2STAGE( 'N', 'A', '/', 0, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + INFOT = 4 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVX_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHEEVX_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 1, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVX_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, X, Z, 2, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 3, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL ZHEEVX_2STAGE( 'N', 'A', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I1, INFO ) + CALL CHKXER( 'ZHEEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * ZHEEVR * SRNAMT = 'ZHEEVR' @@ -508,6 +754,90 @@ CALL CHKXER( 'ZHEEVR', INFOT, NOUT, LERR, OK ) NT = NT + 12 * +* ZHEEVR_2STAGE +* + SRNAMT = 'ZHEEVR_2STAGE' + N = 1 + INFOT = 1 + CALL ZHEEVR_2STAGE( '/', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHEEVR_2STAGE( 'V', 'A', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHEEVR_2STAGE( 'N', '/', 'U', 0, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHEEVR_2STAGE( 'N', 'A', '/', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHEEVR_2STAGE( 'N', 'A', 'U', -1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, + $ IW( 2*N+1 ), 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHEEVR_2STAGE( 'N', 'A', 'U', 2, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHEEVR_2STAGE( 'N', 'V', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 0, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 2, A, 2, + $ 0.0D0, 0.0D0, 2, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 0, IW, Q, 2*N, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 2*N-1, RW, 24*N, IW( 2*N+1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N-1, IW( 2*N-1 ), + $ 10*N, INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 22 + CALL ZHEEVR_2STAGE( 'N', 'I', 'U', 1, A, 1, + $ 0.0D0, 0.0D0, 1, 1, 0.0D0, + $ M, R, Z, 1, IW, Q, 26*N, RW, 24*N, IW, 10*N-1, + $ INFO ) + CALL CHKXER( 'ZHEEVR_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * ZHPEVD * SRNAMT = 'ZHPEVD' @@ -646,6 +976,47 @@ CALL CHKXER( 'ZHBTRD', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* ZHETRD_HB2ST +* + SRNAMT = 'ZHETRD_HB2ST' + INFOT = 1 + CALL ZHETRD_HB2ST( '/', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'N', '/', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRD_HB2ST( 'N', 'H', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRD_HB2ST( 'N', 'N', '/', 0, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', -1, 0, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, -1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, 1, A, 1, D, E, + $ C, 1, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 0, W, 1, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHETRD_HB2ST( 'N', 'N', 'U', 0, 0, A, 1, D, E, + $ C, 1, W, 0, INFO ) + CALL CHKXER( 'ZHETRD_HB2ST', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * ZHBEVD * SRNAMT = 'ZHBEVD' @@ -711,6 +1082,75 @@ CALL CHKXER( 'ZHBEVD', INFOT, NOUT, LERR, OK ) NT = NT + 15 * +* ZHBEVD_2STAGE +* + SRNAMT = 'ZHBEVD_2STAGE' + INFOT = 1 + CALL ZHBEVD_2STAGE( '/', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHBEVD_2STAGE( 'V', 'U', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHBEVD_2STAGE( 'N', '/', 0, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHBEVD_2STAGE( 'N', 'U', -1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHBEVD_2STAGE( 'N', 'U', 0, -1, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 1, X, Z, 1, + $ W, 2, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 0, + $ W, 8, RW, 25, IW, 12, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 0, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 1, RW, 2, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 11 +* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 2, RW, 25, IW, 12, INFO ) +* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 0, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 13 +* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 2, IW, 12, INFO ) +* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHBEVD_2STAGE( 'N', 'U', 1, 0, A, 1, X, Z, 1, + $ W, 1, RW, 1, IW, 0, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZHBEVD_2STAGE( 'N', 'U', 2, 1, A, 2, X, Z, 2, + $ W, 25, RW, 2, IW, 0, INFO ) + CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 15 +* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2, +* $ W, 25, RW, 25, IW, 2, INFO ) +* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 13 +* * ZHBEV * SRNAMT = 'ZHBEV ' @@ -734,6 +1174,43 @@ CALL CHKXER( 'ZHBEV ', INFOT, NOUT, LERR, OK ) NT = NT + 6 * +* ZHBEV_2STAGE +* + SRNAMT = 'ZHBEV_2STAGE ' + INFOT = 1 + CALL ZHBEV_2STAGE( '/', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZHBEV_2STAGE( 'V', 'U', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHBEV_2STAGE( 'N', '/', 0, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHBEV_2STAGE( 'N', 'U', -1, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHBEV_2STAGE( 'N', 'U', 0, -1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHBEV_2STAGE( 'N', 'U', 2, 1, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 0, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEV_2STAGE( 'N', 'U', 2, 0, A, 1, X, + $ Z, 1, W, 0, RW, INFO ) + CALL CHKXER( 'ZHBEV_2STAGE ', INFOT, NOUT, LERR, OK ) + NT = NT + 8 +* * ZHBEVX * SRNAMT = 'ZHBEVX' @@ -781,6 +1258,74 @@ $ 0, 0.0D0, M, X, Z, 1, W, RW, IW, I3, INFO ) CALL CHKXER( 'ZHBEVX', INFOT, NOUT, LERR, OK ) NT = NT + 11 +* +* ZHBEVX_2STAGE +* + SRNAMT = 'ZHBEVX_2STAGE' + INFOT = 1 + CALL ZHBEVX_2STAGE( '/', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 1 + CALL ZHBEVX_2STAGE( 'V', 'A', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHBEVX_2STAGE( 'N', '/', 'U', 0, 0, A, 1, Q, 1, + $ 0.0D0, 1.0D0, 1, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHBEVX_2STAGE( 'N', 'A', '/', 0, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + INFOT = 4 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 2, 1, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) +* INFOT = 9 +* CALL ZHBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, +* $ 0.0D0, 0.0D0, 0, 0, 0.0D0, +* $ M, X, Z, 2, W, 0, RW, IW, I3, INFO ) +* CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHBEVX_2STAGE( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZHBEVX_2STAGE( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, + $ 0.0D0, 0.0D0, 1, 2, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 0, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + INFOT = 20 + CALL ZHBEVX_2STAGE( 'N', 'A', 'U', 2, 0, A, 1, Q, 2, + $ 0.0D0, 0.0D0, 0, 0, 0.0D0, + $ M, X, Z, 1, W, 0, RW, IW, I3, INFO ) + CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK ) + NT = NT + 12 END IF * * Print a summary line. diff --git a/TESTING/Makefile b/TESTING/Makefile index 968a9a2b..9b641e76 100644 --- a/TESTING/Makefile +++ b/TESTING/Makefile @@ -46,6 +46,7 @@ all: single complex double complex16 singleproto doubleproto complexproto co SEIGTST= snep.out \ ssep.out \ + sse2.out \ ssvd.out \ sec.out \ sed.out \ @@ -66,6 +67,7 @@ SEIGTST= snep.out \ CEIGTST= cnep.out \ csep.out \ + cse2.out \ csvd.out \ cec.out \ ced.out \ @@ -86,6 +88,7 @@ CEIGTST= cnep.out \ DEIGTST= dnep.out \ dsep.out \ + dse2.out \ dsvd.out \ dec.out \ ded.out \ @@ -106,6 +109,7 @@ DEIGTST= dnep.out \ ZEIGTST= znep.out \ zsep.out \ + zse2.out \ zsvd.out \ zec.out \ zed.out \ @@ -223,6 +227,10 @@ ssep.out: sep.in xeigtsts @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtsts < sep.in > $@ 2>&1 +sse2.out: se2.in xeigtsts + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtsts < se2.in > $@ 2>&1 + ssvd.out: svd.in xeigtsts @echo SVD: Testing Singular Value Decomposition routines ./xeigtsts < svd.in > $@ 2>&1 @@ -301,6 +309,10 @@ csep.out: sep.in xeigtstc @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtstc < sep.in > $@ 2>&1 +cse2.out: se2.in xeigtstc + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtstc < se2.in > $@ 2>&1 + csvd.out: svd.in xeigtstc @echo SVD: Testing Singular Value Decomposition routines ./xeigtstc < svd.in > $@ 2>&1 @@ -379,6 +391,10 @@ dsep.out: sep.in xeigtstd @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtstd < sep.in > $@ 2>&1 +dse2.out: se2.in xeigtstd + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtstd < se2.in > $@ 2>&1 + dsvd.out: svd.in xeigtstd @echo SVD: Testing Singular Value Decomposition routines ./xeigtstd < svd.in > $@ 2>&1 @@ -457,6 +473,10 @@ zsep.out: sep.in xeigtstz @echo SEP: Testing Symmetric Eigenvalue Problem routines ./xeigtstz < sep.in > $@ 2>&1 +zse2.out: se2.in xeigtstz + @echo SEP: Testing Symmetric Eigenvalue Problem routines + ./xeigtstz < se2.in > $@ 2>&1 + zsvd.out: svd.in xeigtstz @echo SVD: Testing Singular Value Decomposition routines ./xeigtstz < svd.in > $@ 2>&1 diff --git a/TESTING/se2.in b/TESTING/se2.in new file mode 100644 index 00000000..e20649c9 --- /dev/null +++ b/TESTING/se2.in @@ -0,0 +1,15 @@ +SE2: Data file for testing Symmetric Eigenvalue Problem routines +6 Number of values of N +0 1 2 3 5 20 Values of N (dimension) +5 Number of values of NB +1 3 3 3 10 Values of NB (blocksize) +2 2 2 2 2 Values of NBMIN (minimum blocksize) +1 0 5 9 1 Values of NX (crossover point) +50.0 Threshold value +T Put T to test the LAPACK routines +T Put T to test the driver routines +T Put T to test the error exits +1 Code to interpret the seed +SE2 20 +1 2 3 4 5 6 7 8 10 11 12 13 14 15 16 17 18 19 20 21 + |