dlattp.f

Go to the documentation of this file.

*> \brief \b DLATTP
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
*                          INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIAG, TRANS, UPLO
*       INTEGER            IMAT, INFO, N
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       DOUBLE PRECISION   A( * ), B( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLATTP generates a triangular test matrix in packed storage.
*> IMAT and UPLO uniquely specify the properties of the test
*> matrix, which is returned in the array AP.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] IMAT
*> \verbatim
*>          IMAT is INTEGER
*>          An integer key describing which matrix to generate for this
*>          path.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the matrix A will be upper or lower
*>          triangular.
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies whether the matrix or its transpose will be used.
*>          = 'N':  No transpose
*>          = 'T':  Transpose
*>          = 'C':  Conjugate transpose (= Transpose)
*> \endverbatim
*>
*> \param[out] DIAG
*> \verbatim
*>          DIAG is CHARACTER*1
*>          Specifies whether or not the matrix A is unit triangular.
*>          = 'N':  Non-unit triangular
*>          = 'U':  Unit triangular
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          The seed vector for the random number generator (used in
*>          DLATMS).  Modified on exit.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix to be generated.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (N*(N+1)/2)
*>          The upper or lower triangular matrix A, packed columnwise in
*>          a linear array.  The j-th column of A is stored in the array
*>          AP as follows:
*>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
*>          if UPLO = 'L',
*>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (N)
*>          The right hand side vector, if IMAT > 10.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE dlattp( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
     $                   INFO )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            IMAT, INFO, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   A( * ), B( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO, ZERO
      parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      CHARACTER          DIST, PACKIT, TYPE
      CHARACTER*3        PATH
      INTEGER            I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
     $                   kl, ku, mode
      DOUBLE PRECISION   ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
     $                   plus2, ra, rb, rexp, s, sfac, smlnum, star1,
     $                   stemp, t, texp, tleft, tscal, ulp, unfl, x, y,
     $                   z
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLARND
      EXTERNAL           lsame, idamax, dlamch, dlarnd
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlarnv, dlatb4, dlatms, drot, drotg, dscal
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, max, sign, sqrt
*     ..
*     .. Executable Statements ..
*
      path( 1: 1 ) = 'Double precision'
      path( 2: 3 ) = 'TP'
      unfl = dlamch( 'Safe minimum' )
      ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
      smlnum = unfl
      bignum = ( one-ulp ) / smlnum
      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 DLATB4 to set parameters for DLATMS.
*
      upper = lsame( uplo, 'U' )
      IF( upper ) THEN
         CALL dlatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
     $                cndnum, dist )
         packit = 'C'
      ELSE
         CALL dlatb4( path, -imat, n, n, TYPE, kl, ku, anorm, mode,
     $                cndnum, dist )
         packit = 'R'
      END IF
*
*     IMAT <= 6:  Non-unit triangular matrix
*
      IF( imat.LE.6 ) THEN
         CALL dlatms( n, n, dist, iseed, TYPE, b, mode, cndnum, anorm,
     $                kl, ku, packit, a, n, 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
            jc = 1
            DO 20 j = 1, n
               DO 10 i = 1, j - 1
                  a( jc+i-1 ) = zero
   10          CONTINUE
               a( jc+j-1 ) = j
               jc = jc + j
   20       CONTINUE
         ELSE
            jc = 1
            DO 40 j = 1, n
               a( jc ) = j
               DO 30 i = j + 1, n
                  a( jc+i-j ) = zero
   30          CONTINUE
               jc = jc + n - j + 1
   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
            jc = 0
            DO 60 j = 1, n
               DO 50 i = 1, j - 1
                  a( jc+i ) = zero
   50          CONTINUE
               a( jc+j ) = j
               jc = jc + j
   60       CONTINUE
         ELSE
            jc = 1
            DO 80 j = 1, n
               a( jc ) = j
               DO 70 i = j + 1, n
                  a( jc+i-j ) = zero
   70          CONTINUE
               jc = jc + n - j + 1
   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.25d0
         sfac = 0.5d0
         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 = dlarnd( 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 ) - one / sqrt( cndnum )
         IF( n.GT.2 ) THEN
            y = sqrt( two / dble( n-2 ) )*x
         ELSE
            y = zero
         END IF
         z = x*x
*
         IF( upper ) THEN
*
*           Set the upper triangle of A with a unit triangular matrix
*           of known condition number.
*
            jc = 1
            DO 100 j = 2, n
               a( jc+1 ) = y
               IF( j.GT.2 )
     $            a( jc+j-1 ) = work( j-2 )
               IF( j.GT.3 )
     $            a( jc+j-2 ) = work( n+j-3 )
               jc = jc + j
  100       CONTINUE
            jc = jc - n
            a( jc+1 ) = z
            DO 110 j = 2, n - 1
               a( jc+j ) = y
  110       CONTINUE
         ELSE
*
*           Set the lower triangle of A with a unit triangular matrix
*           of known condition number.
*
            DO 120 i = 2, n - 1
               a( i ) = y
  120       CONTINUE
            a( n ) = z
            jc = n + 1
            DO 130 j = 2, n - 1
               a( jc+1 ) = work( j-1 )
               IF( j.LT.n-1 )
     $            a( jc+2 ) = work( n+j-1 )
               a( jc+n-j ) = y
               jc = jc + n - j + 1
  130       CONTINUE
         END IF
*
*        Fill in the zeros using Givens rotations
*
         IF( upper ) THEN
            jc = 1
            DO 150 j = 1, n - 1
               jcnext = jc + j
               ra = a( jcnext+j-1 )
               rb = two
               CALL drotg( ra, rb, c, s )
*
*              Multiply by [ c  s; -s  c] on the left.
*
               IF( n.GT.j+1 ) THEN
                  jx = jcnext + j
                  DO 140 i = j + 2, n
                     stemp = c*a( jx+j ) + s*a( jx+j+1 )
                     a( jx+j+1 ) = -s*a( jx+j ) + c*a( jx+j+1 )
                     a( jx+j ) = stemp
                     jx = jx + i
  140             CONTINUE
               END IF
*
*              Multiply by [-c -s;  s -c] on the right.
*
               IF( j.GT.1 )
     $            CALL drot( j-1, a( jcnext ), 1, a( jc ), 1, -c, -s )
*
*              Negate A(J,J+1).
*
               a( jcnext+j-1 ) = -a( jcnext+j-1 )
               jc = jcnext
  150       CONTINUE
         ELSE
            jc = 1
            DO 170 j = 1, n - 1
               jcnext = jc + n - j + 1
               ra = a( jc+1 )
               rb = two
               CALL drotg( ra, rb, c, s )
*
*              Multiply by [ c -s;  s  c] on the right.
*
               IF( n.GT.j+1 )
     $            CALL drot( n-j-1, a( jcnext+1 ), 1, a( jc+2 ), 1, c,
     $                       -s )
*
*              Multiply by [-c  s; -s -c] on the left.
*
               IF( j.GT.1 ) THEN
                  jx = 1
                  DO 160 i = 1, j - 1
                     stemp = -c*a( jx+j-i ) + s*a( jx+j-i+1 )
                     a( jx+j-i+1 ) = -s*a( jx+j-i ) - c*a( jx+j-i+1 )
                     a( jx+j-i ) = stemp
                     jx = jx + n - i + 1
  160             CONTINUE
               END IF
*
*              Negate A(J+1,J).
*
               a( jc+1 ) = -a( jc+1 )
               jc = jcnext
  170       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
            jc = 1
            DO 180 j = 1, n
               CALL dlarnv( 2, iseed, j, a( jc ) )
               a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
               jc = jc + j
  180       CONTINUE
         ELSE
            jc = 1
            DO 190 j = 1, n
               CALL dlarnv( 2, iseed, n-j+1, a( jc ) )
               a( jc ) = sign( two, a( jc ) )
               jc = jc + n - j + 1
  190       CONTINUE
         END IF
*
*        Set the right hand side so that the largest value is BIGNUM.
*
         CALL dlarnv( 2, iseed, n, b )
         iy = idamax( n, b, 1 )
         bnorm = abs( b( iy ) )
         bscal = bignum / max( one, bnorm )
         CALL dscal( 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 dlarnv( 2, iseed, n, b )
         tscal = one / max( one, dble( n-1 ) )
         IF( upper ) THEN
            jc = 1
            DO 200 j = 1, n
               CALL dlarnv( 2, iseed, j-1, a( jc ) )
               CALL dscal( j-1, tscal, a( jc ), 1 )
               a( jc+j-1 ) = sign( one, dlarnd( 2, iseed ) )
               jc = jc + j
  200       CONTINUE
            a( n*( n+1 ) / 2 ) = smlnum
         ELSE
            jc = 1
            DO 210 j = 1, n
               CALL dlarnv( 2, iseed, n-j, a( jc+1 ) )
               CALL dscal( n-j, tscal, a( jc+1 ), 1 )
               a( jc ) = sign( one, dlarnd( 2, iseed ) )
               jc = jc + n - j + 1
  210       CONTINUE
            a( 1 ) = smlnum
         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 dlarnv( 2, iseed, n, b )
         IF( upper ) THEN
            jc = 1
            DO 220 j = 1, n
               CALL dlarnv( 2, iseed, j-1, a( jc ) )
               a( jc+j-1 ) = sign( one, dlarnd( 2, iseed ) )
               jc = jc + j
  220       CONTINUE
            a( n*( n+1 ) / 2 ) = smlnum
         ELSE
            jc = 1
            DO 230 j = 1, n
               CALL dlarnv( 2, iseed, n-j, a( jc+1 ) )
               a( jc ) = sign( one, dlarnd( 2, iseed ) )
               jc = jc + n - j + 1
  230       CONTINUE
            a( 1 ) = smlnum
         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
            jc = ( n-1 )*n / 2 + 1
            DO 250 j = n, 1, -1
               DO 240 i = 1, j - 1
                  a( jc+i-1 ) = zero
  240          CONTINUE
               IF( jcount.LE.2 ) THEN
                  a( jc+j-1 ) = smlnum
               ELSE
                  a( jc+j-1 ) = one
               END IF
               jcount = jcount + 1
               IF( jcount.GT.4 )
     $            jcount = 1
               jc = jc - j + 1
  250       CONTINUE
         ELSE
            jcount = 1
            jc = 1
            DO 270 j = 1, n
               DO 260 i = j + 1, n
                  a( jc+i-j ) = zero
  260          CONTINUE
               IF( jcount.LE.2 ) THEN
                  a( jc ) = smlnum
               ELSE
                  a( jc ) = one
               END IF
               jcount = jcount + 1
               IF( jcount.GT.4 )
     $            jcount = 1
               jc = jc + n - j + 1
  270       CONTINUE
         END IF
*
*        Set the right hand side alternately zero and small.
*
         IF( upper ) THEN
            b( 1 ) = zero
            DO 280 i = n, 2, -2
               b( i ) = zero
               b( i-1 ) = smlnum
  280       CONTINUE
         ELSE
            b( n ) = zero
            DO 290 i = 1, n - 1, 2
               b( i ) = zero
               b( i+1 ) = smlnum
  290       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, dble( n-1 ) )
         tscal = smlnum**texp
         CALL dlarnv( 2, iseed, n, b )
         IF( upper ) THEN
            jc = 1
            DO 310 j = 1, n
               DO 300 i = 1, j - 2
                  a( jc+i-1 ) = zero
  300          CONTINUE
               IF( j.GT.1 )
     $            a( jc+j-2 ) = -one
               a( jc+j-1 ) = tscal
               jc = jc + j
  310       CONTINUE
            b( n ) = one
         ELSE
            jc = 1
            DO 330 j = 1, n
               DO 320 i = j + 2, n
                  a( jc+i-j ) = zero
  320          CONTINUE
               IF( j.LT.n )
     $            a( jc+1 ) = -one
               a( jc ) = tscal
               jc = jc + n - j + 1
  330       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
            jc = 1
            DO 340 j = 1, n
               CALL dlarnv( 2, iseed, j, a( jc ) )
               IF( j.NE.iy ) THEN
                  a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
               ELSE
                  a( jc+j-1 ) = zero
               END IF
               jc = jc + j
  340       CONTINUE
         ELSE
            jc = 1
            DO 350 j = 1, n
               CALL dlarnv( 2, iseed, n-j+1, a( jc ) )
               IF( j.NE.iy ) THEN
                  a( jc ) = sign( two, a( jc ) )
               ELSE
                  a( jc ) = zero
               END IF
               jc = jc + n - j + 1
  350       CONTINUE
         END IF
         CALL dlarnv( 2, iseed, n, b )
         CALL dscal( 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 360 j = 1, n*( n+1 ) / 2
            a( j ) = zero
  360    CONTINUE
         texp = one
         IF( upper ) THEN
            jc = ( n-1 )*n / 2 + 1
            DO 370 j = n, 2, -2
               a( jc ) = -tscal / dble( n+1 )
               a( jc+j-1 ) = one
               b( j ) = texp*( one-ulp )
               jc = jc - j + 1
               a( jc ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
               a( jc+j-2 ) = one
               b( j-1 ) = texp*dble( n*n+n-1 )
               texp = texp*two
               jc = jc - j + 2
  370       CONTINUE
            b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
         ELSE
            jc = 1
            DO 380 j = 1, n - 1, 2
               a( jc+n-j ) = -tscal / dble( n+1 )
               a( jc ) = one
               b( j ) = texp*( one-ulp )
               jc = jc + n - j + 1
               a( jc+n-j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
               a( jc ) = one
               b( j+1 ) = texp*dble( n*n+n-1 )
               texp = texp*two
               jc = jc + n - j
  380       CONTINUE
            b( n ) = ( dble( n+1 ) / dble( 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
            jc = 1
            DO 390 j = 1, n
               CALL dlarnv( 2, iseed, j-1, a( jc ) )
               a( jc+j-1 ) = zero
               jc = jc + j
  390       CONTINUE
         ELSE
            jc = 1
            DO 400 j = 1, n
               IF( j.LT.n )
     $            CALL dlarnv( 2, iseed, n-j, a( jc+1 ) )
               a( jc ) = zero
               jc = jc + n - j + 1
  400       CONTINUE
         END IF
*
*        Set the right hand side so that the largest value is BIGNUM.
*
         CALL dlarnv( 2, iseed, n, b )
         iy = idamax( n, b, 1 )
         bnorm = abs( b( iy ) )
         bscal = bignum / max( one, bnorm )
         CALL dscal( 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.
*
         tleft = bignum / max( one, dble( n-1 ) )
         tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
         IF( upper ) THEN
            jc = 1
            DO 420 j = 1, n
               CALL dlarnv( 2, iseed, j, a( jc ) )
               DO 410 i = 1, j
                  a( jc+i-1 ) = sign( tleft, a( jc+i-1 ) ) +
     $                          tscal*a( jc+i-1 )
  410          CONTINUE
               jc = jc + j
  420       CONTINUE
         ELSE
            jc = 1
            DO 440 j = 1, n
               CALL dlarnv( 2, iseed, n-j+1, a( jc ) )
               DO 430 i = j, n
                  a( jc+i-j ) = sign( tleft, a( jc+i-j ) ) +
     $                          tscal*a( jc+i-j )
  430          CONTINUE
               jc = jc + n - j + 1
  440       CONTINUE
         END IF
         CALL dlarnv( 2, iseed, n, b )
         CALL dscal( n, two, b, 1 )
      END IF
*
*     Flip the matrix across its counter-diagonal if the transpose will
*     be used.
*
      IF( .NOT.lsame( trans, 'N' ) ) THEN
         IF( upper ) THEN
            jj = 1
            jr = n*( n+1 ) / 2
            DO 460 j = 1, n / 2
               jl = jj
               DO 450 i = j, n - j
                  t = a( jr-i+j )
                  a( jr-i+j ) = a( jl )
                  a( jl ) = t
                  jl = jl + i
  450          CONTINUE
               jj = jj + j + 1
               jr = jr - ( n-j+1 )
  460       CONTINUE
         ELSE
            jl = 1
            jj = n*( n+1 ) / 2
            DO 480 j = 1, n / 2
               jr = jj
               DO 470 i = j, n - j
                  t = a( jl+i-j )
                  a( jl+i-j ) = a( jr )
                  a( jr ) = t
                  jr = jr - i
  470          CONTINUE
               jl = jl + n - j + 1
               jj = jj - j - 1
  480       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DLATTP
*
      END