slattr()

subroutine slattr	(	integer	IMAT,
		character	UPLO,
		character	TRANS,
		character	DIAG,
		integer, dimension( 4 )	ISEED,
		integer	N,
		real, dimension( lda, * )	A,
		integer	LDA,
		real, dimension( * )	B,
		real, dimension( * )	WORK,
		integer	INFO
	)

SLATTR

Purpose:

 SLATTR generates a triangular test matrix.
 IMAT and UPLO uniquely specify the properties of the test
 matrix, which is returned in the array A.

Parameters

[in]	IMAT	IMAT is INTEGER An integer key describing which matrix to generate for this path.
[in]	UPLO	UPLO is CHARACTER*1 Specifies whether the matrix A will be upper or lower triangular. = 'U': Upper triangular = 'L': Lower triangular
[in]	TRANS	TRANS is CHARACTER*1 Specifies whether the matrix or its transpose will be used. = 'N': No transpose = 'T': Transpose = 'C': Conjugate transpose (= Transpose)
[out]	DIAG	DIAG is CHARACTER*1 Specifies whether or not the matrix A is unit triangular. = 'N': Non-unit triangular = 'U': Unit triangular
[in,out]	ISEED	ISEED is INTEGER array, dimension (4) The seed vector for the random number generator (used in SLATMS). Modified on exit.
[in]	N	N is INTEGER The order of the matrix to be generated.
[out]	A	A is REAL array, dimension (LDA,N) The triangular matrix A. If UPLO = 'U', the leading n by n upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If UPLO = 'L', the leading n by n lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If DIAG = 'U', the diagonal elements of A are set so that A(k,k) = k for 1 <= k <= n.
[in]	LDA	LDA is INTEGER The leading dimension of the array A. LDA >= max(1,N).
[out]	B	B is REAL array, dimension (N) The right hand side vector, if IMAT > 10.
[out]	WORK	WORK is REAL array, dimension (3*N)
[out]	INFO	INFO is INTEGER = 0: successful exit < 0: if INFO = -k, the k-th argument had an illegal value

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Date

December 2016

Definition at line 135 of file slattr.f.

*
*  -- 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 ..
      CHARACTER          diag, trans, uplo
      INTEGER            imat, info, lda, n
*     ..
*     .. Array Arguments ..
      INTEGER            iseed( 4 )
      REAL               a( lda, * ), b( * ), work( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               one, two, zero
      parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            upper
      CHARACTER          dist, type
      CHARACTER*3        path
      INTEGER            i, iy, j, jcount, kl, ku, mode
      REAL               anorm, bignum, bnorm, bscal, c, cndnum, plus1,
     $                   plus2, ra, rb, rexp, s, sfac, smlnum, star1,
     $                   texp, tleft, tscal, ulp, unfl, x, y, z
*     ..
*     .. External Functions ..
      LOGICAL            lsame
      INTEGER            isamax
      REAL               slamch, slarnd
      EXTERNAL           lsame, isamax, slamch, slarnd
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slabad, slarnv, slatb4, slatms, srot,
     $                   srotg, sscal, sswap
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, REAL, sign, sqrt
*     ..
*     .. Executable Statements ..
*
      path( 1: 1 ) = 'Single precision'
      path( 2: 3 ) = 'TR'
      unfl = slamch( 'Safe minimum' )
      ulp = slamch( 'Epsilon' )*slamch( 'Base' )
      smlnum = unfl
      bignum = ( one-ulp ) / smlnum
      CALL slabad( smlnum, bignum )
      IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 ) THEN
         diag = 'U'
      ELSE
         diag = 'N'
      END IF
      info = 0
*
*     Quick return if N.LE.0.
*
      IF( n.LE.0 )
     $   RETURN
*
*     Call SLATB4 to set parameters for SLATMS.
*
      upper = lsame( uplo, 'U' )
      IF( upper ) THEN
         CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
     $                cndnum, dist )
      ELSE
         CALL slatb4( path, -imat, n, n, TYPE, kl, ku, anorm, mode,
     $                cndnum, dist )
      END IF
*
*     IMAT <= 6:  Non-unit triangular matrix
*
      IF( imat.LE.6 ) THEN
         CALL slatms( n, n, dist, iseed, TYPE, b, mode, cndnum, anorm,
     $                kl, ku, 'No packing', a, lda, work, info )
*
*     IMAT > 6:  Unit triangular matrix
*     The diagonal is deliberately set to something other than 1.
*
*     IMAT = 7:  Matrix is the identity
*
      ELSE IF( imat.EQ.7 ) THEN
         IF( upper ) THEN
            DO 20 j = 1, n
               DO 10 i = 1, j - 1
                  a( i, j ) = zero
   10          CONTINUE
               a( j, j ) = j
   20       CONTINUE
         ELSE
            DO 40 j = 1, n
               a( j, j ) = j
               DO 30 i = j + 1, n
                  a( i, j ) = zero
   30          CONTINUE
   40       CONTINUE
         END IF
*
*     IMAT > 7:  Non-trivial unit triangular matrix
*
*     Generate a unit triangular matrix T with condition CNDNUM by
*     forming a triangular matrix with known singular values and
*     filling in the zero entries with Givens rotations.
*
      ELSE IF( imat.LE.10 ) THEN
         IF( upper ) THEN
            DO 60 j = 1, n
               DO 50 i = 1, j - 1
                  a( i, j ) = zero
   50          CONTINUE
               a( j, j ) = j
   60       CONTINUE
         ELSE
            DO 80 j = 1, n
               a( j, j ) = j
               DO 70 i = j + 1, n
                  a( i, j ) = zero
   70          CONTINUE
   80       CONTINUE
         END IF
*
*        Since the trace of a unit triangular matrix is 1, the product
*        of its singular values must be 1.  Let s = sqrt(CNDNUM),
*        x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
*        The following triangular matrix has singular values s, 1, 1,
*        ..., 1, 1/s:
*
*        1  y  y  y  ...  y  y  z
*           1  0  0  ...  0  0  y
*              1  0  ...  0  0  y
*                 .  ...  .  .  .
*                     .   .  .  .
*                         1  0  y
*                            1  y
*                               1
*
*        To fill in the zeros, we first multiply by a matrix with small
*        condition number of the form
*
*        1  0  0  0  0  ...
*           1  +  *  0  0  ...
*              1  +  0  0  0
*                 1  +  *  0  0
*                    1  +  0  0
*                       ...
*                          1  +  0
*                             1  0
*                                1
*
*        Each element marked with a '*' is formed by taking the product
*        of the adjacent elements marked with '+'.  The '*'s can be
*        chosen freely, and the '+'s are chosen so that the inverse of
*        T will have elements of the same magnitude as T.  If the *'s in
*        both T and inv(T) have small magnitude, T is well conditioned.
*        The two offdiagonals of T are stored in WORK.
*
*        The product of these two matrices has the form
*
*        1  y  y  y  y  y  .  y  y  z
*           1  +  *  0  0  .  0  0  y
*              1  +  0  0  .  0  0  y
*                 1  +  *  .  .  .  .
*                    1  +  .  .  .  .
*                       .  .  .  .  .
*                          .  .  .  .
*                             1  +  y
*                                1  y
*                                   1
*
*        Now we multiply by Givens rotations, using the fact that
*
*              [  c   s ] [  1   w ] [ -c  -s ] =  [  1  -w ]
*              [ -s   c ] [  0   1 ] [  s  -c ]    [  0   1 ]
*        and
*              [ -c  -s ] [  1   0 ] [  c   s ] =  [  1   0 ]
*              [  s  -c ] [  w   1 ] [ -s   c ]    [ -w   1 ]
*
*        where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
*
         star1 = 0.25
         sfac = 0.5
         plus1 = sfac
         DO 90 j = 1, n, 2
            plus2 = star1 / plus1
            work( j ) = plus1
            work( n+j ) = star1
            IF( j+1.LE.n ) THEN
               work( j+1 ) = plus2
               work( n+j+1 ) = zero
               plus1 = star1 / plus2
               rexp = slarnd( 2, iseed )
               star1 = star1*( sfac**rexp )
               IF( rexp.LT.zero ) THEN
                  star1 = -sfac**( one-rexp )
               ELSE
                  star1 = sfac**( one+rexp )
               END IF
            END IF
   90    CONTINUE
*
         x = sqrt( cndnum ) - 1 / sqrt( cndnum )
         IF( n.GT.2 ) THEN
            y = sqrt( 2. / ( n-2 ) )*x
         ELSE
            y = zero
         END IF
         z = x*x
*
         IF( upper ) THEN
            IF( n.GT.3 ) THEN
               CALL scopy( n-3, work, 1, a( 2, 3 ), lda+1 )
               IF( n.GT.4 )
     $            CALL scopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
            END IF
            DO 100 j = 2, n - 1
               a( 1, j ) = y
               a( j, n ) = y
  100       CONTINUE
            a( 1, n ) = z
         ELSE
            IF( n.GT.3 ) THEN
               CALL scopy( n-3, work, 1, a( 3, 2 ), lda+1 )
               IF( n.GT.4 )
     $            CALL scopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
            END IF
            DO 110 j = 2, n - 1
               a( j, 1 ) = y
               a( n, j ) = y
  110       CONTINUE
            a( n, 1 ) = z
         END IF
*
*        Fill in the zeros using Givens rotations.
*
         IF( upper ) THEN
            DO 120 j = 1, n - 1
               ra = a( j, j+1 )
               rb = 2.0
               CALL srotg( ra, rb, c, s )
*
*              Multiply by [ c  s; -s  c] on the left.
*
               IF( n.GT.j+1 )
     $            CALL srot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
     $                       lda, c, s )
*
*              Multiply by [-c -s;  s -c] on the right.
*
               IF( j.GT.1 )
     $            CALL srot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
*
*              Negate A(J,J+1).
*
               a( j, j+1 ) = -a( j, j+1 )
  120       CONTINUE
         ELSE
            DO 130 j = 1, n - 1
               ra = a( j+1, j )
               rb = 2.0
               CALL srotg( ra, rb, c, s )
*
*              Multiply by [ c -s;  s  c] on the right.
*
               IF( n.GT.j+1 )
     $            CALL srot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
     $                       -s )
*
*              Multiply by [-c  s; -s -c] on the left.
*
               IF( j.GT.1 )
     $            CALL srot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
     $                       s )
*
*              Negate A(J+1,J).
*
               a( j+1, j ) = -a( j+1, j )
  130       CONTINUE
         END IF
*
*     IMAT > 10:  Pathological test cases.  These triangular matrices
*     are badly scaled or badly conditioned, so when used in solving a
*     triangular system they may cause overflow in the solution vector.
*
      ELSE IF( imat.EQ.11 ) THEN
*
*        Type 11:  Generate a triangular matrix with elements between
*        -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
*        Make the right hand side large so that it requires scaling.
*
         IF( upper ) THEN
            DO 140 j = 1, n
               CALL slarnv( 2, iseed, j, a( 1, j ) )
               a( j, j ) = sign( two, a( j, j ) )
  140       CONTINUE
         ELSE
            DO 150 j = 1, n
               CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
               a( j, j ) = sign( two, a( j, j ) )
  150       CONTINUE
         END IF
*
*        Set the right hand side so that the largest value is BIGNUM.
*
         CALL slarnv( 2, iseed, n, b )
         iy = isamax( n, b, 1 )
         bnorm = abs( b( iy ) )
         bscal = bignum / max( one, bnorm )
         CALL sscal( n, bscal, b, 1 )
*
      ELSE IF( imat.EQ.12 ) THEN
*
*        Type 12:  Make the first diagonal element in the solve small to
*        cause immediate overflow when dividing by T(j,j).
*        In type 12, the offdiagonal elements are small (CNORM(j) < 1).
*
         CALL slarnv( 2, iseed, n, b )
         tscal = one / max( one, REAL( N-1 ) )
         IF( upper ) THEN
            DO 160 j = 1, n
               CALL slarnv( 2, iseed, j, a( 1, j ) )
               CALL sscal( j-1, tscal, a( 1, j ), 1 )
               a( j, j ) = sign( one, a( j, j ) )
  160       CONTINUE
            a( n, n ) = smlnum*a( n, n )
         ELSE
            DO 170 j = 1, n
               CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
               IF( n.GT.j )
     $            CALL sscal( n-j, tscal, a( j+1, j ), 1 )
               a( j, j ) = sign( one, a( j, j ) )
  170       CONTINUE
            a( 1, 1 ) = smlnum*a( 1, 1 )
         END IF
*
      ELSE IF( imat.EQ.13 ) THEN
*
*        Type 13:  Make the first diagonal element in the solve small to
*        cause immediate overflow when dividing by T(j,j).
*        In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
         CALL slarnv( 2, iseed, n, b )
         IF( upper ) THEN
            DO 180 j = 1, n
               CALL slarnv( 2, iseed, j, a( 1, j ) )
               a( j, j ) = sign( one, a( j, j ) )
  180       CONTINUE
            a( n, n ) = smlnum*a( n, n )
         ELSE
            DO 190 j = 1, n
               CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
               a( j, j ) = sign( one, a( j, j ) )
  190       CONTINUE
            a( 1, 1 ) = smlnum*a( 1, 1 )
         END IF
*
      ELSE IF( imat.EQ.14 ) THEN
*
*        Type 14:  T is diagonal with small numbers on the diagonal to
*        make the growth factor underflow, but a small right hand side
*        chosen so that the solution does not overflow.
*
         IF( upper ) THEN
            jcount = 1
            DO 210 j = n, 1, -1
               DO 200 i = 1, j - 1
                  a( i, j ) = zero
  200          CONTINUE
               IF( jcount.LE.2 ) THEN
                  a( j, j ) = smlnum
               ELSE
                  a( j, j ) = one
               END IF
               jcount = jcount + 1
               IF( jcount.GT.4 )
     $            jcount = 1
  210       CONTINUE
         ELSE
            jcount = 1
            DO 230 j = 1, n
               DO 220 i = j + 1, n
                  a( i, j ) = zero
  220          CONTINUE
               IF( jcount.LE.2 ) THEN
                  a( j, j ) = smlnum
               ELSE
                  a( j, j ) = one
               END IF
               jcount = jcount + 1
               IF( jcount.GT.4 )
     $            jcount = 1
  230       CONTINUE
         END IF
*
*        Set the right hand side alternately zero and small.
*
         IF( upper ) THEN
            b( 1 ) = zero
            DO 240 i = n, 2, -2
               b( i ) = zero
               b( i-1 ) = smlnum
  240       CONTINUE
         ELSE
            b( n ) = zero
            DO 250 i = 1, n - 1, 2
               b( i ) = zero
               b( i+1 ) = smlnum
  250       CONTINUE
         END IF
*
      ELSE IF( imat.EQ.15 ) THEN
*
*        Type 15:  Make the diagonal elements small to cause gradual
*        overflow when dividing by T(j,j).  To control the amount of
*        scaling needed, the matrix is bidiagonal.
*
         texp = one / max( one, REAL( N-1 ) )
         tscal = smlnum**texp
         CALL slarnv( 2, iseed, n, b )
         IF( upper ) THEN
            DO 270 j = 1, n
               DO 260 i = 1, j - 2
                  a( i, j ) = 0.
  260          CONTINUE
               IF( j.GT.1 )
     $            a( j-1, j ) = -one
               a( j, j ) = tscal
  270       CONTINUE
            b( n ) = one
         ELSE
            DO 290 j = 1, n
               DO 280 i = j + 2, n
                  a( i, j ) = 0.
  280          CONTINUE
               IF( j.LT.n )
     $            a( j+1, j ) = -one
               a( j, j ) = tscal
  290       CONTINUE
            b( 1 ) = one
         END IF
*
      ELSE IF( imat.EQ.16 ) THEN
*
*        Type 16:  One zero diagonal element.
*
         iy = n / 2 + 1
         IF( upper ) THEN
            DO 300 j = 1, n
               CALL slarnv( 2, iseed, j, a( 1, j ) )
               IF( j.NE.iy ) THEN
                  a( j, j ) = sign( two, a( j, j ) )
               ELSE
                  a( j, j ) = zero
               END IF
  300       CONTINUE
         ELSE
            DO 310 j = 1, n
               CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
               IF( j.NE.iy ) THEN
                  a( j, j ) = sign( two, a( j, j ) )
               ELSE
                  a( j, j ) = zero
               END IF
  310       CONTINUE
         END IF
         CALL slarnv( 2, iseed, n, b )
         CALL sscal( n, two, b, 1 )
*
      ELSE IF( imat.EQ.17 ) THEN
*
*        Type 17:  Make the offdiagonal elements large to cause overflow
*        when adding a column of T.  In the non-transposed case, the
*        matrix is constructed to cause overflow when adding a column in
*        every other step.
*
         tscal = unfl / ulp
         tscal = ( one-ulp ) / tscal
         DO 330 j = 1, n
            DO 320 i = 1, n
               a( i, j ) = 0.
  320       CONTINUE
  330    CONTINUE
         texp = one
         IF( upper ) THEN
            DO 340 j = n, 2, -2
               a( 1, j ) = -tscal / REAL( n+1 )
               a( j, j ) = one
               b( j ) = texp*( one-ulp )
               a( 1, j-1 ) = -( tscal / REAL( N+1 ) ) / REAL( n+2 )
               a( j-1, j-1 ) = one
               b( j-1 ) = texp*REAL( n*n+n-1 )
               texp = texp*2.
  340       CONTINUE
            b( 1 ) = ( REAL( N+1 ) / REAL( N+2 ) )*tscal
         ELSE
            DO 350 j = 1, n - 1, 2
               a( n, j ) = -tscal / REAL( n+1 )
               a( j, j ) = one
               b( j ) = texp*( one-ulp )
               a( n, j+1 ) = -( tscal / REAL( N+1 ) ) / REAL( n+2 )
               a( j+1, j+1 ) = one
               b( j+1 ) = texp*REAL( n*n+n-1 )
               texp = texp*2.
  350       CONTINUE
            b( n ) = ( REAL( N+1 ) / REAL( N+2 ) )*tscal
         END IF
*
      ELSE IF( imat.EQ.18 ) THEN
*
*        Type 18:  Generate a unit triangular matrix with elements
*        between -1 and 1, and make the right hand side large so that it
*        requires scaling.
*
         IF( upper ) THEN
            DO 360 j = 1, n
               CALL slarnv( 2, iseed, j-1, a( 1, j ) )
               a( j, j ) = zero
  360       CONTINUE
         ELSE
            DO 370 j = 1, n
               IF( j.LT.n )
     $            CALL slarnv( 2, iseed, n-j, a( j+1, j ) )
               a( j, j ) = zero
  370       CONTINUE
         END IF
*
*        Set the right hand side so that the largest value is BIGNUM.
*
         CALL slarnv( 2, iseed, n, b )
         iy = isamax( n, b, 1 )
         bnorm = abs( b( iy ) )
         bscal = bignum / max( one, bnorm )
         CALL sscal( n, bscal, b, 1 )
*
      ELSE IF( imat.EQ.19 ) THEN
*
*        Type 19:  Generate a triangular matrix with elements between
*        BIGNUM/(n-1) and BIGNUM so that at least one of the column
*        norms will exceed BIGNUM.
*        1/3/91:  SLATRS no longer can handle this case
*
         tleft = bignum / max( one, REAL( N-1 ) )
         tscal = bignum*( REAL( N-1 ) / max( one, REAL( N ) ) )
         IF( upper ) THEN
            DO 390 j = 1, n
               CALL slarnv( 2, iseed, j, a( 1, j ) )
               DO 380 i = 1, j
                  a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
  380          CONTINUE
  390       CONTINUE
         ELSE
            DO 410 j = 1, n
               CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
               DO 400 i = j, n
                  a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
  400          CONTINUE
  410       CONTINUE
         END IF
         CALL slarnv( 2, iseed, n, b )
         CALL sscal( n, two, b, 1 )
      END IF
*
*     Flip the matrix if the transpose will be used.
*
      IF( .NOT.lsame( trans, 'N' ) ) THEN
         IF( upper ) THEN
            DO 420 j = 1, n / 2
               CALL sswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
     $                     -1 )
  420       CONTINUE
         ELSE
            DO 430 j = 1, n / 2
               CALL sswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
     $                     -lda )
  430       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of SLATTR
*

Here is the call graph for this function:

Here is the caller graph for this function: