*> \brief \b SCHKST
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SCHKST( 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
*>
*> SCHKST  checks the symmetric eigenvalue problem routines.
*>
*>    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; SCHKST 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 SCHKST 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', ... )
*>
*> (4)     | I - UV' | / ( n ulp )        SORGTR( UPLO='L', ... )
*>
*> (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,
*>          SCHKST 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, SCHKST
*>          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 SCHKST 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).
*>          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 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 December 2016
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SCHKST( 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.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. 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
      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
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, MIN, REAL, 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( 'SCHKST', -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 ) )
*
*           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 ) )
*
*           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( ' SCHKST: ', 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 SCHKST 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 SCHKST for details.', / )
*     End of SCHKST
*
      END


      PROGRAM fredex
      INTEGER NMAX
      REAL PI
      PARAMETER (NMAX=100,PI=3.14159265)
      INTEGER indx(NMAX),j,n
      REAL a(NMAX,NMAX),g(NMAX),x,d
CU    USES quadmx,ludcmp,lubksb
      n=40
      call quadmx(a,n,NMAX)
      call ludcmp(a,n,NMAX,indx,d)
      do 11 j=1,n
        x=(j-1)*PI/(n-1)
        g(j)=sin(x)
11    continue
      call lubksb(a,n,NMAX,indx,g)
      do 12 j=1,n
        x=(j-1)*PI/(n-1)
        write (*,*) j,x,g(j)
12    continue
      write (*,*) 'normal completion'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fredex.for


c----------------------------------------------------------------------
c parabolic interpolation of signal amplitude and phase,
c finding phase derivative
c----------------------------------------------------------------------
      subroutine fmax(am1,am2,am3,ph1,ph2,ph3,om,dt,t,dph,tm,ph,piover4)
      implicit none
      real*8    t, dph, tm, pi2,ph1,ph2,ph3,ph,om,dt
      real*8    am1,am2,am3,piover4
      real*8    a1,a2,a3,dd
      integer*4 k
c ---
      pi2 = datan(1.0d0)*8.0d0
      dd=am1+am3-2*am2
      t=0.0d0
      if(dd .ne. 0.0d0) then
          t=(am1-am3)/dd/2.0d0
      endif
c  phase derivative
      a1 = ph1
      a2 = ph2
      a3 = ph3
c  check for 2*pi phase jump
      k = nint((a2-a1-om*dt)/pi2)
      a2 = a2-k*pi2
      k = nint((a3-a2-om*dt)/pi2)
      a3 = a3-k*pi2
c interpolation
      dph=t*(a1+a3-2.0d0*a2)+(a3-a1)/2.0d0
      tm=t*t*(am1+am3-2.0d0*am2)/2.0d0+t*(am3-am1)/2.0d0+am2
      ph=t*t*(a1+a3-2.0d0*a2)/2.0d0+t*(a3-a1)/2.0d0+a2+pi2*piover4/8.0d0
      return
      end


program operations

    implicit none
    real(kind=4)              :: blas1_result
    real(kind=4), allocatable :: v(:)
    real(kind=4), allocatable :: w(:)
    real(kind=4), allocatable :: blas2_result(:)
    real(kind=4), allocatable :: A(:,:)
    real(kind=4), allocatable :: B(:,:)
    real(kind=4), allocatable :: blas3_result(:,:)
    integer                   :: s1, s2
    integer                   :: i, j, k
    real                      :: start
    real                      :: finish
    character(len=1)          :: str
    integer                   :: valueRSS

    interface
        subroutine vector_vector_multiply(v, w, result)
            implicit none
            real(kind=4), dimension(:), intent(in) :: v
            real(kind=4), dimension(:), intent(in) :: w
            real(kind=4), intent(out)              :: result
        end subroutine

        subroutine matrix_vector_multiply(A, v, result)
            implicit none
            real(kind=4), dimension(:,:), intent(in)  :: A
            real(kind=4), dimension(:)  , intent(in)  :: v
            real(kind=4), dimension(:)  , intent(out) :: result
        end subroutine

        subroutine matrix_matrix_multiply(A, B, result)
            implicit none
            real(kind=4), dimension(:,:), intent(in)  :: A
            real(kind=4), dimension(:,:), intent(in)  :: B
            real(kind=4), dimension(:,:), intent(out) :: result
        end subroutine
    end interface

    print *, "Enter size of arrays: "; read *, s1, s2
    print *, "Print values and results? [y/n]"; read *, str

    ! Allocate dynamic arrays
    allocate(v(s1))
    allocate(w(s1))
    allocate(blas2_result(s1))
    allocate(A(s1,s2))
    allocate(B(s1,s2))
    allocate(blas3_result(s1,s2))

    call system_mem_usage(valueRSS)
    print *, "memory usage = ", valueRSS

    ! Assign values
    do i = 1, size(v)
        v(i) = i
        w(i) = i+1
    end do

    do i = 1, size(A(:,1))
        do j = 1, size(A(1,:))
            A(i,j) = i
            B(i,j) = i+1
        end do
    end do

    ! Memory requirements
    print *, "Memory occupied v = ", sizeof(v), " bytes"
    print *, "Memory occupied A = ", sizeof(A), " bytes"

    ! Values stored
    if (str == "y") then
        print *, "v = [ "
        do i = 1, size(v)
            print *, v(i)
        end do
        print *, " ]."

        print *, "w = [ "
        do i = 1, size(w)
            print *, w(i)
        end do
        print *, " ]."

        print *, "A = [ "
        do i = 1, size(A(:,1))
            print *, A(i,:)
        end do
        print *, " ]."

        print *, "B = [ "
        do i = 1, size(B(:,1))
            print *, B(i,:)
        end do
        print *, " ]."
    end if

    ! Intrinsic Fortran operations
    start  = 0.
    finish = 0.
    call cpu_time(start)
    blas1_result = dot_product(v, w)
    blas3_result = matmul(A, B)
    call cpu_time(finish)

    print '("CPU time dot_product, matmul = ",f15.10," seconds.")', finish-start

    ! Print results intrinsic operations
    if (str == "y") then
        print *, "intrinsic dot_product(v, w) = ", blas1_result
        print *, "intrinsic matmul(A, B) = [ "
        do i = 1, size(blas3_result(:,1))
            print *, blas3_result(i,:)
        end do
        print *, " ]"
    end if

    ! Coded BLAS operations
    start  = 0.
    finish = 0.
    call cpu_time(start)
    call vector_vector_multiply(v, w, blas1_result)
    call cpu_time(finish)
    print '("CPU time blas 1 = ",f15.10," seconds.")', finish-start

    start  = 0.
    finish = 0.
    call cpu_time(start)
    call matrix_vector_multiply(A, v, blas2_result)
    call cpu_time(finish)
    print '("CPU time blas 2 = ",f15.10," seconds.")', finish-start

    start  = 0.
    finish = 0.
    call cpu_time(start)
    call matrix_matrix_multiply(A, B, blas3_result)
    call cpu_time(finish)
    print '("CPU time blas 3 = ",f15.10," seconds.")', finish-start

    ! Print results implemented BLAS operations
    if (str == "y") then
        print *, "BLAS 1 = ", blas1_result
        print *, "BLAS 2 = [ "
        do i = 1, size(blas2_result)
            print *, blas2_result(i)
        end do
        print *, " ]."
        print *, "BLAS 3 = [ "
        do i = 1, size(blas3_result(:,1))
            print *, blas3_result(i,:)
        end do
        print *, " ]"
    end if

    deallocate(v, w, A, B, blas2_result, blas3_result)

end program operations

!! BLAS 1 operation
subroutine vector_vector_multiply(v, w, result)
    implicit none
    real(kind=4), dimension(:), intent(in) :: v
    real(kind=4), dimension(:), intent(in) :: w
    real(kind=4), intent(out)              :: result
    integer                                :: i

    result = 0.
    !$OMP PARALLEL
    do i = 1, size(v)
        result = result + v(i) * w(i)
    end do
    !$OMP END PARALLEL

end subroutine

!! BLAS 2 operation
subroutine matrix_vector_multiply(A, v, result)
    implicit none
    real(kind=4), dimension(:,:), intent(in)  :: A
    real(kind=4), dimension(:)  , intent(in)  :: v
    real(kind=4), dimension(:)  , intent(out) :: result
    integer                                   :: i, j

    result = 0.
    do i = 1, size(A(:,1))
        do j = 1, size(A(1,:))
            result(i) = result(i) + A(i,j) * v(j)
        end do
    end do

end subroutine

!! BLAS 3 operation
subroutine matrix_matrix_multiply(A, B, result)
    implicit none
    real(kind=4), dimension(:,:), intent(in)  :: A
    real(kind=4), dimension(:,:), intent(in)  :: B
    real(kind=4), dimension(:,:), intent(out) :: result
    integer                                   :: i, j, k

    result = 0.
    !$OMP PARALLEL
    do k = 1, size(A,1)
        do i = 1, size(A,2)
            do j = 1, size(A,1)
                result(i,k) = result(i,k) + A(i,j) * B(j,i)
            end do
        end do
    end do
    !$OMP END PARALLEL

end subroutine

!! Calculate runtime memory usage
subroutine system_mem_usage(valueRSS)
    implicit none
    !use ifport ! --> if on intel compiler
    integer, intent(out) :: valueRSS
    character(len=200)   :: filename=' '
    character(len=80)    :: line
    character(len=8)     :: pid_char=' '
    integer              :: pid
    logical              :: ifxst

    ! return negative number if not found
    valueRSS = -1

    ! get process ID
    pid=getpid()
    write(pid_char,'(I8)') pid
    filename='/proc/'//trim(adjustl(pid_char))//'/status'

    ! read system file
    inquire (file=filename, exist=ifxst)
    if (.not. ifxst) then
        write (*,*) 'system file does not exist'; return
    endif

    open(unit=100, file=filename, action='read')
    do
        read (100, '(a)', end = 120) line
        if (line(1:6) .eq. 'VmRSS:') then
            read (line(7:),*) valueRSS; exit
        endif
    enddo

    120 continue
    close(100)

    return

end subroutine system_mem_usage


MODULE ArrayUtil

  ! #DES: Utility functions for generating and manipulating arrays.

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: ArrayEXP, linspace

CONTAINS

!*

  FUNCTION ArrayEXP(input)

    ! #DES: Take elementwise EXP of real(8) values and return as array
    ! Domain of EXP is R^1, Range is (0,inf)

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: input(:)
    REAL(8) :: ArrayEXP(SIZE(input))
    INTEGER :: i

    ArrayEXP(:) = 0.0d0
    DO i = 1, SIZE(input)
      ArrayEXP(i) = EXP(input(i))
    ENDDO

  END FUNCTION ArrayEXP

!*

  FUNCTION linspace(min, max, nPoints)

    ! #DES: Generate a linearly spaced set of nPoints points between min and max inclusive

    IMPLICIT NONE
    REAL(8), INTENT(IN) :: min, max
    INTEGER, INTENT(IN) :: nPoints
    REAL(8) :: linspace(nPoints), stepSize
    INTEGER :: i

    stepSize = (max - min) / (nPoints - 1)

    DO i = 1, nPoints - 1
      linspace(i) = min + ((i-1) * stepSize)
    ENDDO
    ! The expression inside DO... results in error (INT*REAL8), so that the full input range is not covered.
    ! In order to ensure the correct range is returned, make the final value exact.
    linspace(nPoints) = max

  END FUNCTION linspace

!*

END MODULE ArrayUtil


C/*   15 JUNE 77  ..JEK..    INITIAL RELEASE */
      SUBROUTINE dfft(A,B,NTOT,N,NSPAN,ISN,*,*)
C  MULTIVARIATE COMPLEX FOURIER TRANSFORM, COMPUTED IN PLACE
C    USING MIXED-RADIX FAST FOURIER TRANSFORM ALGORITHM.
C  BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968
C  ARRAYS A AND B ORIGINALLY HOLD THE REAL AND IMAGINARY
C    COMPONENTS OF THE DATA, AND RETURN THE REAL AND
C    IMAGINARY COMPONENTS OF THE RESULTING FOURIER COEFFICIENTS.
C  MULTIVARIATE DATA IS INDEXED ACCORDING TO THE FORTRAN
C    ARRAY ELEMENT SUCCESSOR FUNCTION, WITHOUT LIMIT
C    ON THE NUMBER OF IMPLIED MULTIPLE SUBSCRIPTS.
C    THE SUBROUTINE IS CALLED ONCE FOR EACH VARIATE.
C    THE CALLS FOR A MULTIVARIATE TRANSFORM MAY BE IN ANY ORDER.
C  NTOT IS THE TOTAL NUMBER OF COMPLEX DATA VALUES.
C  N IS THE DIMENSION OF THE CURRENT VARIABLE.
C  NSPAN/N IS THE SPACING OF CONSECUTIVE DATA VALUES
C    WHILE INDEXING THE CURRENT VARIABLE.
C  ISN*NSPAN/N IS THE SPACING OF CONSECUTIVE DATA VALUES.
C  THE SIGN OF ISN DETERMINES THE SIGN OF THE COMPLEX
C    EXPONENTIAL, AND THE MAGNITUDE OF ISN IS NORMALLY ONE.
C  A TRI-VARIATE TRANSFORM WITH A(N1,N2,N3), B(N1,N2,N3)
C    IS COMPUTED BY
C      CALL FFT(A,B,N1*N2*N3,N1,N1,1)
C      CALL FFT(A,B,N1*N2*N3,N2,N1*N2,1)
C      CALL FFT(A,B,N1*N2*N3,N3,N1*N2*N3,1)
C  FOR A SINGLE-VARIATE TRANSFORM,
C    NTOT = N = NSPAN = (NUMBER OF COMPLEX DATA VALUES), E.G.
C      CALL FFT(A,B,N,N,N,1)
C  THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX
C    ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO
C    GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO
C    PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY
C    VALUES, E.G.
C      CALL FFT(A,A(2),NTOT,N,NSPAN,2)
C  ARRAYS AT(MAXF), CK(MAXF), BT(MAXF), SK(MAXF), AND NP(MAXP)
C    ARE USED FOR TEMPORARY STORAGE.  IF THE AVAILABLE STORAGE
C    IS INSUFFICIENT, THE PROGRAM IS TERMINATED BY A STOP.
C    MAXF MUST BE .GE. THE MAXIMUM PRIME FACTOR OF N.
C    MAXP MUST BE .GT. THE NUMBER OF PRIME FACTORS OF N.
C    IN ADDITION, IF THE SQUARE-FREE PORTION K OF N HAS TWO OR
C    MORE PRIME FACTORS, THEN MAXP MUST BE .GE. K-1.
      DIMENSION A(1),B(1)
C  ARRAY STORAGE IN NFAC FOR A MAXIMUM OF 11 FACTORS OF N.
C  IF N HAS MORE THAN ONE SQUARE-FREE FACTOR, THE PRODUCT OF THE
C    SQUARE-FREE FACTORS MUST BE .LE. 210
      DIMENSION NFAC(11),NP(209)
C  ARRAY STORAGE FOR MAXIMUM PRIME FACTOR OF 23
      DIMENSION AT(23),CK(23),BT(23),SK(23)
      EQUIVALENCE (I,II)
C  THE FOLLOWING TWO CONSTANTS SHOULD AGREE WITH THE ARRAY DIMENSIONS.
      MAXF=23
      MAXP=209
      IF(N .LT. 2) RETURN
      INC=ISN
      RAD=8.0*ATAN(1.0)
      S72=RAD/5.0
      C72=COS(S72)
      S72=SIN(S72)
      S120=SQRT(0.75)
      IF(ISN .GE. 0) GO TO 10
      S72=-S72
      S120=-S120
      RAD=-RAD
      INC=-INC
   10 NT=INC*NTOT
      KS=INC*NSPAN
      KSPAN=KS
      NN=NT-INC
      JC=KS/N
      RADF=RAD*FLOAT(JC)*0.5
      I=0
      JF=0
C  DETERMINE THE FACTORS OF N
      M=0
      K=N
      GO TO 20
   15 M=M+1
      NFAC(M)=4
      K=K/16
   20 IF(K-(K/16)*16 .EQ. 0) GO TO 15
      J=3
      JJ=9
      GO TO 30
   25 M=M+1
      NFAC(M)=J
      K=K/JJ
   30 IF(MOD(K,JJ) .EQ. 0) GO TO 25
      J=J+2
      JJ=J**2
      IF(JJ .LE. K) GO TO 30
      IF(K .GT. 4) GO TO 40
      KT=M
      NFAC(M+1)=K
      IF(K .NE. 1) M=M+1
      GO TO 80
   40 IF(K-(K/4)*4 .NE. 0) GO TO 50
      M=M+1
      NFAC(M)=2
      K=K/4
   50 KT=M
      J=2
   60 IF(MOD(K,J) .NE. 0) GO TO 70
      M=M+1
      NFAC(M)=J
      K=K/J
   70 J=((J+1)/2)*2+1
      IF(J .LE. K) GO TO 60
   80 IF(KT .EQ. 0) GO TO 100
      J=KT
   90 M=M+1
      NFAC(M)=NFAC(J)
      J=J-1
      IF(J .NE. 0) GO TO 90
C  COMPUTE FOURIER TRANSFORM
  100 SD=RADF/FLOAT(KSPAN)
      CD=2.0*SIN(SD)**2
      SD=SIN(SD+SD)
      KK=1
      I=I+1
      IF(NFAC(I) .NE. 2) GO TO 400
C  TRANSFORM FOR FACTOR OF 2 (INCLUDING ROTATION FACTOR)
      KSPAN=KSPAN/2
      K1=KSPAN+2
  210 K2=KK+KSPAN
      AK=A(K2)
      BK=B(K2)
      A(K2)=A(KK)-AK
      B(K2)=B(KK)-BK
      A(KK)=A(KK)+AK
      B(KK)=B(KK)+BK
      KK=K2+KSPAN
      IF(KK .LE. NN) GO TO 210
      KK=KK-NN
      IF(KK .LE. JC) GO TO 210
      IF(KK .GT. KSPAN) GO TO 800
  220 C1=1.0-CD
      S1=SD
  230 K2=KK+KSPAN
      AK=A(KK)-A(K2)
      BK=B(KK)-B(K2)
      A(KK)=A(KK)+A(K2)
      B(KK)=B(KK)+B(K2)
      A(K2)=C1*AK-S1*BK
      B(K2)=S1*AK+C1*BK
      KK=K2+KSPAN
      IF(KK .LT. NT) GO TO 230
      K2=KK-NT
      C1=-C1
      KK=K1-K2
      IF(KK .GT. K2) GO TO 230
      AK=C1-(CD*C1+SD*S1)
      S1=(SD*C1-CD*S1)+S1
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION
C    ERROR.  IF ROUNDED ARITHMETIC IS USED, SUBSTITUTE
C     C1=AK
      C1=0.5/(AK**2+S1**2)+0.5
      S1=C1*S1
      C1=C1*AK
      KK=KK+JC
      IF(KK .LT. K2) GO TO 230
      K1=K1+INC+INC
      KK=(K1-KSPAN)/2+JC
      IF(KK .LE. JC+JC) GO TO 220
      GO TO 100
C  TRANSFORM FOR FACTOR OF 3 (OPTIONAL CODE)
  320 K1=KK+KSPAN
      K2=K1+KSPAN
      AK=A(KK)
      BK=B(KK)
      AJ=A(K1)+A(K2)
      BJ=B(K1)+B(K2)
      A(KK)=AK+AJ
      B(KK)=BK+BJ
      AK=-0.5*AJ+AK
      BK=-0.5*BJ+BK
      AJ=(A(K1)-A(K2))*S120
      BJ=(B(K1)-B(K2))*S120
      A(K1)=AK-BJ
      B(K1)=BK+AJ
      A(K2)=AK+BJ
      B(K2)=BK-AJ
      KK=K2+KSPAN
      IF(KK .LT. NN) GO TO 320
      KK=KK-NN
      IF(KK .LE. KSPAN) GO TO 320
      GO TO 700
C  TRANSFORM FOR FACTOR OF 4
  400 IF(NFAC(I) .NE. 4) GO TO 600
      KSPNN=KSPAN
      KSPAN=KSPAN/4
  410 C1=1.0
      S1=0
  420 K1=KK+KSPAN
      K2=K1+KSPAN
      K3=K2+KSPAN
      AKP=A(KK)+A(K2)
      AKM=A(KK)-A(K2)
      AJP=A(K1)+A(K3)
      AJM=A(K1)-A(K3)
      A(KK)=AKP+AJP
      AJP=AKP-AJP
      BKP=B(KK)+B(K2)
      BKM=B(KK)-B(K2)
      BJP=B(K1)+B(K3)
      BJM=B(K1)-B(K3)
      B(KK)=BKP+BJP
      BJP=BKP-BJP
      IF(ISN .LT. 0) GO TO 450
      AKP=AKM-BJM
      AKM=AKM+BJM
      BKP=BKM+AJM
      BKM=BKM-AJM
      IF(S1 .EQ. 0.0) GO TO 460
  430 A(K1)=AKP*C1-BKP*S1
      B(K1)=AKP*S1+BKP*C1
      A(K2)=AJP*C2-BJP*S2
      B(K2)=AJP*S2+BJP*C2
      A(K3)=AKM*C3-BKM*S3
      B(K3)=AKM*S3+BKM*C3
      KK=K3+KSPAN
      IF(KK .LE. NT) GO TO 420
  440 C2=C1-(CD*C1+SD*S1)
      S1=(SD*C1-CD*S1)+S1
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION
C    ERROR.  IF ROUNDED ARITHMETIC IS USED, SUBSTITUTE
C     C1=C2
      C1=0.5/(C2**2+S1**2)+0.5
      S1=C1*S1
      C1=C1*C2
      C2=C1**2-S1**2
      S2=2.0*C1*S1
      C3=C2*C1-S2*S1
      S3=C2*S1+S2*C1
      KK=KK-NT+JC
      IF(KK .LE. KSPAN) GO TO 420
      KK=KK-KSPAN+INC
      IF(KK .LE. JC) GO TO 410
      IF(KSPAN .EQ. JC) GO TO 800
      GO TO 100
  450 AKP=AKM+BJM
      AKM=AKM-BJM
      BKP=BKM-AJM
      BKM=BKM+AJM
      IF(S1 .NE. 0.0) GO TO 430
  460 A(K1)=AKP
      B(K1)=BKP
      A(K2)=AJP
      B(K2)=BJP
      A(K3)=AKM
      B(K3)=BKM
      KK=K3+KSPAN
      IF(KK .LE. NT) GO TO 420
      GO TO 440
C  TRANSFORM FOR FACTOR OF 5 (OPTIONAL CODE)
  510 C2=C72**2-S72**2
      S2=2.0*C72*S72
  520 K1=KK+KSPAN
      K2=K1+KSPAN
      K3=K2+KSPAN
      K4=K3+KSPAN
      AKP=A(K1)+A(K4)
      AKM=A(K1)-A(K4)
      BKP=B(K1)+B(K4)
      BKM=B(K1)-B(K4)
      AJP=A(K2)+A(K3)
      AJM=A(K2)-A(K3)
      BJP=B(K2)+B(K3)
      BJM=B(K2)-B(K3)
      AA=A(KK)
      BB=B(KK)
      A(KK)=AA+AKP+AJP
      B(KK)=BB+BKP+BJP
      AK=AKP*C72+AJP*C2+AA
      BK=BKP*C72+BJP*C2+BB
      AJ=AKM*S72+AJM*S2
      BJ=BKM*S72+BJM*S2
      A(K1)=AK-BJ
      A(K4)=AK+BJ
      B(K1)=BK+AJ
      B(K4)=BK-AJ
      AK=AKP*C2+AJP*C72+AA
      BK=BKP*C2+BJP*C72+BB
      AJ=AKM*S2-AJM*S72
      BJ=BKM*S2-BJM*S72
      A(K2)=AK-BJ
      A(K3)=AK+BJ
      B(K2)=BK+AJ
      B(K3)=BK-AJ
      KK=K4+KSPAN
      IF(KK .LT. NN) GO TO 520
      KK=KK-NN
      IF(KK .LE. KSPAN) GO TO 520
      GO TO 700
C  TRANSFORM FOR ODD FACTORS
  600 K=NFAC(I)
      KSPNN=KSPAN
      KSPAN=KSPAN/K
      IF(K .EQ. 3) GO TO 320
      IF(K .EQ. 5) GO TO 510
      IF(K .EQ. JF) GO TO 640
      JF=K
      S1=RAD/FLOAT(K)
      C1=COS(S1)
      S1=SIN(S1)
      IF(JF .GT. MAXF) RETURN 1
      CK(JF)=1.0
      SK(JF)=0.0
      J=1
  630 CK(J)=CK(K)*C1+SK(K)*S1
      SK(J)=CK(K)*S1-SK(K)*C1
      K=K-1
      CK(K)=CK(J)
      SK(K)=-SK(J)
      J=J+1
      IF(J .LT. K) GO TO 630
  640 K1=KK
      K2=KK+KSPNN
      AA=A(KK)
      BB=B(KK)
      AK=AA
      BK=BB
      J=1
      K1=K1+KSPAN
  650 K2=K2-KSPAN
      J=J+1
      AT(J)=A(K1)+A(K2)
      AK=AT(J)+AK
      BT(J)=B(K1)+B(K2)
      BK=BT(J)+BK
      J=J+1
      AT(J)=A(K1)-A(K2)
      BT(J)=B(K1)-B(K2)
      K1=K1+KSPAN
      IF(K1 .LT. K2) GO TO 650
      A(KK)=AK
      B(KK)=BK
      K1=KK
      K2=KK+KSPNN
      J=1
  660 K1=K1+KSPAN
      K2=K2-KSPAN
      JJ=J
      AK=AA
      BK=BB
      AJ=0.0
      BJ=0.0
      K=1
  670 K=K+1
      AK=AT(K)*CK(JJ)+AK
      BK=BT(K)*CK(JJ)+BK
      K=K+1
      AJ=AT(K)*SK(JJ)+AJ
      BJ=BT(K)*SK(JJ)+BJ
      JJ=JJ+J
      IF(JJ .GT. JF) JJ=JJ-JF
      IF(K .LT. JF) GO TO 670
      K=JF-J
      A(K1)=AK-BJ
      B(K1)=BK+AJ
      A(K2)=AK+BJ
      B(K2)=BK-AJ
      J=J+1
      IF(J .LT. K) GO TO 660
      KK=KK+KSPNN
      IF(KK .LE. NN) GO TO 640
      KK=KK-NN
      IF(KK .LE. KSPAN) GO TO 640
C  MULTIPLY BY ROTATION FACTOR (EXCEPT FOR FACTORS OF 2 AND 4)
  700 IF(I .EQ. M) GO TO 800
      KK=JC+1
  710 C2=1.0-CD
      S1=SD
  720 C1=C2
      S2=S1
      KK=KK+KSPAN
  730 AK=A(KK)
      A(KK)=C2*AK-S2*B(KK)
      B(KK)=S2*AK+C2*B(KK)
      KK=KK+KSPNN
      IF(KK .LE. NT) GO TO 730
      AK=S1*S2
      S2=S1*C2+C1*S2
      C2=C1*C2-AK
      KK=KK-NT+KSPAN
      IF(KK .LE. KSPNN) GO TO 730
      C2=C1-(CD*C1+SD*S1)
      S1=S1+(SD*C1-CD*S1)
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION
C    ERROR.  IF ROUNDED ARITHMETIC IS USED, THEY MAY
C    BE DELETED.
      C1=0.5/(C2**2+S1**2)+0.5
      S1=C1*S1
      C2=C1*C2
      KK=KK-KSPNN+JC
      IF(KK .LE. KSPAN) GO TO 720
      KK=KK-KSPAN+JC+INC
      IF(KK .LE. JC+JC) GO TO 710
      GO TO 100
C  PERMUTE THE RESULTS TO NORMAL ORDER---DONE IN TWO STAGES
C  PERMUTATION FOR SQUARE FACTORS OF N
  800 NP(1)=KS
      IF(KT .EQ. 0) GO TO 890
      K=KT+KT+1
      IF(M .LT. K) K=K-1
      J=1
      NP(K+1)=JC
  810 NP(J+1)=NP(J)/NFAC(J)
      NP(K)=NP(K+1)*NFAC(J)
      J=J+1
      K=K-1
      IF(J .LT. K) GO TO 810
      K3=NP(K+1)
      KSPAN=NP(2)
      KK=JC+1
      K2=KSPAN+1
      J=1
      IF(N .NE. NTOT) GO TO 850
C  PERMUTATION FOR SINGLE-VARIATE TRANSFORM (OPTIONAL CODE)
  820 AK=A(KK)
      A(KK)=A(K2)
      A(K2)=AK
      BK=B(KK)
      B(KK)=B(K2)
      B(K2)=BK
      KK=KK+INC
      K2=KSPAN+K2
      IF(K2 .LT. KS) GO TO 820
  830 K2=K2-NP(J)
      J=J+1
      K2=NP(J+1)+K2
      IF(K2 .GT. NP(J)) GO TO 830
      J=1
  840 IF(KK .LT. K2) GO TO 820
      KK=KK+INC
      K2=KSPAN+K2
      IF(K2 .LT. KS) GO TO 840
      IF(KK .LT. KS) GO TO 830
      JC=K3
      GO TO 890
C  PERMUTATION FOR MULTIVARIATE TRANSFORM
  850 K=KK+JC
  860 AK=A(KK)
      A(KK)=A(K2)
      A(K2)=AK
      BK=B(KK)
      B(KK)=B(K2)
      B(K2)=BK
      KK=KK+INC
      K2=K2+INC
      IF(KK .LT. K) GO TO 860
      KK=KK+KS-JC
      K2=K2+KS-JC
      IF(KK .LT. NT) GO TO 850
      K2=K2-NT+KSPAN
      KK=KK-NT+JC
      IF(K2 .LT. KS) GO TO 850
  870 K2=K2-NP(J)
      J=J+1
      K2=NP(J+1)+K2
      IF(K2 .GT. NP(J)) GO TO 870
      J=1
  880 IF(KK .LT. K2) GO TO 850
      KK=KK+JC
      K2=KSPAN+K2
      IF(K2 .LT. KS) GO TO 880
      IF(KK .LT. KS) GO TO 870
      JC=K3
  890 IF(2*KT+1 .GE. M) RETURN
      KSPNN=NP(KT+1)
C  PERMUTATION FOR SQUARE-FREE FACTORS OF N
      J=M-KT
      NFAC(J+1)=1
  900 NFAC(J)=NFAC(J)*NFAC(J+1)
      J=J-1
      IF(J .NE. KT) GO TO 900
      KT=KT+1
      NN=NFAC(KT)-1
      IF(NN .GT. MAXP) RETURN 2
      JJ=0
      J=0
      GO TO 906
  902 JJ=JJ-K2
      K2=KK
      K=K+1
      KK=NFAC(K)
  904 JJ=KK+JJ
      IF(JJ .GE. K2) GO TO 902
      NP(J)=JJ
  906 K2=NFAC(KT)
      K=KT+1
      KK=NFAC(K)
      J=J+1
      IF(J .LE. NN) GO TO 904
C  DETERMINE THE PERMUTATION CYCLES OF LENGTH GREATER THAN 1
      J=0
      GO TO 914
  910 K=KK
      KK=NP(K)
      NP(K)=-KK
      IF(KK .NE. J) GO TO 910
      K3=KK
  914 J=J+1
      KK=NP(J)
      IF(KK .LT. 0) GO TO 914
      IF(KK .NE. J) GO TO 910
      NP(J)=-J
      IF(J .NE. NN) GO TO 914
      MAXF=INC*MAXF
C  REORDER A AND B, FOLLOWING THE PERMUTATION CYCLES
      GO TO 950
  924 J=J-1
      IF(NP(J) .LT. 0) GO TO 924
      JJ=JC
  926 KSPAN=JJ
      IF(JJ .GT. MAXF) KSPAN=MAXF
      JJ=JJ-KSPAN
      K=NP(J)
      KK=JC*K+II+JJ
      K1=KK+KSPAN
      K2=0
  928 K2=K2+1
      AT(K2)=A(K1)
      BT(K2)=B(K1)
      K1=K1-INC
      IF(K1 .NE. KK) GO TO 928
  932 K1=KK+KSPAN
      K2=K1-JC*(K+NP(K))
      K=-NP(K)
  936 A(K1)=A(K2)
      B(K1)=B(K2)
      K1=K1-INC
      K2=K2-INC
      IF(K1 .NE. KK) GO TO 936
      KK=K2
      IF(K .NE. J) GO TO 932
      K1=KK+KSPAN
      K2=0
  940 K2=K2+1
      A(K1)=AT(K2)
      B(K1)=BT(K2)
      K1=K1-INC
      IF(K1 .NE. KK) GO TO 940
      IF(JJ .NE. 0) GO TO 926
      IF(J .NE. 1) GO TO 924
  950 J=K3+1
      NT=NT-KSPNN
      II=NT-INC+1
      IF(NT .GE. 0) GO TO 924
      RETURN
      END


SUBROUTINE weitn(ord,x,y,sig,mu,eta)

!-------------------------------------------------------------
!
!  Computes the spatial weights
!  From Azmy 1988 in NSE, equations 20a and 20b used
!  First find the epsilons
!  Input: order, dx, dy, total XS, mu, eta
!  Returns: weight for cell (i,j) in x (alpha) and
!            y (beta) directions
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: ord
REAL*8, INTENT(IN) :: x, y, sig, mu, eta
INTEGER :: k
REAL*8 :: shx, shy, chx, chy, epsxe, epsxo, epsye, epsyo
REAL*8 :: smxe, smxo, smye, smyo
      ! Compute the coefficients and the hyperbolic functions
      ex = 0.5*sig*x/mu
      ey = 0.5*sig*y/eta
      shx = SINH(ex)
      shy = SINH(ey)
      chx = COSH(ex)
      chy = COSH(ey)

      ! Initialize values for epsilons from 15c in Azmy '88 NSE
      epsxe = shx/ex
      epsxo = 3.0*(chx-shx/ex)/ex
      epsye = shy/ey
      epsyo = 3.0*(chy-shy/ey)/ey

      ! Initialize summation terms
      smxe = 0.0
      smxo = 0.0
      smye = 0.0
      smyo = 0.0
      k = 0

      ! Start the summations
      DO
         ! Even terms
         smxe = smxe + epsxe
         smye = smye + epsye
         IF (k == ord) EXIT
         k = k + 1

         ! Odd terms
         smxo = smxo + epsxo
         smyo = smyo + epsyo
         IF (k == ord) EXIT
         k = k + 1

         ! Compute the updates
         epsxe = (2.0*k+1.0)*(ex*epsxe/(2.0*k-3.0)-epsxo)/ex
         epsye = (2.0*k+1.0)*(ey*epsye/(2.0*k-3.0)-epsyo)/ey
         epsxo = (2.0*k+3.0)*(ex*epsxo/(2.0*k-1.0)-epsxe)/ex
         epsyo = (2.0*k+3.0)*(ey*epsyo/(2.0*k-1.0)-epsye)/ey
      END DO

      ! Finish by taking ratio related to odd and even summations
      alpha = (chx - smxe)/(shx - smxo)
      beta  = (chy - smye)/(shy - smyo)
      !
!     alpha = 1.0
!     beta  = 1.0
      !
      RETURN
END SUBROUTINE weitn


! @expect verified
! @flag --unroll=10

recursive function fib(n)
  implicit none
  integer, intent(in) :: n
  integer :: fib
  if (n <= 0) then
    fib = 0
  else if (n == 1) then
    fib = 1
  else
    fib = fib(n - 1) + fib(n - 2)
  end if
end function

program main
  use smack
  implicit none
  integer :: fib
  !print *, fib(5) == 5
  !print *, fib(6) == 8
  integer :: z
  !z = fib(2)
  !call assert(z > 18)
  call assert(fib(5) == 5)
  call assert(fib(6) == 8)
end program main


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief truncated series expansion of cosh(x) for x < 0.1
!>    @param[in] x input value
!>    @return truncated function value
      double precision FUNCTION alfa(x)
        IMPLICIT NONE
        DOUBLE PRECISION x
!      double precision x2, x3, x5, x7
        alfa = 0.D0
        IF (abs(x)>1.D-30) alfa = (x/tanh(x)-1.D0)/x

!      if (abs(x).lt.1.d-1) then
!         x2 = x*x
!         x3 = x2*x
!         x5 = x3*x2
!         x7 = x5*x2
!         alfa = x/3.d0 - x3/4.5d1 + 2.d0*x5/9.45d2 -
!     & x7/4.725d3
!         alfa = x*3.333333333333333d-01
!     &        - x3*2.222222222222222d-02
!     &        + x5*2.116402116402117d-03
!     &        - x7*2.116402116402116e-04
!      else
!         alfa=(x/tanh(x) - 1.d0)/x
!      endif
        RETURN
      END


c -----------------------------------
      INTEGER FUNCTION greg2juli (yyyy,mm,dd)
      implicit none
      integer  yyyy,mm,dd

c NCL: julian_day = greg2juld_int (yyyy,mm,dd)

c converts calendar date to Julian date
c .   cf Fliegel & Van Flandern, CACM 11(10):657, 1968

c nomenclature:
c .   yyyy   - year
c .   mm     - month [1 to 12]
c .   dd     - day   [1 to 31]

c A Julian day is defined as the number of days
c .   since January 1, 4713 B.C.
c A Julian day begins at noon Universal Time [UT; 12Z]
c .   of the given date.

c Examples:
c .   integer gregjuli,  julday
c .   julday = greg2juli (1900,1,1)   ==>  julday=2415021

      greg2juli =
     +       dd - 32075 + 1461*(yyyy + 4800 + (mm - 14)/12)/4 +
     +       367*(mm - 2 - ((mm - 14)/12)*12)/12 -
     +       3*((yyyy + 4900 + (mm - 14)/12)/100)/4

      return
      end
c -----------------------------------
      REAL*8 FUNCTION greg2juld (yyyy,mm,dd,hr)
      implicit none
      integer yyyy,mm,dd,hr

c NCL: julian_day = greg2juld_double (yyyy,mm,dd,hr)

c converts calendar date to Julian date
c .   cf Fliegel & Van Flandern, CACM 11(10):657, 1968
c .   =====> minor modifications by Shea <=====

c nomenclature:
c .   yyyy   - year
c .   mm     - month [1 to 12]
c .   dd     - day   [1 to 31]
c .   hr     - hour  [0 =< hour <= 23]

c A Julian day is defined as the number of days
c .   since January 1, 4713 B.C.
c A Julian day begins at noon Universal Time [UT; 12Z]
c .   of the given date.

c Examples:
c .   real julday
c .   julday = greg2juld (1900,1,1,0)    ==>  julday=2415020.5
c .   julday = greg2juld (1900,1,1,3)    ==>  julday=2415020.625
c .   julday = greg2juld (1900,1,1,6)    ==>  julday=2415020.75
c .   julday = greg2juld (1900,1,1,12)   ==>  julday=2415021.
c .   julday = greg2juld (1900,1,1,15)   ==>  julday=2415021.125
c .   julday = greg2juld (1900,1,1,18)   ==>  julday=2415021.25

      integer juld ! local  (julian day)

      juld = dd - 32075 + 1461*(yyyy + 4800 + (mm - 14)/12)/4 +
     +       367*(mm - 2 - ((mm - 14)/12)*12)/12 -
     +       3*((yyyy + 4900 + (mm - 14)/12)/100)/4

      greg2juld = dble(juld)  + dble(hr-12)/dble(24.)

      return
      end
c -------------------------------------------
      SUBROUTINE juld2greg (juld,yyyy,mm,dd,hr)
      implicit none

c NCL: itime = juld2greg_int (juld) where itime(4)

      REAL*8  juld            ! input
      INTEGER yyyy,mm,dd,hr   ! output
      INTEGER jd, k,n         ! local

c expands a Julian date into a calendar date
c cf Fliegel & Van Flandern, CACM 11(10):657, 1968
c .   =====> minor modifications by Shea <=====

c A Julian day is defined as the number of days
c .   since January 1, 4713 B.C.
c A Julian day begins at noon Universal Time [UT; 12Z]
c .   of the given date.

c Examples:
c .   call juld2greg (2415020.5 ,yyyy,mm,dd,hr) ==> 1900,1,1,0
c .   call juld2greg (2415020.75,yyyy,mm,dd,hr) ==> 1900,1,1,6
c .   call juld2greg (2415021.  ,yyyy,mm,dd,hr) ==> 1900,1,1,12
c .   call juld2greg (2415021.25,yyyy,mm,dd,hr) ==> 1900,1,1,18

      jd = int(juld+0.5)                   ! shea

      k  = jd + 68569
      n  = 4*k/146097
      k  = k - (146097*n + 3)/4
      yyyy = 4000*(k + 1)/1461001
      k  = k - 1461*yyyy/4 + 31
      mm = 80*k/2447
      dd = k - 2447*mm/80
      k  = mm/11
      mm = mm + 2 - 12*k
      yyyy = 100*(n - 49) + yyyy + k

      hr = nint(24.*sngl((juld-dble(jd))) + 12.)      ! shea

      return
      end
c -------------------------------------------
      SUBROUTINE juli2greg (juld,yyyy,mm,dd)
      implicit none

c NCL: itime = juld2greg_int (juli) where itime(3)

      INTEGER juld            ! input
      INTEGER yyyy,mm,dd      ! output
      INTEGER jd, k,n         ! local

c expands a Julian date into a calendar date
c cf Fliegel & Van Flandern, CACM 11(10):657, 1968
c .   =====> minor modifications by Shea <=====

c A Julian day is defined as the number of days
c .   since January 1, 4713 B.C.
c A Julian day begins at noon Universal Time [UT; 12Z]
c .   of the given date.

c Examples:
c .   call juli2greg (2415021,nyear,nmo,ndy,nhr) ==> 1900,1,1,12

      jd = juld
      k  = jd + 68569
      n  = 4*k/146097
      k  = k - (146097*n + 3)/4
      yyyy = 4000*(k + 1)/1461001
      k  = k - 1461*yyyy/4 + 31
      mm = 80*k/2447
      dd = k - 2447*mm/80
      k  = mm/11
      mm = mm + 2 - 12*k
      yyyy = 100*(n - 49) + yyyy + k

      return
      end