LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ sdrvst()

subroutine sdrvst ( integer  nsizes,
integer, dimension( * )  nn,
integer  ntypes,
logical, dimension( * )  dotype,
integer, dimension( 4 )  iseed,
real  thresh,
integer  nounit,
real, dimension( lda, * )  a,
integer  lda,
real, dimension( * )  d1,
real, dimension( * )  d2,
real, dimension( * )  d3,
real, dimension( * )  d4,
real, dimension( * )  eveigs,
real, dimension( * )  wa1,
real, dimension( * )  wa2,
real, dimension( * )  wa3,
real, dimension( ldu, * )  u,
integer  ldu,
real, dimension( ldu, * )  v,
real, dimension( * )  tau,
real, dimension( ldu, * )  z,
real, dimension( * )  work,
integer  lwork,
integer, dimension( * )  iwork,
integer  liwork,
real, dimension( * )  result,
integer  info 
)

SDRVST

Purpose:
      SDRVST  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 SDRVST 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 )
  NSIZES  INTEGER
          The number of sizes of matrices to use.  If it is zero,
          SDRVST 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, SDRVST
          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 SDRVST 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 simultaneously
          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('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('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('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('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('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('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('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('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('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('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('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('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('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', ... )
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 449 of file sdrvst.f.

453*
454* -- LAPACK test routine --
455* -- LAPACK is a software package provided by Univ. of Tennessee, --
456* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
457*
458* .. Scalar Arguments ..
459 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
460 $ NTYPES
461 REAL THRESH
462* ..
463* .. Array Arguments ..
464 LOGICAL DOTYPE( * )
465 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
466 REAL A( LDA, * ), D1( * ), D2( * ), D3( * ),
467 $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
468 $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
469 $ WA3( * ), WORK( * ), Z( LDU, * )
470* ..
471*
472* =====================================================================
473*
474* .. Parameters ..
475 REAL ZERO, ONE, TWO, TEN
476 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
477 $ ten = 10.0e0 )
478 REAL HALF
479 parameter( half = 0.5e0 )
480 INTEGER MAXTYP
481 parameter( maxtyp = 18 )
482* ..
483* .. Local Scalars ..
484 LOGICAL BADNN
485 CHARACTER UPLO
486 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
487 $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
488 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
489 $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
490 $ NTESTT
491 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
492 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
493 $ VL, VU
494* ..
495* .. Local Arrays ..
496 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
497 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
498 $ KTYPE( MAXTYP )
499* ..
500* .. External Functions ..
501 REAL SLAMCH, SLARND, SSXT1
502 EXTERNAL slamch, slarnd, ssxt1
503* ..
504* .. External Subroutines ..
505 EXTERNAL alasvm, slacpy, slafts, slaset, slatmr, slatms,
506 $ ssbev, ssbevd, ssbevx, sspev, sspevd, sspevx,
507 $ sstev, sstevd, sstevr, sstevx, sstt21, sstt22,
508 $ ssyev, ssyevd, ssyevr, ssyevx, ssyt21, ssyt22,
509 $ xerbla
510* ..
511* .. Scalars in Common ..
512 CHARACTER*32 SRNAMT
513* ..
514* .. Common blocks ..
515 COMMON / srnamc / srnamt
516* ..
517* .. Intrinsic Functions ..
518 INTRINSIC abs, int, log, max, min, real, sqrt
519* ..
520* .. Data statements ..
521 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 3*9 /
522 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
523 $ 2, 3, 1, 2, 3 /
524 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
525 $ 0, 0, 4, 4, 4 /
526* ..
527* .. Executable Statements ..
528*
529* Keep ftrnchek happy
530*
531 vl = zero
532 vu = zero
533*
534* 1) Check for errors
535*
536 ntestt = 0
537 info = 0
538*
539 badnn = .false.
540 nmax = 1
541 DO 10 j = 1, nsizes
542 nmax = max( nmax, nn( j ) )
543 IF( nn( j ).LT.0 )
544 $ badnn = .true.
545 10 CONTINUE
546*
547* Check for errors
548*
549 IF( nsizes.LT.0 ) THEN
550 info = -1
551 ELSE IF( badnn ) THEN
552 info = -2
553 ELSE IF( ntypes.LT.0 ) THEN
554 info = -3
555 ELSE IF( lda.LT.nmax ) THEN
556 info = -9
557 ELSE IF( ldu.LT.nmax ) THEN
558 info = -16
559 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
560 info = -21
561 END IF
562*
563 IF( info.NE.0 ) THEN
564 CALL xerbla( 'SDRVST', -info )
565 RETURN
566 END IF
567*
568* Quick return if nothing to do
569*
570 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
571 $ RETURN
572*
573* More Important constants
574*
575 unfl = slamch( 'Safe minimum' )
576 ovfl = slamch( 'Overflow' )
577 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
578 ulpinv = one / ulp
579 rtunfl = sqrt( unfl )
580 rtovfl = sqrt( ovfl )
581*
582* Loop over sizes, types
583*
584 DO 20 i = 1, 4
585 iseed2( i ) = iseed( i )
586 iseed3( i ) = iseed( i )
587 20 CONTINUE
588*
589 nerrs = 0
590 nmats = 0
591*
592*
593 DO 1740 jsize = 1, nsizes
594 n = nn( jsize )
595 IF( n.GT.0 ) THEN
596 lgn = int( log( real( n ) ) / log( two ) )
597 IF( 2**lgn.LT.n )
598 $ lgn = lgn + 1
599 IF( 2**lgn.LT.n )
600 $ lgn = lgn + 1
601 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
602c LIWEDC = 6 + 6*N + 5*N*LGN
603 liwedc = 3 + 5*n
604 ELSE
605 lwedc = 9
606c LIWEDC = 12
607 liwedc = 8
608 END IF
609 aninv = one / real( max( 1, n ) )
610*
611 IF( nsizes.NE.1 ) THEN
612 mtypes = min( maxtyp, ntypes )
613 ELSE
614 mtypes = min( maxtyp+1, ntypes )
615 END IF
616*
617 DO 1730 jtype = 1, mtypes
618*
619 IF( .NOT.dotype( jtype ) )
620 $ GO TO 1730
621 nmats = nmats + 1
622 ntest = 0
623*
624 DO 30 j = 1, 4
625 ioldsd( j ) = iseed( j )
626 30 CONTINUE
627*
628* 2) Compute "A"
629*
630* Control parameters:
631*
632* KMAGN KMODE KTYPE
633* =1 O(1) clustered 1 zero
634* =2 large clustered 2 identity
635* =3 small exponential (none)
636* =4 arithmetic diagonal, (w/ eigenvalues)
637* =5 random log symmetric, w/ eigenvalues
638* =6 random (none)
639* =7 random diagonal
640* =8 random symmetric
641* =9 band symmetric, w/ eigenvalues
642*
643 IF( mtypes.GT.maxtyp )
644 $ GO TO 110
645*
646 itype = ktype( jtype )
647 imode = kmode( jtype )
648*
649* Compute norm
650*
651 GO TO ( 40, 50, 60 )kmagn( jtype )
652*
653 40 CONTINUE
654 anorm = one
655 GO TO 70
656*
657 50 CONTINUE
658 anorm = ( rtovfl*ulp )*aninv
659 GO TO 70
660*
661 60 CONTINUE
662 anorm = rtunfl*n*ulpinv
663 GO TO 70
664*
665 70 CONTINUE
666*
667 CALL slaset( 'Full', lda, n, zero, zero, a, lda )
668 iinfo = 0
669 cond = ulpinv
670*
671* Special Matrices -- Identity & Jordan block
672*
673* Zero
674*
675 IF( itype.EQ.1 ) THEN
676 iinfo = 0
677*
678 ELSE IF( itype.EQ.2 ) THEN
679*
680* Identity
681*
682 DO 80 jcol = 1, n
683 a( jcol, jcol ) = anorm
684 80 CONTINUE
685*
686 ELSE IF( itype.EQ.4 ) THEN
687*
688* Diagonal Matrix, [Eigen]values Specified
689*
690 CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
691 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
692 $ iinfo )
693*
694 ELSE IF( itype.EQ.5 ) THEN
695*
696* Symmetric, eigenvalues specified
697*
698 CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
699 $ anorm, n, n, 'N', a, lda, work( n+1 ),
700 $ iinfo )
701*
702 ELSE IF( itype.EQ.7 ) THEN
703*
704* Diagonal, random eigenvalues
705*
706 idumma( 1 ) = 1
707 CALL slatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
708 $ 'T', 'N', work( n+1 ), 1, one,
709 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
710 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
711*
712 ELSE IF( itype.EQ.8 ) THEN
713*
714* Symmetric, random eigenvalues
715*
716 idumma( 1 ) = 1
717 CALL slatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
718 $ 'T', 'N', work( n+1 ), 1, one,
719 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
720 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
721*
722 ELSE IF( itype.EQ.9 ) THEN
723*
724* Symmetric banded, eigenvalues specified
725*
726 ihbw = int( ( n-1 )*slarnd( 1, iseed3 ) )
727 CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
728 $ anorm, ihbw, ihbw, 'Z', u, ldu, work( n+1 ),
729 $ iinfo )
730*
731* Store as dense matrix for most routines.
732*
733 CALL slaset( 'Full', lda, n, zero, zero, a, lda )
734 DO 100 idiag = -ihbw, ihbw
735 irow = ihbw - idiag + 1
736 j1 = max( 1, idiag+1 )
737 j2 = min( n, n+idiag )
738 DO 90 j = j1, j2
739 i = j - idiag
740 a( i, j ) = u( irow, j )
741 90 CONTINUE
742 100 CONTINUE
743 ELSE
744 iinfo = 1
745 END IF
746*
747 IF( iinfo.NE.0 ) THEN
748 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
749 $ ioldsd
750 info = abs( iinfo )
751 RETURN
752 END IF
753*
754 110 CONTINUE
755*
756 abstol = unfl + unfl
757 IF( n.LE.1 ) THEN
758 il = 1
759 iu = n
760 ELSE
761 il = 1 + int( ( n-1 )*slarnd( 1, iseed2 ) )
762 iu = 1 + int( ( n-1 )*slarnd( 1, iseed2 ) )
763 IF( il.GT.iu ) THEN
764 itemp = il
765 il = iu
766 iu = itemp
767 END IF
768 END IF
769*
770* 3) If matrix is tridiagonal, call SSTEV and SSTEVX.
771*
772 IF( jtype.LE.7 ) THEN
773 ntest = 1
774 DO 120 i = 1, n
775 d1( i ) = real( a( i, i ) )
776 120 CONTINUE
777 DO 130 i = 1, n - 1
778 d2( i ) = real( a( i+1, i ) )
779 130 CONTINUE
780 srnamt = 'SSTEV'
781 CALL sstev( 'V', n, d1, d2, z, ldu, work, iinfo )
782 IF( iinfo.NE.0 ) THEN
783 WRITE( nounit, fmt = 9999 )'SSTEV(V)', iinfo, n,
784 $ jtype, ioldsd
785 info = abs( iinfo )
786 IF( iinfo.LT.0 ) THEN
787 RETURN
788 ELSE
789 result( 1 ) = ulpinv
790 result( 2 ) = ulpinv
791 result( 3 ) = ulpinv
792 GO TO 180
793 END IF
794 END IF
795*
796* Do tests 1 and 2.
797*
798 DO 140 i = 1, n
799 d3( i ) = real( a( i, i ) )
800 140 CONTINUE
801 DO 150 i = 1, n - 1
802 d4( i ) = real( a( i+1, i ) )
803 150 CONTINUE
804 CALL sstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
805 $ result( 1 ) )
806*
807 ntest = 3
808 DO 160 i = 1, n - 1
809 d4( i ) = real( a( i+1, i ) )
810 160 CONTINUE
811 srnamt = 'SSTEV'
812 CALL sstev( 'N', n, d3, d4, z, ldu, work, iinfo )
813 IF( iinfo.NE.0 ) THEN
814 WRITE( nounit, fmt = 9999 )'SSTEV(N)', iinfo, n,
815 $ jtype, ioldsd
816 info = abs( iinfo )
817 IF( iinfo.LT.0 ) THEN
818 RETURN
819 ELSE
820 result( 3 ) = ulpinv
821 GO TO 180
822 END IF
823 END IF
824*
825* Do test 3.
826*
827 temp1 = zero
828 temp2 = zero
829 DO 170 j = 1, n
830 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
831 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
832 170 CONTINUE
833 result( 3 ) = temp2 / max( unfl,
834 $ ulp*max( temp1, temp2 ) )
835*
836 180 CONTINUE
837*
838 ntest = 4
839 DO 190 i = 1, n
840 eveigs( i ) = d3( i )
841 d1( i ) = real( a( i, i ) )
842 190 CONTINUE
843 DO 200 i = 1, n - 1
844 d2( i ) = real( a( i+1, i ) )
845 200 CONTINUE
846 srnamt = 'SSTEVX'
847 CALL sstevx( 'V', 'A', n, d1, d2, vl, vu, il, iu, abstol,
848 $ m, wa1, z, ldu, work, iwork, iwork( 5*n+1 ),
849 $ iinfo )
850 IF( iinfo.NE.0 ) THEN
851 WRITE( nounit, fmt = 9999 )'SSTEVX(V,A)', iinfo, n,
852 $ jtype, ioldsd
853 info = abs( iinfo )
854 IF( iinfo.LT.0 ) THEN
855 RETURN
856 ELSE
857 result( 4 ) = ulpinv
858 result( 5 ) = ulpinv
859 result( 6 ) = ulpinv
860 GO TO 250
861 END IF
862 END IF
863 IF( n.GT.0 ) THEN
864 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
865 ELSE
866 temp3 = zero
867 END IF
868*
869* Do tests 4 and 5.
870*
871 DO 210 i = 1, n
872 d3( i ) = real( a( i, i ) )
873 210 CONTINUE
874 DO 220 i = 1, n - 1
875 d4( i ) = real( a( i+1, i ) )
876 220 CONTINUE
877 CALL sstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
878 $ result( 4 ) )
879*
880 ntest = 6
881 DO 230 i = 1, n - 1
882 d4( i ) = real( a( i+1, i ) )
883 230 CONTINUE
884 srnamt = 'SSTEVX'
885 CALL sstevx( 'N', 'A', n, d3, d4, vl, vu, il, iu, abstol,
886 $ m2, wa2, z, ldu, work, iwork,
887 $ iwork( 5*n+1 ), iinfo )
888 IF( iinfo.NE.0 ) THEN
889 WRITE( nounit, fmt = 9999 )'SSTEVX(N,A)', iinfo, n,
890 $ jtype, ioldsd
891 info = abs( iinfo )
892 IF( iinfo.LT.0 ) THEN
893 RETURN
894 ELSE
895 result( 6 ) = ulpinv
896 GO TO 250
897 END IF
898 END IF
899*
900* Do test 6.
901*
902 temp1 = zero
903 temp2 = zero
904 DO 240 j = 1, n
905 temp1 = max( temp1, abs( wa2( j ) ),
906 $ abs( eveigs( j ) ) )
907 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
908 240 CONTINUE
909 result( 6 ) = temp2 / max( unfl,
910 $ ulp*max( temp1, temp2 ) )
911*
912 250 CONTINUE
913*
914 ntest = 7
915 DO 260 i = 1, n
916 d1( i ) = real( a( i, i ) )
917 260 CONTINUE
918 DO 270 i = 1, n - 1
919 d2( i ) = real( a( i+1, i ) )
920 270 CONTINUE
921 srnamt = 'SSTEVR'
922 CALL sstevr( 'V', 'A', n, d1, d2, vl, vu, il, iu, abstol,
923 $ m, wa1, z, ldu, iwork, work, lwork,
924 $ iwork(2*n+1), liwork-2*n, iinfo )
925 IF( iinfo.NE.0 ) THEN
926 WRITE( nounit, fmt = 9999 )'SSTEVR(V,A)', iinfo, n,
927 $ jtype, ioldsd
928 info = abs( iinfo )
929 IF( iinfo.LT.0 ) THEN
930 RETURN
931 ELSE
932 result( 7 ) = ulpinv
933 result( 8 ) = ulpinv
934 GO TO 320
935 END IF
936 END IF
937 IF( n.GT.0 ) THEN
938 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
939 ELSE
940 temp3 = zero
941 END IF
942*
943* Do tests 7 and 8.
944*
945 DO 280 i = 1, n
946 d3( i ) = real( a( i, i ) )
947 280 CONTINUE
948 DO 290 i = 1, n - 1
949 d4( i ) = real( a( i+1, i ) )
950 290 CONTINUE
951 CALL sstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
952 $ result( 7 ) )
953*
954 ntest = 9
955 DO 300 i = 1, n - 1
956 d4( i ) = real( a( i+1, i ) )
957 300 CONTINUE
958 srnamt = 'SSTEVR'
959 CALL sstevr( 'N', 'A', n, d3, d4, vl, vu, il, iu, abstol,
960 $ m2, wa2, z, ldu, iwork, work, lwork,
961 $ iwork(2*n+1), liwork-2*n, iinfo )
962 IF( iinfo.NE.0 ) THEN
963 WRITE( nounit, fmt = 9999 )'SSTEVR(N,A)', iinfo, n,
964 $ jtype, ioldsd
965 info = abs( iinfo )
966 IF( iinfo.LT.0 ) THEN
967 RETURN
968 ELSE
969 result( 9 ) = ulpinv
970 GO TO 320
971 END IF
972 END IF
973*
974* Do test 9.
975*
976 temp1 = zero
977 temp2 = zero
978 DO 310 j = 1, n
979 temp1 = max( temp1, abs( wa2( j ) ),
980 $ abs( eveigs( j ) ) )
981 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
982 310 CONTINUE
983 result( 9 ) = temp2 / max( unfl,
984 $ ulp*max( temp1, temp2 ) )
985*
986 320 CONTINUE
987*
988*
989 ntest = 10
990 DO 330 i = 1, n
991 d1( i ) = real( a( i, i ) )
992 330 CONTINUE
993 DO 340 i = 1, n - 1
994 d2( i ) = real( a( i+1, i ) )
995 340 CONTINUE
996 srnamt = 'SSTEVX'
997 CALL sstevx( 'V', 'I', n, d1, d2, vl, vu, il, iu, abstol,
998 $ m2, wa2, z, ldu, work, iwork,
999 $ iwork( 5*n+1 ), iinfo )
1000 IF( iinfo.NE.0 ) THEN
1001 WRITE( nounit, fmt = 9999 )'SSTEVX(V,I)', iinfo, n,
1002 $ jtype, ioldsd
1003 info = abs( iinfo )
1004 IF( iinfo.LT.0 ) THEN
1005 RETURN
1006 ELSE
1007 result( 10 ) = ulpinv
1008 result( 11 ) = ulpinv
1009 result( 12 ) = ulpinv
1010 GO TO 380
1011 END IF
1012 END IF
1013*
1014* Do tests 10 and 11.
1015*
1016 DO 350 i = 1, n
1017 d3( i ) = real( a( i, i ) )
1018 350 CONTINUE
1019 DO 360 i = 1, n - 1
1020 d4( i ) = real( a( i+1, i ) )
1021 360 CONTINUE
1022 CALL sstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1023 $ max( 1, m2 ), result( 10 ) )
1024*
1025*
1026 ntest = 12
1027 DO 370 i = 1, n - 1
1028 d4( i ) = real( a( i+1, i ) )
1029 370 CONTINUE
1030 srnamt = 'SSTEVX'
1031 CALL sstevx( 'N', 'I', n, d3, d4, vl, vu, il, iu, abstol,
1032 $ m3, wa3, z, ldu, work, iwork,
1033 $ iwork( 5*n+1 ), iinfo )
1034 IF( iinfo.NE.0 ) THEN
1035 WRITE( nounit, fmt = 9999 )'SSTEVX(N,I)', iinfo, n,
1036 $ jtype, ioldsd
1037 info = abs( iinfo )
1038 IF( iinfo.LT.0 ) THEN
1039 RETURN
1040 ELSE
1041 result( 12 ) = ulpinv
1042 GO TO 380
1043 END IF
1044 END IF
1045*
1046* Do test 12.
1047*
1048 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1049 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1050 result( 12 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1051*
1052 380 CONTINUE
1053*
1054 ntest = 12
1055 IF( n.GT.0 ) THEN
1056 IF( il.NE.1 ) THEN
1057 vl = wa1( il ) - max( half*
1058 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1059 $ ten*rtunfl )
1060 ELSE
1061 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1062 $ ten*ulp*temp3, ten*rtunfl )
1063 END IF
1064 IF( iu.NE.n ) THEN
1065 vu = wa1( iu ) + max( half*
1066 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1067 $ ten*rtunfl )
1068 ELSE
1069 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1070 $ ten*ulp*temp3, ten*rtunfl )
1071 END IF
1072 ELSE
1073 vl = zero
1074 vu = one
1075 END IF
1076*
1077 DO 390 i = 1, n
1078 d1( i ) = real( a( i, i ) )
1079 390 CONTINUE
1080 DO 400 i = 1, n - 1
1081 d2( i ) = real( a( i+1, i ) )
1082 400 CONTINUE
1083 srnamt = 'SSTEVX'
1084 CALL sstevx( 'V', 'V', n, d1, d2, vl, vu, il, iu, abstol,
1085 $ m2, wa2, z, ldu, work, iwork,
1086 $ iwork( 5*n+1 ), iinfo )
1087 IF( iinfo.NE.0 ) THEN
1088 WRITE( nounit, fmt = 9999 )'SSTEVX(V,V)', iinfo, n,
1089 $ jtype, ioldsd
1090 info = abs( iinfo )
1091 IF( iinfo.LT.0 ) THEN
1092 RETURN
1093 ELSE
1094 result( 13 ) = ulpinv
1095 result( 14 ) = ulpinv
1096 result( 15 ) = ulpinv
1097 GO TO 440
1098 END IF
1099 END IF
1100*
1101 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1102 result( 13 ) = ulpinv
1103 result( 14 ) = ulpinv
1104 result( 15 ) = ulpinv
1105 GO TO 440
1106 END IF
1107*
1108* Do tests 13 and 14.
1109*
1110 DO 410 i = 1, n
1111 d3( i ) = real( a( i, i ) )
1112 410 CONTINUE
1113 DO 420 i = 1, n - 1
1114 d4( i ) = real( a( i+1, i ) )
1115 420 CONTINUE
1116 CALL sstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1117 $ max( 1, m2 ), result( 13 ) )
1118*
1119 ntest = 15
1120 DO 430 i = 1, n - 1
1121 d4( i ) = real( a( i+1, i ) )
1122 430 CONTINUE
1123 srnamt = 'SSTEVX'
1124 CALL sstevx( 'N', 'V', n, d3, d4, vl, vu, il, iu, abstol,
1125 $ m3, wa3, z, ldu, work, iwork,
1126 $ iwork( 5*n+1 ), iinfo )
1127 IF( iinfo.NE.0 ) THEN
1128 WRITE( nounit, fmt = 9999 )'SSTEVX(N,V)', iinfo, n,
1129 $ jtype, ioldsd
1130 info = abs( iinfo )
1131 IF( iinfo.LT.0 ) THEN
1132 RETURN
1133 ELSE
1134 result( 15 ) = ulpinv
1135 GO TO 440
1136 END IF
1137 END IF
1138*
1139* Do test 15.
1140*
1141 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1142 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1143 result( 15 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1144*
1145 440 CONTINUE
1146*
1147 ntest = 16
1148 DO 450 i = 1, n
1149 d1( i ) = real( a( i, i ) )
1150 450 CONTINUE
1151 DO 460 i = 1, n - 1
1152 d2( i ) = real( a( i+1, i ) )
1153 460 CONTINUE
1154 srnamt = 'SSTEVD'
1155 CALL sstevd( 'V', n, d1, d2, z, ldu, work, lwedc, iwork,
1156 $ liwedc, iinfo )
1157 IF( iinfo.NE.0 ) THEN
1158 WRITE( nounit, fmt = 9999 )'SSTEVD(V)', iinfo, n,
1159 $ jtype, ioldsd
1160 info = abs( iinfo )
1161 IF( iinfo.LT.0 ) THEN
1162 RETURN
1163 ELSE
1164 result( 16 ) = ulpinv
1165 result( 17 ) = ulpinv
1166 result( 18 ) = ulpinv
1167 GO TO 510
1168 END IF
1169 END IF
1170*
1171* Do tests 16 and 17.
1172*
1173 DO 470 i = 1, n
1174 d3( i ) = real( a( i, i ) )
1175 470 CONTINUE
1176 DO 480 i = 1, n - 1
1177 d4( i ) = real( a( i+1, i ) )
1178 480 CONTINUE
1179 CALL sstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
1180 $ result( 16 ) )
1181*
1182 ntest = 18
1183 DO 490 i = 1, n - 1
1184 d4( i ) = real( a( i+1, i ) )
1185 490 CONTINUE
1186 srnamt = 'SSTEVD'
1187 CALL sstevd( 'N', n, d3, d4, z, ldu, work, lwedc, iwork,
1188 $ liwedc, iinfo )
1189 IF( iinfo.NE.0 ) THEN
1190 WRITE( nounit, fmt = 9999 )'SSTEVD(N)', iinfo, n,
1191 $ jtype, ioldsd
1192 info = abs( iinfo )
1193 IF( iinfo.LT.0 ) THEN
1194 RETURN
1195 ELSE
1196 result( 18 ) = ulpinv
1197 GO TO 510
1198 END IF
1199 END IF
1200*
1201* Do test 18.
1202*
1203 temp1 = zero
1204 temp2 = zero
1205 DO 500 j = 1, n
1206 temp1 = max( temp1, abs( eveigs( j ) ),
1207 $ abs( d3( j ) ) )
1208 temp2 = max( temp2, abs( eveigs( j )-d3( j ) ) )
1209 500 CONTINUE
1210 result( 18 ) = temp2 / max( unfl,
1211 $ ulp*max( temp1, temp2 ) )
1212*
1213 510 CONTINUE
1214*
1215 ntest = 19
1216 DO 520 i = 1, n
1217 d1( i ) = real( a( i, i ) )
1218 520 CONTINUE
1219 DO 530 i = 1, n - 1
1220 d2( i ) = real( a( i+1, i ) )
1221 530 CONTINUE
1222 srnamt = 'SSTEVR'
1223 CALL sstevr( 'V', 'I', n, d1, d2, vl, vu, il, iu, abstol,
1224 $ m2, wa2, z, ldu, iwork, work, lwork,
1225 $ iwork(2*n+1), liwork-2*n, iinfo )
1226 IF( iinfo.NE.0 ) THEN
1227 WRITE( nounit, fmt = 9999 )'SSTEVR(V,I)', iinfo, n,
1228 $ jtype, ioldsd
1229 info = abs( iinfo )
1230 IF( iinfo.LT.0 ) THEN
1231 RETURN
1232 ELSE
1233 result( 19 ) = ulpinv
1234 result( 20 ) = ulpinv
1235 result( 21 ) = ulpinv
1236 GO TO 570
1237 END IF
1238 END IF
1239*
1240* DO tests 19 and 20.
1241*
1242 DO 540 i = 1, n
1243 d3( i ) = real( a( i, i ) )
1244 540 CONTINUE
1245 DO 550 i = 1, n - 1
1246 d4( i ) = real( a( i+1, i ) )
1247 550 CONTINUE
1248 CALL sstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1249 $ max( 1, m2 ), result( 19 ) )
1250*
1251*
1252 ntest = 21
1253 DO 560 i = 1, n - 1
1254 d4( i ) = real( a( i+1, i ) )
1255 560 CONTINUE
1256 srnamt = 'SSTEVR'
1257 CALL sstevr( 'N', 'I', n, d3, d4, vl, vu, il, iu, abstol,
1258 $ m3, wa3, z, ldu, iwork, work, lwork,
1259 $ iwork(2*n+1), liwork-2*n, iinfo )
1260 IF( iinfo.NE.0 ) THEN
1261 WRITE( nounit, fmt = 9999 )'SSTEVR(N,I)', iinfo, n,
1262 $ jtype, ioldsd
1263 info = abs( iinfo )
1264 IF( iinfo.LT.0 ) THEN
1265 RETURN
1266 ELSE
1267 result( 21 ) = ulpinv
1268 GO TO 570
1269 END IF
1270 END IF
1271*
1272* Do test 21.
1273*
1274 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1275 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1276 result( 21 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1277*
1278 570 CONTINUE
1279*
1280 ntest = 21
1281 IF( n.GT.0 ) THEN
1282 IF( il.NE.1 ) THEN
1283 vl = wa1( il ) - max( half*
1284 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1285 $ ten*rtunfl )
1286 ELSE
1287 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1288 $ ten*ulp*temp3, ten*rtunfl )
1289 END IF
1290 IF( iu.NE.n ) THEN
1291 vu = wa1( iu ) + max( half*
1292 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1293 $ ten*rtunfl )
1294 ELSE
1295 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1296 $ ten*ulp*temp3, ten*rtunfl )
1297 END IF
1298 ELSE
1299 vl = zero
1300 vu = one
1301 END IF
1302*
1303 DO 580 i = 1, n
1304 d1( i ) = real( a( i, i ) )
1305 580 CONTINUE
1306 DO 590 i = 1, n - 1
1307 d2( i ) = real( a( i+1, i ) )
1308 590 CONTINUE
1309 srnamt = 'SSTEVR'
1310 CALL sstevr( 'V', 'V', n, d1, d2, vl, vu, il, iu, abstol,
1311 $ m2, wa2, z, ldu, iwork, work, lwork,
1312 $ iwork(2*n+1), liwork-2*n, iinfo )
1313 IF( iinfo.NE.0 ) THEN
1314 WRITE( nounit, fmt = 9999 )'SSTEVR(V,V)', iinfo, n,
1315 $ jtype, ioldsd
1316 info = abs( iinfo )
1317 IF( iinfo.LT.0 ) THEN
1318 RETURN
1319 ELSE
1320 result( 22 ) = ulpinv
1321 result( 23 ) = ulpinv
1322 result( 24 ) = ulpinv
1323 GO TO 630
1324 END IF
1325 END IF
1326*
1327 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1328 result( 22 ) = ulpinv
1329 result( 23 ) = ulpinv
1330 result( 24 ) = ulpinv
1331 GO TO 630
1332 END IF
1333*
1334* Do tests 22 and 23.
1335*
1336 DO 600 i = 1, n
1337 d3( i ) = real( a( i, i ) )
1338 600 CONTINUE
1339 DO 610 i = 1, n - 1
1340 d4( i ) = real( a( i+1, i ) )
1341 610 CONTINUE
1342 CALL sstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1343 $ max( 1, m2 ), result( 22 ) )
1344*
1345 ntest = 24
1346 DO 620 i = 1, n - 1
1347 d4( i ) = real( a( i+1, i ) )
1348 620 CONTINUE
1349 srnamt = 'SSTEVR'
1350 CALL sstevr( 'N', 'V', n, d3, d4, vl, vu, il, iu, abstol,
1351 $ m3, wa3, z, ldu, iwork, work, lwork,
1352 $ iwork(2*n+1), liwork-2*n, iinfo )
1353 IF( iinfo.NE.0 ) THEN
1354 WRITE( nounit, fmt = 9999 )'SSTEVR(N,V)', iinfo, n,
1355 $ jtype, ioldsd
1356 info = abs( iinfo )
1357 IF( iinfo.LT.0 ) THEN
1358 RETURN
1359 ELSE
1360 result( 24 ) = ulpinv
1361 GO TO 630
1362 END IF
1363 END IF
1364*
1365* Do test 24.
1366*
1367 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1368 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1369 result( 24 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1370*
1371 630 CONTINUE
1372*
1373*
1374*
1375 ELSE
1376*
1377 DO 640 i = 1, 24
1378 result( i ) = zero
1379 640 CONTINUE
1380 ntest = 24
1381 END IF
1382*
1383* Perform remaining tests storing upper or lower triangular
1384* part of matrix.
1385*
1386 DO 1720 iuplo = 0, 1
1387 IF( iuplo.EQ.0 ) THEN
1388 uplo = 'L'
1389 ELSE
1390 uplo = 'U'
1391 END IF
1392*
1393* 4) Call SSYEV and SSYEVX.
1394*
1395 CALL slacpy( ' ', n, n, a, lda, v, ldu )
1396*
1397 ntest = ntest + 1
1398 srnamt = 'SSYEV'
1399 CALL ssyev( 'V', uplo, n, a, ldu, d1, work, lwork,
1400 $ iinfo )
1401 IF( iinfo.NE.0 ) THEN
1402 WRITE( nounit, fmt = 9999 )'SSYEV(V,' // uplo // ')',
1403 $ iinfo, n, jtype, ioldsd
1404 info = abs( iinfo )
1405 IF( iinfo.LT.0 ) THEN
1406 RETURN
1407 ELSE
1408 result( ntest ) = ulpinv
1409 result( ntest+1 ) = ulpinv
1410 result( ntest+2 ) = ulpinv
1411 GO TO 660
1412 END IF
1413 END IF
1414*
1415* Do tests 25 and 26 (or +54)
1416*
1417 CALL ssyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1418 $ ldu, tau, work, result( ntest ) )
1419*
1420 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1421*
1422 ntest = ntest + 2
1423 srnamt = 'SSYEV'
1424 CALL ssyev( 'N', uplo, n, a, ldu, d3, work, lwork,
1425 $ iinfo )
1426 IF( iinfo.NE.0 ) THEN
1427 WRITE( nounit, fmt = 9999 )'SSYEV(N,' // uplo // ')',
1428 $ iinfo, n, jtype, ioldsd
1429 info = abs( iinfo )
1430 IF( iinfo.LT.0 ) THEN
1431 RETURN
1432 ELSE
1433 result( ntest ) = ulpinv
1434 GO TO 660
1435 END IF
1436 END IF
1437*
1438* Do test 27 (or +54)
1439*
1440 temp1 = zero
1441 temp2 = zero
1442 DO 650 j = 1, n
1443 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1444 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1445 650 CONTINUE
1446 result( ntest ) = temp2 / max( unfl,
1447 $ ulp*max( temp1, temp2 ) )
1448*
1449 660 CONTINUE
1450 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1451*
1452 ntest = ntest + 1
1453*
1454 IF( n.GT.0 ) THEN
1455 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1456 IF( il.NE.1 ) THEN
1457 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1458 $ ten*ulp*temp3, ten*rtunfl )
1459 ELSE IF( n.GT.0 ) THEN
1460 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1461 $ ten*ulp*temp3, ten*rtunfl )
1462 END IF
1463 IF( iu.NE.n ) THEN
1464 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1465 $ ten*ulp*temp3, ten*rtunfl )
1466 ELSE IF( n.GT.0 ) THEN
1467 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1468 $ ten*ulp*temp3, ten*rtunfl )
1469 END IF
1470 ELSE
1471 temp3 = zero
1472 vl = zero
1473 vu = one
1474 END IF
1475*
1476 srnamt = 'SSYEVX'
1477 CALL ssyevx( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1478 $ abstol, m, wa1, z, ldu, work, lwork, iwork,
1479 $ iwork( 5*n+1 ), iinfo )
1480 IF( iinfo.NE.0 ) THEN
1481 WRITE( nounit, fmt = 9999 )'SSYEVX(V,A,' // uplo //
1482 $ ')', iinfo, n, jtype, ioldsd
1483 info = abs( iinfo )
1484 IF( iinfo.LT.0 ) THEN
1485 RETURN
1486 ELSE
1487 result( ntest ) = ulpinv
1488 result( ntest+1 ) = ulpinv
1489 result( ntest+2 ) = ulpinv
1490 GO TO 680
1491 END IF
1492 END IF
1493*
1494* Do tests 28 and 29 (or +54)
1495*
1496 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1497*
1498 CALL ssyt21( 1, uplo, n, 0, a, ldu, d1, d2, z, ldu, v,
1499 $ ldu, tau, work, result( ntest ) )
1500*
1501 ntest = ntest + 2
1502 srnamt = 'SSYEVX'
1503 CALL ssyevx( 'N', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1504 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1505 $ iwork( 5*n+1 ), iinfo )
1506 IF( iinfo.NE.0 ) THEN
1507 WRITE( nounit, fmt = 9999 )'SSYEVX(N,A,' // uplo //
1508 $ ')', iinfo, n, jtype, ioldsd
1509 info = abs( iinfo )
1510 IF( iinfo.LT.0 ) THEN
1511 RETURN
1512 ELSE
1513 result( ntest ) = ulpinv
1514 GO TO 680
1515 END IF
1516 END IF
1517*
1518* Do test 30 (or +54)
1519*
1520 temp1 = zero
1521 temp2 = zero
1522 DO 670 j = 1, n
1523 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1524 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1525 670 CONTINUE
1526 result( ntest ) = temp2 / max( unfl,
1527 $ ulp*max( temp1, temp2 ) )
1528*
1529 680 CONTINUE
1530*
1531 ntest = ntest + 1
1532 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1533 srnamt = 'SSYEVX'
1534 CALL ssyevx( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1535 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1536 $ iwork( 5*n+1 ), iinfo )
1537 IF( iinfo.NE.0 ) THEN
1538 WRITE( nounit, fmt = 9999 )'SSYEVX(V,I,' // uplo //
1539 $ ')', iinfo, n, jtype, ioldsd
1540 info = abs( iinfo )
1541 IF( iinfo.LT.0 ) THEN
1542 RETURN
1543 ELSE
1544 result( ntest ) = ulpinv
1545 result( ntest+1 ) = ulpinv
1546 result( ntest+2 ) = ulpinv
1547 GO TO 690
1548 END IF
1549 END IF
1550*
1551* Do tests 31 and 32 (or +54)
1552*
1553 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1554*
1555 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1556 $ v, ldu, tau, work, result( ntest ) )
1557*
1558 ntest = ntest + 2
1559 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1560 srnamt = 'SSYEVX'
1561 CALL ssyevx( 'N', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1562 $ abstol, m3, wa3, z, ldu, work, lwork, iwork,
1563 $ iwork( 5*n+1 ), iinfo )
1564 IF( iinfo.NE.0 ) THEN
1565 WRITE( nounit, fmt = 9999 )'SSYEVX(N,I,' // uplo //
1566 $ ')', iinfo, n, jtype, ioldsd
1567 info = abs( iinfo )
1568 IF( iinfo.LT.0 ) THEN
1569 RETURN
1570 ELSE
1571 result( ntest ) = ulpinv
1572 GO TO 690
1573 END IF
1574 END IF
1575*
1576* Do test 33 (or +54)
1577*
1578 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1579 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1580 result( ntest ) = ( temp1+temp2 ) /
1581 $ max( unfl, ulp*temp3 )
1582 690 CONTINUE
1583*
1584 ntest = ntest + 1
1585 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1586 srnamt = 'SSYEVX'
1587 CALL ssyevx( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
1588 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1589 $ iwork( 5*n+1 ), iinfo )
1590 IF( iinfo.NE.0 ) THEN
1591 WRITE( nounit, fmt = 9999 )'SSYEVX(V,V,' // uplo //
1592 $ ')', iinfo, n, jtype, ioldsd
1593 info = abs( iinfo )
1594 IF( iinfo.LT.0 ) THEN
1595 RETURN
1596 ELSE
1597 result( ntest ) = ulpinv
1598 result( ntest+1 ) = ulpinv
1599 result( ntest+2 ) = ulpinv
1600 GO TO 700
1601 END IF
1602 END IF
1603*
1604* Do tests 34 and 35 (or +54)
1605*
1606 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1607*
1608 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1609 $ v, ldu, tau, work, result( ntest ) )
1610*
1611 ntest = ntest + 2
1612 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1613 srnamt = 'SSYEVX'
1614 CALL ssyevx( 'N', 'V', uplo, n, a, ldu, vl, vu, il, iu,
1615 $ abstol, m3, wa3, z, ldu, work, lwork, iwork,
1616 $ iwork( 5*n+1 ), iinfo )
1617 IF( iinfo.NE.0 ) THEN
1618 WRITE( nounit, fmt = 9999 )'SSYEVX(N,V,' // uplo //
1619 $ ')', iinfo, n, jtype, ioldsd
1620 info = abs( iinfo )
1621 IF( iinfo.LT.0 ) THEN
1622 RETURN
1623 ELSE
1624 result( ntest ) = ulpinv
1625 GO TO 700
1626 END IF
1627 END IF
1628*
1629 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1630 result( ntest ) = ulpinv
1631 GO TO 700
1632 END IF
1633*
1634* Do test 36 (or +54)
1635*
1636 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1637 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1638 IF( n.GT.0 ) THEN
1639 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1640 ELSE
1641 temp3 = zero
1642 END IF
1643 result( ntest ) = ( temp1+temp2 ) /
1644 $ max( unfl, temp3*ulp )
1645*
1646 700 CONTINUE
1647*
1648* 5) Call SSPEV and SSPEVX.
1649*
1650 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1651*
1652* Load array WORK with the upper or lower triangular
1653* part of the matrix in packed form.
1654*
1655 IF( iuplo.EQ.1 ) THEN
1656 indx = 1
1657 DO 720 j = 1, n
1658 DO 710 i = 1, j
1659 work( indx ) = a( i, j )
1660 indx = indx + 1
1661 710 CONTINUE
1662 720 CONTINUE
1663 ELSE
1664 indx = 1
1665 DO 740 j = 1, n
1666 DO 730 i = j, n
1667 work( indx ) = a( i, j )
1668 indx = indx + 1
1669 730 CONTINUE
1670 740 CONTINUE
1671 END IF
1672*
1673 ntest = ntest + 1
1674 srnamt = 'SSPEV'
1675 CALL sspev( 'V', uplo, n, work, d1, z, ldu, v, iinfo )
1676 IF( iinfo.NE.0 ) THEN
1677 WRITE( nounit, fmt = 9999 )'SSPEV(V,' // uplo // ')',
1678 $ iinfo, n, jtype, ioldsd
1679 info = abs( iinfo )
1680 IF( iinfo.LT.0 ) THEN
1681 RETURN
1682 ELSE
1683 result( ntest ) = ulpinv
1684 result( ntest+1 ) = ulpinv
1685 result( ntest+2 ) = ulpinv
1686 GO TO 800
1687 END IF
1688 END IF
1689*
1690* Do tests 37 and 38 (or +54)
1691*
1692 CALL ssyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1693 $ ldu, tau, work, result( ntest ) )
1694*
1695 IF( iuplo.EQ.1 ) THEN
1696 indx = 1
1697 DO 760 j = 1, n
1698 DO 750 i = 1, j
1699 work( indx ) = a( i, j )
1700 indx = indx + 1
1701 750 CONTINUE
1702 760 CONTINUE
1703 ELSE
1704 indx = 1
1705 DO 780 j = 1, n
1706 DO 770 i = j, n
1707 work( indx ) = a( i, j )
1708 indx = indx + 1
1709 770 CONTINUE
1710 780 CONTINUE
1711 END IF
1712*
1713 ntest = ntest + 2
1714 srnamt = 'SSPEV'
1715 CALL sspev( 'N', uplo, n, work, d3, z, ldu, v, iinfo )
1716 IF( iinfo.NE.0 ) THEN
1717 WRITE( nounit, fmt = 9999 )'SSPEV(N,' // uplo // ')',
1718 $ iinfo, n, jtype, ioldsd
1719 info = abs( iinfo )
1720 IF( iinfo.LT.0 ) THEN
1721 RETURN
1722 ELSE
1723 result( ntest ) = ulpinv
1724 GO TO 800
1725 END IF
1726 END IF
1727*
1728* Do test 39 (or +54)
1729*
1730 temp1 = zero
1731 temp2 = zero
1732 DO 790 j = 1, n
1733 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1734 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1735 790 CONTINUE
1736 result( ntest ) = temp2 / max( unfl,
1737 $ ulp*max( temp1, temp2 ) )
1738*
1739* Load array WORK with the upper or lower triangular part
1740* of the matrix in packed form.
1741*
1742 800 CONTINUE
1743 IF( iuplo.EQ.1 ) THEN
1744 indx = 1
1745 DO 820 j = 1, n
1746 DO 810 i = 1, j
1747 work( indx ) = a( i, j )
1748 indx = indx + 1
1749 810 CONTINUE
1750 820 CONTINUE
1751 ELSE
1752 indx = 1
1753 DO 840 j = 1, n
1754 DO 830 i = j, n
1755 work( indx ) = a( i, j )
1756 indx = indx + 1
1757 830 CONTINUE
1758 840 CONTINUE
1759 END IF
1760*
1761 ntest = ntest + 1
1762*
1763 IF( n.GT.0 ) THEN
1764 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1765 IF( il.NE.1 ) THEN
1766 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1767 $ ten*ulp*temp3, ten*rtunfl )
1768 ELSE IF( n.GT.0 ) THEN
1769 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1770 $ ten*ulp*temp3, ten*rtunfl )
1771 END IF
1772 IF( iu.NE.n ) THEN
1773 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1774 $ ten*ulp*temp3, ten*rtunfl )
1775 ELSE IF( n.GT.0 ) THEN
1776 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1777 $ ten*ulp*temp3, ten*rtunfl )
1778 END IF
1779 ELSE
1780 temp3 = zero
1781 vl = zero
1782 vu = one
1783 END IF
1784*
1785 srnamt = 'SSPEVX'
1786 CALL sspevx( 'V', 'A', uplo, n, work, vl, vu, il, iu,
1787 $ abstol, m, wa1, z, ldu, v, iwork,
1788 $ iwork( 5*n+1 ), iinfo )
1789 IF( iinfo.NE.0 ) THEN
1790 WRITE( nounit, fmt = 9999 )'SSPEVX(V,A,' // uplo //
1791 $ ')', iinfo, n, jtype, ioldsd
1792 info = abs( iinfo )
1793 IF( iinfo.LT.0 ) THEN
1794 RETURN
1795 ELSE
1796 result( ntest ) = ulpinv
1797 result( ntest+1 ) = ulpinv
1798 result( ntest+2 ) = ulpinv
1799 GO TO 900
1800 END IF
1801 END IF
1802*
1803* Do tests 40 and 41 (or +54)
1804*
1805 CALL ssyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1806 $ ldu, tau, work, result( ntest ) )
1807*
1808 ntest = ntest + 2
1809*
1810 IF( iuplo.EQ.1 ) THEN
1811 indx = 1
1812 DO 860 j = 1, n
1813 DO 850 i = 1, j
1814 work( indx ) = a( i, j )
1815 indx = indx + 1
1816 850 CONTINUE
1817 860 CONTINUE
1818 ELSE
1819 indx = 1
1820 DO 880 j = 1, n
1821 DO 870 i = j, n
1822 work( indx ) = a( i, j )
1823 indx = indx + 1
1824 870 CONTINUE
1825 880 CONTINUE
1826 END IF
1827*
1828 srnamt = 'SSPEVX'
1829 CALL sspevx( 'N', 'A', uplo, n, work, vl, vu, il, iu,
1830 $ abstol, m2, wa2, z, ldu, v, iwork,
1831 $ iwork( 5*n+1 ), iinfo )
1832 IF( iinfo.NE.0 ) THEN
1833 WRITE( nounit, fmt = 9999 )'SSPEVX(N,A,' // uplo //
1834 $ ')', iinfo, n, jtype, ioldsd
1835 info = abs( iinfo )
1836 IF( iinfo.LT.0 ) THEN
1837 RETURN
1838 ELSE
1839 result( ntest ) = ulpinv
1840 GO TO 900
1841 END IF
1842 END IF
1843*
1844* Do test 42 (or +54)
1845*
1846 temp1 = zero
1847 temp2 = zero
1848 DO 890 j = 1, n
1849 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1850 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1851 890 CONTINUE
1852 result( ntest ) = temp2 / max( unfl,
1853 $ ulp*max( temp1, temp2 ) )
1854*
1855 900 CONTINUE
1856 IF( iuplo.EQ.1 ) THEN
1857 indx = 1
1858 DO 920 j = 1, n
1859 DO 910 i = 1, j
1860 work( indx ) = a( i, j )
1861 indx = indx + 1
1862 910 CONTINUE
1863 920 CONTINUE
1864 ELSE
1865 indx = 1
1866 DO 940 j = 1, n
1867 DO 930 i = j, n
1868 work( indx ) = a( i, j )
1869 indx = indx + 1
1870 930 CONTINUE
1871 940 CONTINUE
1872 END IF
1873*
1874 ntest = ntest + 1
1875*
1876 srnamt = 'SSPEVX'
1877 CALL sspevx( 'V', 'I', uplo, n, work, vl, vu, il, iu,
1878 $ abstol, m2, wa2, z, ldu, v, iwork,
1879 $ iwork( 5*n+1 ), iinfo )
1880 IF( iinfo.NE.0 ) THEN
1881 WRITE( nounit, fmt = 9999 )'SSPEVX(V,I,' // uplo //
1882 $ ')', iinfo, n, jtype, ioldsd
1883 info = abs( iinfo )
1884 IF( iinfo.LT.0 ) THEN
1885 RETURN
1886 ELSE
1887 result( ntest ) = ulpinv
1888 result( ntest+1 ) = ulpinv
1889 result( ntest+2 ) = ulpinv
1890 GO TO 990
1891 END IF
1892 END IF
1893*
1894* Do tests 43 and 44 (or +54)
1895*
1896 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1897 $ v, ldu, tau, work, result( ntest ) )
1898*
1899 ntest = ntest + 2
1900*
1901 IF( iuplo.EQ.1 ) THEN
1902 indx = 1
1903 DO 960 j = 1, n
1904 DO 950 i = 1, j
1905 work( indx ) = a( i, j )
1906 indx = indx + 1
1907 950 CONTINUE
1908 960 CONTINUE
1909 ELSE
1910 indx = 1
1911 DO 980 j = 1, n
1912 DO 970 i = j, n
1913 work( indx ) = a( i, j )
1914 indx = indx + 1
1915 970 CONTINUE
1916 980 CONTINUE
1917 END IF
1918*
1919 srnamt = 'SSPEVX'
1920 CALL sspevx( 'N', 'I', uplo, n, work, vl, vu, il, iu,
1921 $ abstol, m3, wa3, z, ldu, v, iwork,
1922 $ iwork( 5*n+1 ), iinfo )
1923 IF( iinfo.NE.0 ) THEN
1924 WRITE( nounit, fmt = 9999 )'SSPEVX(N,I,' // uplo //
1925 $ ')', iinfo, n, jtype, ioldsd
1926 info = abs( iinfo )
1927 IF( iinfo.LT.0 ) THEN
1928 RETURN
1929 ELSE
1930 result( ntest ) = ulpinv
1931 GO TO 990
1932 END IF
1933 END IF
1934*
1935 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1936 result( ntest ) = ulpinv
1937 GO TO 990
1938 END IF
1939*
1940* Do test 45 (or +54)
1941*
1942 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1943 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1944 IF( n.GT.0 ) THEN
1945 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1946 ELSE
1947 temp3 = zero
1948 END IF
1949 result( ntest ) = ( temp1+temp2 ) /
1950 $ max( unfl, temp3*ulp )
1951*
1952 990 CONTINUE
1953 IF( iuplo.EQ.1 ) THEN
1954 indx = 1
1955 DO 1010 j = 1, n
1956 DO 1000 i = 1, j
1957 work( indx ) = a( i, j )
1958 indx = indx + 1
1959 1000 CONTINUE
1960 1010 CONTINUE
1961 ELSE
1962 indx = 1
1963 DO 1030 j = 1, n
1964 DO 1020 i = j, n
1965 work( indx ) = a( i, j )
1966 indx = indx + 1
1967 1020 CONTINUE
1968 1030 CONTINUE
1969 END IF
1970*
1971 ntest = ntest + 1
1972*
1973 srnamt = 'SSPEVX'
1974 CALL sspevx( 'V', 'V', uplo, n, work, vl, vu, il, iu,
1975 $ abstol, m2, wa2, z, ldu, v, iwork,
1976 $ iwork( 5*n+1 ), iinfo )
1977 IF( iinfo.NE.0 ) THEN
1978 WRITE( nounit, fmt = 9999 )'SSPEVX(V,V,' // uplo //
1979 $ ')', iinfo, n, jtype, ioldsd
1980 info = abs( iinfo )
1981 IF( iinfo.LT.0 ) THEN
1982 RETURN
1983 ELSE
1984 result( ntest ) = ulpinv
1985 result( ntest+1 ) = ulpinv
1986 result( ntest+2 ) = ulpinv
1987 GO TO 1080
1988 END IF
1989 END IF
1990*
1991* Do tests 46 and 47 (or +54)
1992*
1993 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1994 $ v, ldu, tau, work, result( ntest ) )
1995*
1996 ntest = ntest + 2
1997*
1998 IF( iuplo.EQ.1 ) THEN
1999 indx = 1
2000 DO 1050 j = 1, n
2001 DO 1040 i = 1, j
2002 work( indx ) = a( i, j )
2003 indx = indx + 1
2004 1040 CONTINUE
2005 1050 CONTINUE
2006 ELSE
2007 indx = 1
2008 DO 1070 j = 1, n
2009 DO 1060 i = j, n
2010 work( indx ) = a( i, j )
2011 indx = indx + 1
2012 1060 CONTINUE
2013 1070 CONTINUE
2014 END IF
2015*
2016 srnamt = 'SSPEVX'
2017 CALL sspevx( 'N', 'V', uplo, n, work, vl, vu, il, iu,
2018 $ abstol, m3, wa3, z, ldu, v, iwork,
2019 $ iwork( 5*n+1 ), iinfo )
2020 IF( iinfo.NE.0 ) THEN
2021 WRITE( nounit, fmt = 9999 )'SSPEVX(N,V,' // uplo //
2022 $ ')', iinfo, n, jtype, ioldsd
2023 info = abs( iinfo )
2024 IF( iinfo.LT.0 ) THEN
2025 RETURN
2026 ELSE
2027 result( ntest ) = ulpinv
2028 GO TO 1080
2029 END IF
2030 END IF
2031*
2032 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2033 result( ntest ) = ulpinv
2034 GO TO 1080
2035 END IF
2036*
2037* Do test 48 (or +54)
2038*
2039 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2040 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2041 IF( n.GT.0 ) THEN
2042 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2043 ELSE
2044 temp3 = zero
2045 END IF
2046 result( ntest ) = ( temp1+temp2 ) /
2047 $ max( unfl, temp3*ulp )
2048*
2049 1080 CONTINUE
2050*
2051* 6) Call SSBEV and SSBEVX.
2052*
2053 IF( jtype.LE.7 ) THEN
2054 kd = 1
2055 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2056 kd = max( n-1, 0 )
2057 ELSE
2058 kd = ihbw
2059 END IF
2060*
2061* Load array V with the upper or lower triangular part
2062* of the matrix in band form.
2063*
2064 IF( iuplo.EQ.1 ) THEN
2065 DO 1100 j = 1, n
2066 DO 1090 i = max( 1, j-kd ), j
2067 v( kd+1+i-j, j ) = a( i, j )
2068 1090 CONTINUE
2069 1100 CONTINUE
2070 ELSE
2071 DO 1120 j = 1, n
2072 DO 1110 i = j, min( n, j+kd )
2073 v( 1+i-j, j ) = a( i, j )
2074 1110 CONTINUE
2075 1120 CONTINUE
2076 END IF
2077*
2078 ntest = ntest + 1
2079 srnamt = 'SSBEV'
2080 CALL ssbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2081 $ iinfo )
2082 IF( iinfo.NE.0 ) THEN
2083 WRITE( nounit, fmt = 9999 )'SSBEV(V,' // uplo // ')',
2084 $ iinfo, n, jtype, ioldsd
2085 info = abs( iinfo )
2086 IF( iinfo.LT.0 ) THEN
2087 RETURN
2088 ELSE
2089 result( ntest ) = ulpinv
2090 result( ntest+1 ) = ulpinv
2091 result( ntest+2 ) = ulpinv
2092 GO TO 1180
2093 END IF
2094 END IF
2095*
2096* Do tests 49 and 50 (or ... )
2097*
2098 CALL ssyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2099 $ ldu, tau, work, result( ntest ) )
2100*
2101 IF( iuplo.EQ.1 ) THEN
2102 DO 1140 j = 1, n
2103 DO 1130 i = max( 1, j-kd ), j
2104 v( kd+1+i-j, j ) = a( i, j )
2105 1130 CONTINUE
2106 1140 CONTINUE
2107 ELSE
2108 DO 1160 j = 1, n
2109 DO 1150 i = j, min( n, j+kd )
2110 v( 1+i-j, j ) = a( i, j )
2111 1150 CONTINUE
2112 1160 CONTINUE
2113 END IF
2114*
2115 ntest = ntest + 2
2116 srnamt = 'SSBEV'
2117 CALL ssbev( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2118 $ iinfo )
2119 IF( iinfo.NE.0 ) THEN
2120 WRITE( nounit, fmt = 9999 )'SSBEV(N,' // uplo // ')',
2121 $ iinfo, n, jtype, ioldsd
2122 info = abs( iinfo )
2123 IF( iinfo.LT.0 ) THEN
2124 RETURN
2125 ELSE
2126 result( ntest ) = ulpinv
2127 GO TO 1180
2128 END IF
2129 END IF
2130*
2131* Do test 51 (or +54)
2132*
2133 temp1 = zero
2134 temp2 = zero
2135 DO 1170 j = 1, n
2136 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2137 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2138 1170 CONTINUE
2139 result( ntest ) = temp2 / max( unfl,
2140 $ ulp*max( temp1, temp2 ) )
2141*
2142* Load array V with the upper or lower triangular part
2143* of the matrix in band form.
2144*
2145 1180 CONTINUE
2146 IF( iuplo.EQ.1 ) THEN
2147 DO 1200 j = 1, n
2148 DO 1190 i = max( 1, j-kd ), j
2149 v( kd+1+i-j, j ) = a( i, j )
2150 1190 CONTINUE
2151 1200 CONTINUE
2152 ELSE
2153 DO 1220 j = 1, n
2154 DO 1210 i = j, min( n, j+kd )
2155 v( 1+i-j, j ) = a( i, j )
2156 1210 CONTINUE
2157 1220 CONTINUE
2158 END IF
2159*
2160 ntest = ntest + 1
2161 srnamt = 'SSBEVX'
2162 CALL ssbevx( 'V', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
2163 $ vu, il, iu, abstol, m, wa2, z, ldu, work,
2164 $ iwork, iwork( 5*n+1 ), iinfo )
2165 IF( iinfo.NE.0 ) THEN
2166 WRITE( nounit, fmt = 9999 )'SSBEVX(V,A,' // uplo //
2167 $ ')', iinfo, n, jtype, ioldsd
2168 info = abs( iinfo )
2169 IF( iinfo.LT.0 ) THEN
2170 RETURN
2171 ELSE
2172 result( ntest ) = ulpinv
2173 result( ntest+1 ) = ulpinv
2174 result( ntest+2 ) = ulpinv
2175 GO TO 1280
2176 END IF
2177 END IF
2178*
2179* Do tests 52 and 53 (or +54)
2180*
2181 CALL ssyt21( 1, uplo, n, 0, a, ldu, wa2, d2, z, ldu, v,
2182 $ ldu, tau, work, result( ntest ) )
2183*
2184 ntest = ntest + 2
2185*
2186 IF( iuplo.EQ.1 ) THEN
2187 DO 1240 j = 1, n
2188 DO 1230 i = max( 1, j-kd ), j
2189 v( kd+1+i-j, j ) = a( i, j )
2190 1230 CONTINUE
2191 1240 CONTINUE
2192 ELSE
2193 DO 1260 j = 1, n
2194 DO 1250 i = j, min( n, j+kd )
2195 v( 1+i-j, j ) = a( i, j )
2196 1250 CONTINUE
2197 1260 CONTINUE
2198 END IF
2199*
2200 srnamt = 'SSBEVX'
2201 CALL ssbevx( 'N', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
2202 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2203 $ iwork, iwork( 5*n+1 ), iinfo )
2204 IF( iinfo.NE.0 ) THEN
2205 WRITE( nounit, fmt = 9999 )'SSBEVX(N,A,' // uplo //
2206 $ ')', iinfo, n, jtype, ioldsd
2207 info = abs( iinfo )
2208 IF( iinfo.LT.0 ) THEN
2209 RETURN
2210 ELSE
2211 result( ntest ) = ulpinv
2212 GO TO 1280
2213 END IF
2214 END IF
2215*
2216* Do test 54 (or +54)
2217*
2218 temp1 = zero
2219 temp2 = zero
2220 DO 1270 j = 1, n
2221 temp1 = max( temp1, abs( wa2( j ) ), abs( wa3( j ) ) )
2222 temp2 = max( temp2, abs( wa2( j )-wa3( j ) ) )
2223 1270 CONTINUE
2224 result( ntest ) = temp2 / max( unfl,
2225 $ ulp*max( temp1, temp2 ) )
2226*
2227 1280 CONTINUE
2228 ntest = ntest + 1
2229 IF( iuplo.EQ.1 ) THEN
2230 DO 1300 j = 1, n
2231 DO 1290 i = max( 1, j-kd ), j
2232 v( kd+1+i-j, j ) = a( i, j )
2233 1290 CONTINUE
2234 1300 CONTINUE
2235 ELSE
2236 DO 1320 j = 1, n
2237 DO 1310 i = j, min( n, j+kd )
2238 v( 1+i-j, j ) = a( i, j )
2239 1310 CONTINUE
2240 1320 CONTINUE
2241 END IF
2242*
2243 srnamt = 'SSBEVX'
2244 CALL ssbevx( 'V', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
2245 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2246 $ iwork, iwork( 5*n+1 ), iinfo )
2247 IF( iinfo.NE.0 ) THEN
2248 WRITE( nounit, fmt = 9999 )'SSBEVX(V,I,' // uplo //
2249 $ ')', iinfo, n, jtype, ioldsd
2250 info = abs( iinfo )
2251 IF( iinfo.LT.0 ) THEN
2252 RETURN
2253 ELSE
2254 result( ntest ) = ulpinv
2255 result( ntest+1 ) = ulpinv
2256 result( ntest+2 ) = ulpinv
2257 GO TO 1370
2258 END IF
2259 END IF
2260*
2261* Do tests 55 and 56 (or +54)
2262*
2263 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2264 $ v, ldu, tau, work, result( ntest ) )
2265*
2266 ntest = ntest + 2
2267*
2268 IF( iuplo.EQ.1 ) THEN
2269 DO 1340 j = 1, n
2270 DO 1330 i = max( 1, j-kd ), j
2271 v( kd+1+i-j, j ) = a( i, j )
2272 1330 CONTINUE
2273 1340 CONTINUE
2274 ELSE
2275 DO 1360 j = 1, n
2276 DO 1350 i = j, min( n, j+kd )
2277 v( 1+i-j, j ) = a( i, j )
2278 1350 CONTINUE
2279 1360 CONTINUE
2280 END IF
2281*
2282 srnamt = 'SSBEVX'
2283 CALL ssbevx( 'N', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
2284 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2285 $ iwork, iwork( 5*n+1 ), iinfo )
2286 IF( iinfo.NE.0 ) THEN
2287 WRITE( nounit, fmt = 9999 )'SSBEVX(N,I,' // uplo //
2288 $ ')', iinfo, n, jtype, ioldsd
2289 info = abs( iinfo )
2290 IF( iinfo.LT.0 ) THEN
2291 RETURN
2292 ELSE
2293 result( ntest ) = ulpinv
2294 GO TO 1370
2295 END IF
2296 END IF
2297*
2298* Do test 57 (or +54)
2299*
2300 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2301 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2302 IF( n.GT.0 ) THEN
2303 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2304 ELSE
2305 temp3 = zero
2306 END IF
2307 result( ntest ) = ( temp1+temp2 ) /
2308 $ max( unfl, temp3*ulp )
2309*
2310 1370 CONTINUE
2311 ntest = ntest + 1
2312 IF( iuplo.EQ.1 ) THEN
2313 DO 1390 j = 1, n
2314 DO 1380 i = max( 1, j-kd ), j
2315 v( kd+1+i-j, j ) = a( i, j )
2316 1380 CONTINUE
2317 1390 CONTINUE
2318 ELSE
2319 DO 1410 j = 1, n
2320 DO 1400 i = j, min( n, j+kd )
2321 v( 1+i-j, j ) = a( i, j )
2322 1400 CONTINUE
2323 1410 CONTINUE
2324 END IF
2325*
2326 srnamt = 'SSBEVX'
2327 CALL ssbevx( 'V', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
2328 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2329 $ iwork, iwork( 5*n+1 ), iinfo )
2330 IF( iinfo.NE.0 ) THEN
2331 WRITE( nounit, fmt = 9999 )'SSBEVX(V,V,' // uplo //
2332 $ ')', iinfo, n, jtype, ioldsd
2333 info = abs( iinfo )
2334 IF( iinfo.LT.0 ) THEN
2335 RETURN
2336 ELSE
2337 result( ntest ) = ulpinv
2338 result( ntest+1 ) = ulpinv
2339 result( ntest+2 ) = ulpinv
2340 GO TO 1460
2341 END IF
2342 END IF
2343*
2344* Do tests 58 and 59 (or +54)
2345*
2346 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2347 $ v, ldu, tau, work, result( ntest ) )
2348*
2349 ntest = ntest + 2
2350*
2351 IF( iuplo.EQ.1 ) THEN
2352 DO 1430 j = 1, n
2353 DO 1420 i = max( 1, j-kd ), j
2354 v( kd+1+i-j, j ) = a( i, j )
2355 1420 CONTINUE
2356 1430 CONTINUE
2357 ELSE
2358 DO 1450 j = 1, n
2359 DO 1440 i = j, min( n, j+kd )
2360 v( 1+i-j, j ) = a( i, j )
2361 1440 CONTINUE
2362 1450 CONTINUE
2363 END IF
2364*
2365 srnamt = 'SSBEVX'
2366 CALL ssbevx( 'N', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
2367 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2368 $ iwork, iwork( 5*n+1 ), iinfo )
2369 IF( iinfo.NE.0 ) THEN
2370 WRITE( nounit, fmt = 9999 )'SSBEVX(N,V,' // uplo //
2371 $ ')', iinfo, n, jtype, ioldsd
2372 info = abs( iinfo )
2373 IF( iinfo.LT.0 ) THEN
2374 RETURN
2375 ELSE
2376 result( ntest ) = ulpinv
2377 GO TO 1460
2378 END IF
2379 END IF
2380*
2381 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2382 result( ntest ) = ulpinv
2383 GO TO 1460
2384 END IF
2385*
2386* Do test 60 (or +54)
2387*
2388 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2389 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2390 IF( n.GT.0 ) THEN
2391 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2392 ELSE
2393 temp3 = zero
2394 END IF
2395 result( ntest ) = ( temp1+temp2 ) /
2396 $ max( unfl, temp3*ulp )
2397*
2398 1460 CONTINUE
2399*
2400* 7) Call SSYEVD
2401*
2402 CALL slacpy( ' ', n, n, a, lda, v, ldu )
2403*
2404 ntest = ntest + 1
2405 srnamt = 'SSYEVD'
2406 CALL ssyevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
2407 $ iwork, liwedc, iinfo )
2408 IF( iinfo.NE.0 ) THEN
2409 WRITE( nounit, fmt = 9999 )'SSYEVD(V,' // uplo //
2410 $ ')', iinfo, n, jtype, ioldsd
2411 info = abs( iinfo )
2412 IF( iinfo.LT.0 ) THEN
2413 RETURN
2414 ELSE
2415 result( ntest ) = ulpinv
2416 result( ntest+1 ) = ulpinv
2417 result( ntest+2 ) = ulpinv
2418 GO TO 1480
2419 END IF
2420 END IF
2421*
2422* Do tests 61 and 62 (or +54)
2423*
2424 CALL ssyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
2425 $ ldu, tau, work, result( ntest ) )
2426*
2427 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2428*
2429 ntest = ntest + 2
2430 srnamt = 'SSYEVD'
2431 CALL ssyevd( 'N', uplo, n, a, ldu, d3, work, lwedc,
2432 $ iwork, liwedc, iinfo )
2433 IF( iinfo.NE.0 ) THEN
2434 WRITE( nounit, fmt = 9999 )'SSYEVD(N,' // uplo //
2435 $ ')', iinfo, n, jtype, ioldsd
2436 info = abs( iinfo )
2437 IF( iinfo.LT.0 ) THEN
2438 RETURN
2439 ELSE
2440 result( ntest ) = ulpinv
2441 GO TO 1480
2442 END IF
2443 END IF
2444*
2445* Do test 63 (or +54)
2446*
2447 temp1 = zero
2448 temp2 = zero
2449 DO 1470 j = 1, n
2450 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2451 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2452 1470 CONTINUE
2453 result( ntest ) = temp2 / max( unfl,
2454 $ ulp*max( temp1, temp2 ) )
2455*
2456 1480 CONTINUE
2457*
2458* 8) Call SSPEVD.
2459*
2460 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2461*
2462* Load array WORK with the upper or lower triangular
2463* part of the matrix in packed form.
2464*
2465 IF( iuplo.EQ.1 ) THEN
2466 indx = 1
2467 DO 1500 j = 1, n
2468 DO 1490 i = 1, j
2469 work( indx ) = a( i, j )
2470 indx = indx + 1
2471 1490 CONTINUE
2472 1500 CONTINUE
2473 ELSE
2474 indx = 1
2475 DO 1520 j = 1, n
2476 DO 1510 i = j, n
2477 work( indx ) = a( i, j )
2478 indx = indx + 1
2479 1510 CONTINUE
2480 1520 CONTINUE
2481 END IF
2482*
2483 ntest = ntest + 1
2484 srnamt = 'SSPEVD'
2485 CALL sspevd( 'V', uplo, n, work, d1, z, ldu,
2486 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2487 $ iinfo )
2488 IF( iinfo.NE.0 ) THEN
2489 WRITE( nounit, fmt = 9999 )'SSPEVD(V,' // uplo //
2490 $ ')', iinfo, n, jtype, ioldsd
2491 info = abs( iinfo )
2492 IF( iinfo.LT.0 ) THEN
2493 RETURN
2494 ELSE
2495 result( ntest ) = ulpinv
2496 result( ntest+1 ) = ulpinv
2497 result( ntest+2 ) = ulpinv
2498 GO TO 1580
2499 END IF
2500 END IF
2501*
2502* Do tests 64 and 65 (or +54)
2503*
2504 CALL ssyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2505 $ ldu, tau, work, result( ntest ) )
2506*
2507 IF( iuplo.EQ.1 ) THEN
2508 indx = 1
2509 DO 1540 j = 1, n
2510 DO 1530 i = 1, j
2511*
2512 work( indx ) = a( i, j )
2513 indx = indx + 1
2514 1530 CONTINUE
2515 1540 CONTINUE
2516 ELSE
2517 indx = 1
2518 DO 1560 j = 1, n
2519 DO 1550 i = j, n
2520 work( indx ) = a( i, j )
2521 indx = indx + 1
2522 1550 CONTINUE
2523 1560 CONTINUE
2524 END IF
2525*
2526 ntest = ntest + 2
2527 srnamt = 'SSPEVD'
2528 CALL sspevd( 'N', uplo, n, work, d3, z, ldu,
2529 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2530 $ iinfo )
2531 IF( iinfo.NE.0 ) THEN
2532 WRITE( nounit, fmt = 9999 )'SSPEVD(N,' // uplo //
2533 $ ')', iinfo, n, jtype, ioldsd
2534 info = abs( iinfo )
2535 IF( iinfo.LT.0 ) THEN
2536 RETURN
2537 ELSE
2538 result( ntest ) = ulpinv
2539 GO TO 1580
2540 END IF
2541 END IF
2542*
2543* Do test 66 (or +54)
2544*
2545 temp1 = zero
2546 temp2 = zero
2547 DO 1570 j = 1, n
2548 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2549 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2550 1570 CONTINUE
2551 result( ntest ) = temp2 / max( unfl,
2552 $ ulp*max( temp1, temp2 ) )
2553 1580 CONTINUE
2554*
2555* 9) Call SSBEVD.
2556*
2557 IF( jtype.LE.7 ) THEN
2558 kd = 1
2559 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2560 kd = max( n-1, 0 )
2561 ELSE
2562 kd = ihbw
2563 END IF
2564*
2565* Load array V with the upper or lower triangular part
2566* of the matrix in band form.
2567*
2568 IF( iuplo.EQ.1 ) THEN
2569 DO 1600 j = 1, n
2570 DO 1590 i = max( 1, j-kd ), j
2571 v( kd+1+i-j, j ) = a( i, j )
2572 1590 CONTINUE
2573 1600 CONTINUE
2574 ELSE
2575 DO 1620 j = 1, n
2576 DO 1610 i = j, min( n, j+kd )
2577 v( 1+i-j, j ) = a( i, j )
2578 1610 CONTINUE
2579 1620 CONTINUE
2580 END IF
2581*
2582 ntest = ntest + 1
2583 srnamt = 'SSBEVD'
2584 CALL ssbevd( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2585 $ lwedc, iwork, liwedc, iinfo )
2586 IF( iinfo.NE.0 ) THEN
2587 WRITE( nounit, fmt = 9999 )'SSBEVD(V,' // uplo //
2588 $ ')', iinfo, n, jtype, ioldsd
2589 info = abs( iinfo )
2590 IF( iinfo.LT.0 ) THEN
2591 RETURN
2592 ELSE
2593 result( ntest ) = ulpinv
2594 result( ntest+1 ) = ulpinv
2595 result( ntest+2 ) = ulpinv
2596 GO TO 1680
2597 END IF
2598 END IF
2599*
2600* Do tests 67 and 68 (or +54)
2601*
2602 CALL ssyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2603 $ ldu, tau, work, result( ntest ) )
2604*
2605 IF( iuplo.EQ.1 ) THEN
2606 DO 1640 j = 1, n
2607 DO 1630 i = max( 1, j-kd ), j
2608 v( kd+1+i-j, j ) = a( i, j )
2609 1630 CONTINUE
2610 1640 CONTINUE
2611 ELSE
2612 DO 1660 j = 1, n
2613 DO 1650 i = j, min( n, j+kd )
2614 v( 1+i-j, j ) = a( i, j )
2615 1650 CONTINUE
2616 1660 CONTINUE
2617 END IF
2618*
2619 ntest = ntest + 2
2620 srnamt = 'SSBEVD'
2621 CALL ssbevd( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2622 $ lwedc, iwork, liwedc, iinfo )
2623 IF( iinfo.NE.0 ) THEN
2624 WRITE( nounit, fmt = 9999 )'SSBEVD(N,' // uplo //
2625 $ ')', iinfo, n, jtype, ioldsd
2626 info = abs( iinfo )
2627 IF( iinfo.LT.0 ) THEN
2628 RETURN
2629 ELSE
2630 result( ntest ) = ulpinv
2631 GO TO 1680
2632 END IF
2633 END IF
2634*
2635* Do test 69 (or +54)
2636*
2637 temp1 = zero
2638 temp2 = zero
2639 DO 1670 j = 1, n
2640 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2641 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2642 1670 CONTINUE
2643 result( ntest ) = temp2 / max( unfl,
2644 $ ulp*max( temp1, temp2 ) )
2645*
2646 1680 CONTINUE
2647*
2648*
2649 CALL slacpy( ' ', n, n, a, lda, v, ldu )
2650 ntest = ntest + 1
2651 srnamt = 'SSYEVR'
2652 CALL ssyevr( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
2653 $ abstol, m, wa1, z, ldu, iwork, work, lwork,
2654 $ iwork(2*n+1), liwork-2*n, iinfo )
2655 IF( iinfo.NE.0 ) THEN
2656 WRITE( nounit, fmt = 9999 )'SSYEVR(V,A,' // uplo //
2657 $ ')', iinfo, n, jtype, ioldsd
2658 info = abs( iinfo )
2659 IF( iinfo.LT.0 ) THEN
2660 RETURN
2661 ELSE
2662 result( ntest ) = ulpinv
2663 result( ntest+1 ) = ulpinv
2664 result( ntest+2 ) = ulpinv
2665 GO TO 1700
2666 END IF
2667 END IF
2668*
2669* Do tests 70 and 71 (or ... )
2670*
2671 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2672*
2673 CALL ssyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
2674 $ ldu, tau, work, result( ntest ) )
2675*
2676 ntest = ntest + 2
2677 srnamt = 'SSYEVR'
2678 CALL ssyevr( 'N', 'A', uplo, n, a, ldu, vl, vu, il, iu,
2679 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2680 $ iwork(2*n+1), liwork-2*n, iinfo )
2681 IF( iinfo.NE.0 ) THEN
2682 WRITE( nounit, fmt = 9999 )'SSYEVR(N,A,' // uplo //
2683 $ ')', iinfo, n, jtype, ioldsd
2684 info = abs( iinfo )
2685 IF( iinfo.LT.0 ) THEN
2686 RETURN
2687 ELSE
2688 result( ntest ) = ulpinv
2689 GO TO 1700
2690 END IF
2691 END IF
2692*
2693* Do test 72 (or ... )
2694*
2695 temp1 = zero
2696 temp2 = zero
2697 DO 1690 j = 1, n
2698 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
2699 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
2700 1690 CONTINUE
2701 result( ntest ) = temp2 / max( unfl,
2702 $ ulp*max( temp1, temp2 ) )
2703*
2704 1700 CONTINUE
2705*
2706 ntest = ntest + 1
2707 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2708 srnamt = 'SSYEVR'
2709 CALL ssyevr( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
2710 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2711 $ iwork(2*n+1), liwork-2*n, iinfo )
2712 IF( iinfo.NE.0 ) THEN
2713 WRITE( nounit, fmt = 9999 )'SSYEVR(V,I,' // uplo //
2714 $ ')', iinfo, n, jtype, ioldsd
2715 info = abs( iinfo )
2716 IF( iinfo.LT.0 ) THEN
2717 RETURN
2718 ELSE
2719 result( ntest ) = ulpinv
2720 result( ntest+1 ) = ulpinv
2721 result( ntest+2 ) = ulpinv
2722 GO TO 1710
2723 END IF
2724 END IF
2725*
2726* Do tests 73 and 74 (or +54)
2727*
2728 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2729*
2730 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2731 $ v, ldu, tau, work, result( ntest ) )
2732*
2733 ntest = ntest + 2
2734 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2735 srnamt = 'SSYEVR'
2736 CALL ssyevr( 'N', 'I', uplo, n, a, ldu, vl, vu, il, iu,
2737 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2738 $ iwork(2*n+1), liwork-2*n, iinfo )
2739 IF( iinfo.NE.0 ) THEN
2740 WRITE( nounit, fmt = 9999 )'SSYEVR(N,I,' // uplo //
2741 $ ')', iinfo, n, jtype, ioldsd
2742 info = abs( iinfo )
2743 IF( iinfo.LT.0 ) THEN
2744 RETURN
2745 ELSE
2746 result( ntest ) = ulpinv
2747 GO TO 1710
2748 END IF
2749 END IF
2750*
2751* Do test 75 (or +54)
2752*
2753 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2754 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2755 result( ntest ) = ( temp1+temp2 ) /
2756 $ max( unfl, ulp*temp3 )
2757 1710 CONTINUE
2758*
2759 ntest = ntest + 1
2760 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2761 srnamt = 'SSYEVR'
2762 CALL ssyevr( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2763 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2764 $ iwork(2*n+1), liwork-2*n, iinfo )
2765 IF( iinfo.NE.0 ) THEN
2766 WRITE( nounit, fmt = 9999 )'SSYEVR(V,V,' // uplo //
2767 $ ')', iinfo, n, jtype, ioldsd
2768 info = abs( iinfo )
2769 IF( iinfo.LT.0 ) THEN
2770 RETURN
2771 ELSE
2772 result( ntest ) = ulpinv
2773 result( ntest+1 ) = ulpinv
2774 result( ntest+2 ) = ulpinv
2775 GO TO 700
2776 END IF
2777 END IF
2778*
2779* Do tests 76 and 77 (or +54)
2780*
2781 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2782*
2783 CALL ssyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2784 $ v, ldu, tau, work, result( ntest ) )
2785*
2786 ntest = ntest + 2
2787 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2788 srnamt = 'SSYEVR'
2789 CALL ssyevr( 'N', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2790 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2791 $ iwork(2*n+1), liwork-2*n, iinfo )
2792 IF( iinfo.NE.0 ) THEN
2793 WRITE( nounit, fmt = 9999 )'SSYEVR(N,V,' // uplo //
2794 $ ')', iinfo, n, jtype, ioldsd
2795 info = abs( iinfo )
2796 IF( iinfo.LT.0 ) THEN
2797 RETURN
2798 ELSE
2799 result( ntest ) = ulpinv
2800 GO TO 700
2801 END IF
2802 END IF
2803*
2804 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2805 result( ntest ) = ulpinv
2806 GO TO 700
2807 END IF
2808*
2809* Do test 78 (or +54)
2810*
2811 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2812 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2813 IF( n.GT.0 ) THEN
2814 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2815 ELSE
2816 temp3 = zero
2817 END IF
2818 result( ntest ) = ( temp1+temp2 ) /
2819 $ max( unfl, temp3*ulp )
2820*
2821 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2822*
2823 1720 CONTINUE
2824*
2825* End of Loop -- Check for RESULT(j) > THRESH
2826*
2827 ntestt = ntestt + ntest
2828*
2829 CALL slafts( 'SST', n, n, jtype, ntest, result, ioldsd,
2830 $ thresh, nounit, nerrs )
2831*
2832 1730 CONTINUE
2833 1740 CONTINUE
2834*
2835* Summary
2836*
2837 CALL alasvm( 'SST', nounit, nerrs, ntestt, 0 )
2838*
2839 9999 FORMAT( ' SDRVST: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
2840 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2841*
2842 RETURN
2843*
2844* End of SDRVST
2845*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
ssbev
subroutine ssbev(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, info)
SSBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition ssbev.f:146
ssbevd
subroutine ssbevd(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, iwork, liwork, info)
SSBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition ssbevd.f:187
ssbevx
subroutine ssbevx(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition ssbevx.f:265
ssyev
subroutine ssyev(jobz, uplo, n, a, lda, w, work, lwork, info)
SSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyev.f:132
ssyevd
subroutine ssyevd(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
SSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyevd.f:176
ssyevr
subroutine ssyevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
SSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyevr.f:336
ssyevx
subroutine ssyevx(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
SSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyevx.f:253
sspev
subroutine sspev(jobz, uplo, n, ap, w, z, ldz, work, info)
SSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition sspev.f:130
sspevd
subroutine sspevd(jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork, liwork, info)
SSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sspevd.f:172
sspevx
subroutine sspevx(jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sspevx.f:234
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
slaset
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition slaset.f:110
sstev
subroutine sstev(jobz, n, d, e, z, ldz, work, info)
SSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition sstev.f:116
sstevd
subroutine sstevd(jobz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
SSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sstevd.f:157
sstevr
subroutine sstevr(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
SSTEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sstevr.f:306
sstevx
subroutine sstevx(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sstevx.f:227
slafts
subroutine slafts(type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
SLAFTS
Definition slafts.f:99
slarnd
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73
slatmr
subroutine slatmr(m, n, dist, iseed, sym, d, mode, cond, dmax, rsign, grade, dl, model, condl, dr, moder, condr, pivtng, ipivot, kl, ku, sparse, anorm, pack, a, lda, iwork, info)
SLATMR
Definition slatmr.f:471
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
sstt21
subroutine sstt21(n, kband, ad, ae, sd, se, u, ldu, work, result)
SSTT21
Definition sstt21.f:127
sstt22
subroutine sstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, result)
SSTT22
Definition sstt22.f:139
ssxt1
real function ssxt1(ijob, d1, n1, d2, n2, abstol, ulp, unfl)
SSXT1
Definition ssxt1.f:106
ssyt21
subroutine ssyt21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
SSYT21
Definition ssyt21.f:207
ssyt22
subroutine ssyt22(itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
SSYT22
Definition ssyt22.f:157
Here is the call graph for this function:
Here is the caller graph for this function: