LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
zlattp.f
Go to the documentation of this file.
00001 *> \brief \b ZLATTP
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE ZLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK,
00012 *                          RWORK, INFO )
00013 * 
00014 *       .. Scalar Arguments ..
00015 *       CHARACTER          DIAG, TRANS, UPLO
00016 *       INTEGER            IMAT, INFO, N
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       INTEGER            ISEED( 4 )
00020 *       DOUBLE PRECISION   RWORK( * )
00021 *       COMPLEX*16         AP( * ), B( * ), WORK( * )
00022 *       ..
00023 *  
00024 *
00025 *> \par Purpose:
00026 *  =============
00027 *>
00028 *> \verbatim
00029 *>
00030 *> ZLATTP generates a triangular test matrix in packed storage.
00031 *> IMAT and UPLO uniquely specify the properties of the test matrix,
00032 *> which is returned in the array AP.
00033 *> \endverbatim
00034 *
00035 *  Arguments:
00036 *  ==========
00037 *
00038 *> \param[in] IMAT
00039 *> \verbatim
00040 *>          IMAT is INTEGER
00041 *>          An integer key describing which matrix to generate for this
00042 *>          path.
00043 *> \endverbatim
00044 *>
00045 *> \param[in] UPLO
00046 *> \verbatim
00047 *>          UPLO is CHARACTER*1
00048 *>          Specifies whether the matrix A will be upper or lower
00049 *>          triangular.
00050 *>          = 'U':  Upper triangular
00051 *>          = 'L':  Lower triangular
00052 *> \endverbatim
00053 *>
00054 *> \param[in] TRANS
00055 *> \verbatim
00056 *>          TRANS is CHARACTER*1
00057 *>          Specifies whether the matrix or its transpose will be used.
00058 *>          = 'N':  No transpose
00059 *>          = 'T':  Transpose
00060 *>          = 'C':  Conjugate transpose
00061 *> \endverbatim
00062 *>
00063 *> \param[out] DIAG
00064 *> \verbatim
00065 *>          DIAG is CHARACTER*1
00066 *>          Specifies whether or not the matrix A is unit triangular.
00067 *>          = 'N':  Non-unit triangular
00068 *>          = 'U':  Unit triangular
00069 *> \endverbatim
00070 *>
00071 *> \param[in,out] ISEED
00072 *> \verbatim
00073 *>          ISEED is INTEGER array, dimension (4)
00074 *>          The seed vector for the random number generator (used in
00075 *>          ZLATMS).  Modified on exit.
00076 *> \endverbatim
00077 *>
00078 *> \param[in] N
00079 *> \verbatim
00080 *>          N is INTEGER
00081 *>          The order of the matrix to be generated.
00082 *> \endverbatim
00083 *>
00084 *> \param[out] AP
00085 *> \verbatim
00086 *>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
00087 *>          The upper or lower triangular matrix A, packed columnwise in
00088 *>          a linear array.  The j-th column of A is stored in the array
00089 *>          AP as follows:
00090 *>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
00091 *>          if UPLO = 'L',
00092 *>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
00093 *> \endverbatim
00094 *>
00095 *> \param[out] B
00096 *> \verbatim
00097 *>          B is COMPLEX*16 array, dimension (N)
00098 *>          The right hand side vector, if IMAT > 10.
00099 *> \endverbatim
00100 *>
00101 *> \param[out] WORK
00102 *> \verbatim
00103 *>          WORK is COMPLEX*16 array, dimension (2*N)
00104 *> \endverbatim
00105 *>
00106 *> \param[out] RWORK
00107 *> \verbatim
00108 *>          RWORK is DOUBLE PRECISION array, dimension (N)
00109 *> \endverbatim
00110 *>
00111 *> \param[out] INFO
00112 *> \verbatim
00113 *>          INFO is INTEGER
00114 *>          = 0:  successful exit
00115 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
00116 *> \endverbatim
00117 *
00118 *  Authors:
00119 *  ========
00120 *
00121 *> \author Univ. of Tennessee 
00122 *> \author Univ. of California Berkeley 
00123 *> \author Univ. of Colorado Denver 
00124 *> \author NAG Ltd. 
00125 *
00126 *> \date November 2011
00127 *
00128 *> \ingroup complex16_lin
00129 *
00130 *  =====================================================================
00131       SUBROUTINE ZLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK,
00132      $                   RWORK, INFO )
00133 *
00134 *  -- LAPACK test routine (version 3.4.0) --
00135 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00136 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00137 *     November 2011
00138 *
00139 *     .. Scalar Arguments ..
00140       CHARACTER          DIAG, TRANS, UPLO
00141       INTEGER            IMAT, INFO, N
00142 *     ..
00143 *     .. Array Arguments ..
00144       INTEGER            ISEED( 4 )
00145       DOUBLE PRECISION   RWORK( * )
00146       COMPLEX*16         AP( * ), B( * ), WORK( * )
00147 *     ..
00148 *
00149 *  =====================================================================
00150 *
00151 *     .. Parameters ..
00152       DOUBLE PRECISION   ONE, TWO, ZERO
00153       PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
00154 *     ..
00155 *     .. Local Scalars ..
00156       LOGICAL            UPPER
00157       CHARACTER          DIST, PACKIT, TYPE
00158       CHARACTER*3        PATH
00159       INTEGER            I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
00160      $                   KL, KU, MODE
00161       DOUBLE PRECISION   ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, REXP,
00162      $                   SFAC, SMLNUM, T, TEXP, TLEFT, TSCAL, ULP, UNFL,
00163      $                   X, Y, Z
00164       COMPLEX*16         CTEMP, PLUS1, PLUS2, RA, RB, S, STAR1
00165 *     ..
00166 *     .. External Functions ..
00167       LOGICAL            LSAME
00168       INTEGER            IZAMAX
00169       DOUBLE PRECISION   DLAMCH
00170       COMPLEX*16         ZLARND
00171       EXTERNAL           LSAME, IZAMAX, DLAMCH, ZLARND
00172 *     ..
00173 *     .. External Subroutines ..
00174       EXTERNAL           DLABAD, DLARNV, ZDSCAL, ZLARNV, ZLATB4, ZLATMS,
00175      $                   ZROT, ZROTG
00176 *     ..
00177 *     .. Intrinsic Functions ..
00178       INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, MAX, SQRT
00179 *     ..
00180 *     .. Executable Statements ..
00181 *
00182       PATH( 1: 1 ) = 'Zomplex precision'
00183       PATH( 2: 3 ) = 'TP'
00184       UNFL = DLAMCH( 'Safe minimum' )
00185       ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
00186       SMLNUM = UNFL
00187       BIGNUM = ( ONE-ULP ) / SMLNUM
00188       CALL DLABAD( SMLNUM, BIGNUM )
00189       IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN
00190          DIAG = 'U'
00191       ELSE
00192          DIAG = 'N'
00193       END IF
00194       INFO = 0
00195 *
00196 *     Quick return if N.LE.0.
00197 *
00198       IF( N.LE.0 )
00199      $   RETURN
00200 *
00201 *     Call ZLATB4 to set parameters for CLATMS.
00202 *
00203       UPPER = LSAME( UPLO, 'U' )
00204       IF( UPPER ) THEN
00205          CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
00206      $                CNDNUM, DIST )
00207          PACKIT = 'C'
00208       ELSE
00209          CALL ZLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
00210      $                CNDNUM, DIST )
00211          PACKIT = 'R'
00212       END IF
00213 *
00214 *     IMAT <= 6:  Non-unit triangular matrix
00215 *
00216       IF( IMAT.LE.6 ) THEN
00217          CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM,
00218      $                ANORM, KL, KU, PACKIT, AP, N, WORK, INFO )
00219 *
00220 *     IMAT > 6:  Unit triangular matrix
00221 *     The diagonal is deliberately set to something other than 1.
00222 *
00223 *     IMAT = 7:  Matrix is the identity
00224 *
00225       ELSE IF( IMAT.EQ.7 ) THEN
00226          IF( UPPER ) THEN
00227             JC = 1
00228             DO 20 J = 1, N
00229                DO 10 I = 1, J - 1
00230                   AP( JC+I-1 ) = ZERO
00231    10          CONTINUE
00232                AP( JC+J-1 ) = J
00233                JC = JC + J
00234    20       CONTINUE
00235          ELSE
00236             JC = 1
00237             DO 40 J = 1, N
00238                AP( JC ) = J
00239                DO 30 I = J + 1, N
00240                   AP( JC+I-J ) = ZERO
00241    30          CONTINUE
00242                JC = JC + N - J + 1
00243    40       CONTINUE
00244          END IF
00245 *
00246 *     IMAT > 7:  Non-trivial unit triangular matrix
00247 *
00248 *     Generate a unit triangular matrix T with condition CNDNUM by
00249 *     forming a triangular matrix with known singular values and
00250 *     filling in the zero entries with Givens rotations.
00251 *
00252       ELSE IF( IMAT.LE.10 ) THEN
00253          IF( UPPER ) THEN
00254             JC = 0
00255             DO 60 J = 1, N
00256                DO 50 I = 1, J - 1
00257                   AP( JC+I ) = ZERO
00258    50          CONTINUE
00259                AP( JC+J ) = J
00260                JC = JC + J
00261    60       CONTINUE
00262          ELSE
00263             JC = 1
00264             DO 80 J = 1, N
00265                AP( JC ) = J
00266                DO 70 I = J + 1, N
00267                   AP( JC+I-J ) = ZERO
00268    70          CONTINUE
00269                JC = JC + N - J + 1
00270    80       CONTINUE
00271          END IF
00272 *
00273 *        Since the trace of a unit triangular matrix is 1, the product
00274 *        of its singular values must be 1.  Let s = sqrt(CNDNUM),
00275 *        x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
00276 *        The following triangular matrix has singular values s, 1, 1,
00277 *        ..., 1, 1/s:
00278 *
00279 *        1  y  y  y  ...  y  y  z
00280 *           1  0  0  ...  0  0  y
00281 *              1  0  ...  0  0  y
00282 *                 .  ...  .  .  .
00283 *                     .   .  .  .
00284 *                         1  0  y
00285 *                            1  y
00286 *                               1
00287 *
00288 *        To fill in the zeros, we first multiply by a matrix with small
00289 *        condition number of the form
00290 *
00291 *        1  0  0  0  0  ...
00292 *           1  +  *  0  0  ...
00293 *              1  +  0  0  0
00294 *                 1  +  *  0  0
00295 *                    1  +  0  0
00296 *                       ...
00297 *                          1  +  0
00298 *                             1  0
00299 *                                1
00300 *
00301 *        Each element marked with a '*' is formed by taking the product
00302 *        of the adjacent elements marked with '+'.  The '*'s can be
00303 *        chosen freely, and the '+'s are chosen so that the inverse of
00304 *        T will have elements of the same magnitude as T.  If the *'s in
00305 *        both T and inv(T) have small magnitude, T is well conditioned.
00306 *        The two offdiagonals of T are stored in WORK.
00307 *
00308 *        The product of these two matrices has the form
00309 *
00310 *        1  y  y  y  y  y  .  y  y  z
00311 *           1  +  *  0  0  .  0  0  y
00312 *              1  +  0  0  .  0  0  y
00313 *                 1  +  *  .  .  .  .
00314 *                    1  +  .  .  .  .
00315 *                       .  .  .  .  .
00316 *                          .  .  .  .
00317 *                             1  +  y
00318 *                                1  y
00319 *                                   1
00320 *
00321 *        Now we multiply by Givens rotations, using the fact that
00322 *
00323 *              [  c   s ] [  1   w ] [ -c  -s ] =  [  1  -w ]
00324 *              [ -s   c ] [  0   1 ] [  s  -c ]    [  0   1 ]
00325 *        and
00326 *              [ -c  -s ] [  1   0 ] [  c   s ] =  [  1   0 ]
00327 *              [  s  -c ] [  w   1 ] [ -s   c ]    [ -w   1 ]
00328 *
00329 *        where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
00330 *
00331          STAR1 = 0.25D0*ZLARND( 5, ISEED )
00332          SFAC = 0.5D0
00333          PLUS1 = SFAC*ZLARND( 5, ISEED )
00334          DO 90 J = 1, N, 2
00335             PLUS2 = STAR1 / PLUS1
00336             WORK( J ) = PLUS1
00337             WORK( N+J ) = STAR1
00338             IF( J+1.LE.N ) THEN
00339                WORK( J+1 ) = PLUS2
00340                WORK( N+J+1 ) = ZERO
00341                PLUS1 = STAR1 / PLUS2
00342                REXP = ZLARND( 2, ISEED )
00343                IF( REXP.LT.ZERO ) THEN
00344                   STAR1 = -SFAC**( ONE-REXP )*ZLARND( 5, ISEED )
00345                ELSE
00346                   STAR1 = SFAC**( ONE+REXP )*ZLARND( 5, ISEED )
00347                END IF
00348             END IF
00349    90    CONTINUE
00350 *
00351          X = SQRT( CNDNUM ) - ONE / SQRT( CNDNUM )
00352          IF( N.GT.2 ) THEN
00353             Y = SQRT( TWO / DBLE( N-2 ) )*X
00354          ELSE
00355             Y = ZERO
00356          END IF
00357          Z = X*X
00358 *
00359          IF( UPPER ) THEN
00360 *
00361 *           Set the upper triangle of A with a unit triangular matrix
00362 *           of known condition number.
00363 *
00364             JC = 1
00365             DO 100 J = 2, N
00366                AP( JC+1 ) = Y
00367                IF( J.GT.2 )
00368      $            AP( JC+J-1 ) = WORK( J-2 )
00369                IF( J.GT.3 )
00370      $            AP( JC+J-2 ) = WORK( N+J-3 )
00371                JC = JC + J
00372   100       CONTINUE
00373             JC = JC - N
00374             AP( JC+1 ) = Z
00375             DO 110 J = 2, N - 1
00376                AP( JC+J ) = Y
00377   110       CONTINUE
00378          ELSE
00379 *
00380 *           Set the lower triangle of A with a unit triangular matrix
00381 *           of known condition number.
00382 *
00383             DO 120 I = 2, N - 1
00384                AP( I ) = Y
00385   120       CONTINUE
00386             AP( N ) = Z
00387             JC = N + 1
00388             DO 130 J = 2, N - 1
00389                AP( JC+1 ) = WORK( J-1 )
00390                IF( J.LT.N-1 )
00391      $            AP( JC+2 ) = WORK( N+J-1 )
00392                AP( JC+N-J ) = Y
00393                JC = JC + N - J + 1
00394   130       CONTINUE
00395          END IF
00396 *
00397 *        Fill in the zeros using Givens rotations
00398 *
00399          IF( UPPER ) THEN
00400             JC = 1
00401             DO 150 J = 1, N - 1
00402                JCNEXT = JC + J
00403                RA = AP( JCNEXT+J-1 )
00404                RB = TWO
00405                CALL ZROTG( RA, RB, C, S )
00406 *
00407 *              Multiply by [ c  s; -conjg(s)  c] on the left.
00408 *
00409                IF( N.GT.J+1 ) THEN
00410                   JX = JCNEXT + J
00411                   DO 140 I = J + 2, N
00412                      CTEMP = C*AP( JX+J ) + S*AP( JX+J+1 )
00413                      AP( JX+J+1 ) = -DCONJG( S )*AP( JX+J ) +
00414      $                              C*AP( JX+J+1 )
00415                      AP( JX+J ) = CTEMP
00416                      JX = JX + I
00417   140             CONTINUE
00418                END IF
00419 *
00420 *              Multiply by [-c -s;  conjg(s) -c] on the right.
00421 *
00422                IF( J.GT.1 )
00423      $            CALL ZROT( J-1, AP( JCNEXT ), 1, AP( JC ), 1, -C, -S )
00424 *
00425 *              Negate A(J,J+1).
00426 *
00427                AP( JCNEXT+J-1 ) = -AP( JCNEXT+J-1 )
00428                JC = JCNEXT
00429   150       CONTINUE
00430          ELSE
00431             JC = 1
00432             DO 170 J = 1, N - 1
00433                JCNEXT = JC + N - J + 1
00434                RA = AP( JC+1 )
00435                RB = TWO
00436                CALL ZROTG( RA, RB, C, S )
00437                S = DCONJG( S )
00438 *
00439 *              Multiply by [ c -s;  conjg(s) c] on the right.
00440 *
00441                IF( N.GT.J+1 )
00442      $            CALL ZROT( N-J-1, AP( JCNEXT+1 ), 1, AP( JC+2 ), 1, C,
00443      $                       -S )
00444 *
00445 *              Multiply by [-c  s; -conjg(s) -c] on the left.
00446 *
00447                IF( J.GT.1 ) THEN
00448                   JX = 1
00449                   DO 160 I = 1, J - 1
00450                      CTEMP = -C*AP( JX+J-I ) + S*AP( JX+J-I+1 )
00451                      AP( JX+J-I+1 ) = -DCONJG( S )*AP( JX+J-I ) -
00452      $                                C*AP( JX+J-I+1 )
00453                      AP( JX+J-I ) = CTEMP
00454                      JX = JX + N - I + 1
00455   160             CONTINUE
00456                END IF
00457 *
00458 *              Negate A(J+1,J).
00459 *
00460                AP( JC+1 ) = -AP( JC+1 )
00461                JC = JCNEXT
00462   170       CONTINUE
00463          END IF
00464 *
00465 *     IMAT > 10:  Pathological test cases.  These triangular matrices
00466 *     are badly scaled or badly conditioned, so when used in solving a
00467 *     triangular system they may cause overflow in the solution vector.
00468 *
00469       ELSE IF( IMAT.EQ.11 ) THEN
00470 *
00471 *        Type 11:  Generate a triangular matrix with elements between
00472 *        -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
00473 *        Make the right hand side large so that it requires scaling.
00474 *
00475          IF( UPPER ) THEN
00476             JC = 1
00477             DO 180 J = 1, N
00478                CALL ZLARNV( 4, ISEED, J-1, AP( JC ) )
00479                AP( JC+J-1 ) = ZLARND( 5, ISEED )*TWO
00480                JC = JC + J
00481   180       CONTINUE
00482          ELSE
00483             JC = 1
00484             DO 190 J = 1, N
00485                IF( J.LT.N )
00486      $            CALL ZLARNV( 4, ISEED, N-J, AP( JC+1 ) )
00487                AP( JC ) = ZLARND( 5, ISEED )*TWO
00488                JC = JC + N - J + 1
00489   190       CONTINUE
00490          END IF
00491 *
00492 *        Set the right hand side so that the largest value is BIGNUM.
00493 *
00494          CALL ZLARNV( 2, ISEED, N, B )
00495          IY = IZAMAX( N, B, 1 )
00496          BNORM = ABS( B( IY ) )
00497          BSCAL = BIGNUM / MAX( ONE, BNORM )
00498          CALL ZDSCAL( N, BSCAL, B, 1 )
00499 *
00500       ELSE IF( IMAT.EQ.12 ) THEN
00501 *
00502 *        Type 12:  Make the first diagonal element in the solve small to
00503 *        cause immediate overflow when dividing by T(j,j).
00504 *        In type 12, the offdiagonal elements are small (CNORM(j) < 1).
00505 *
00506          CALL ZLARNV( 2, ISEED, N, B )
00507          TSCAL = ONE / MAX( ONE, DBLE( N-1 ) )
00508          IF( UPPER ) THEN
00509             JC = 1
00510             DO 200 J = 1, N
00511                CALL ZLARNV( 4, ISEED, J-1, AP( JC ) )
00512                CALL ZDSCAL( J-1, TSCAL, AP( JC ), 1 )
00513                AP( JC+J-1 ) = ZLARND( 5, ISEED )
00514                JC = JC + J
00515   200       CONTINUE
00516             AP( N*( N+1 ) / 2 ) = SMLNUM*AP( N*( N+1 ) / 2 )
00517          ELSE
00518             JC = 1
00519             DO 210 J = 1, N
00520                CALL ZLARNV( 2, ISEED, N-J, AP( JC+1 ) )
00521                CALL ZDSCAL( N-J, TSCAL, AP( JC+1 ), 1 )
00522                AP( JC ) = ZLARND( 5, ISEED )
00523                JC = JC + N - J + 1
00524   210       CONTINUE
00525             AP( 1 ) = SMLNUM*AP( 1 )
00526          END IF
00527 *
00528       ELSE IF( IMAT.EQ.13 ) THEN
00529 *
00530 *        Type 13:  Make the first diagonal element in the solve small to
00531 *        cause immediate overflow when dividing by T(j,j).
00532 *        In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
00533 *
00534          CALL ZLARNV( 2, ISEED, N, B )
00535          IF( UPPER ) THEN
00536             JC = 1
00537             DO 220 J = 1, N
00538                CALL ZLARNV( 4, ISEED, J-1, AP( JC ) )
00539                AP( JC+J-1 ) = ZLARND( 5, ISEED )
00540                JC = JC + J
00541   220       CONTINUE
00542             AP( N*( N+1 ) / 2 ) = SMLNUM*AP( N*( N+1 ) / 2 )
00543          ELSE
00544             JC = 1
00545             DO 230 J = 1, N
00546                CALL ZLARNV( 4, ISEED, N-J, AP( JC+1 ) )
00547                AP( JC ) = ZLARND( 5, ISEED )
00548                JC = JC + N - J + 1
00549   230       CONTINUE
00550             AP( 1 ) = SMLNUM*AP( 1 )
00551          END IF
00552 *
00553       ELSE IF( IMAT.EQ.14 ) THEN
00554 *
00555 *        Type 14:  T is diagonal with small numbers on the diagonal to
00556 *        make the growth factor underflow, but a small right hand side
00557 *        chosen so that the solution does not overflow.
00558 *
00559          IF( UPPER ) THEN
00560             JCOUNT = 1
00561             JC = ( N-1 )*N / 2 + 1
00562             DO 250 J = N, 1, -1
00563                DO 240 I = 1, J - 1
00564                   AP( JC+I-1 ) = ZERO
00565   240          CONTINUE
00566                IF( JCOUNT.LE.2 ) THEN
00567                   AP( JC+J-1 ) = SMLNUM*ZLARND( 5, ISEED )
00568                ELSE
00569                   AP( JC+J-1 ) = ZLARND( 5, ISEED )
00570                END IF
00571                JCOUNT = JCOUNT + 1
00572                IF( JCOUNT.GT.4 )
00573      $            JCOUNT = 1
00574                JC = JC - J + 1
00575   250       CONTINUE
00576          ELSE
00577             JCOUNT = 1
00578             JC = 1
00579             DO 270 J = 1, N
00580                DO 260 I = J + 1, N
00581                   AP( JC+I-J ) = ZERO
00582   260          CONTINUE
00583                IF( JCOUNT.LE.2 ) THEN
00584                   AP( JC ) = SMLNUM*ZLARND( 5, ISEED )
00585                ELSE
00586                   AP( JC ) = ZLARND( 5, ISEED )
00587                END IF
00588                JCOUNT = JCOUNT + 1
00589                IF( JCOUNT.GT.4 )
00590      $            JCOUNT = 1
00591                JC = JC + N - J + 1
00592   270       CONTINUE
00593          END IF
00594 *
00595 *        Set the right hand side alternately zero and small.
00596 *
00597          IF( UPPER ) THEN
00598             B( 1 ) = ZERO
00599             DO 280 I = N, 2, -2
00600                B( I ) = ZERO
00601                B( I-1 ) = SMLNUM*ZLARND( 5, ISEED )
00602   280       CONTINUE
00603          ELSE
00604             B( N ) = ZERO
00605             DO 290 I = 1, N - 1, 2
00606                B( I ) = ZERO
00607                B( I+1 ) = SMLNUM*ZLARND( 5, ISEED )
00608   290       CONTINUE
00609          END IF
00610 *
00611       ELSE IF( IMAT.EQ.15 ) THEN
00612 *
00613 *        Type 15:  Make the diagonal elements small to cause gradual
00614 *        overflow when dividing by T(j,j).  To control the amount of
00615 *        scaling needed, the matrix is bidiagonal.
00616 *
00617          TEXP = ONE / MAX( ONE, DBLE( N-1 ) )
00618          TSCAL = SMLNUM**TEXP
00619          CALL ZLARNV( 4, ISEED, N, B )
00620          IF( UPPER ) THEN
00621             JC = 1
00622             DO 310 J = 1, N
00623                DO 300 I = 1, J - 2
00624                   AP( JC+I-1 ) = ZERO
00625   300          CONTINUE
00626                IF( J.GT.1 )
00627      $            AP( JC+J-2 ) = DCMPLX( -ONE, -ONE )
00628                AP( JC+J-1 ) = TSCAL*ZLARND( 5, ISEED )
00629                JC = JC + J
00630   310       CONTINUE
00631             B( N ) = DCMPLX( ONE, ONE )
00632          ELSE
00633             JC = 1
00634             DO 330 J = 1, N
00635                DO 320 I = J + 2, N
00636                   AP( JC+I-J ) = ZERO
00637   320          CONTINUE
00638                IF( J.LT.N )
00639      $            AP( JC+1 ) = DCMPLX( -ONE, -ONE )
00640                AP( JC ) = TSCAL*ZLARND( 5, ISEED )
00641                JC = JC + N - J + 1
00642   330       CONTINUE
00643             B( 1 ) = DCMPLX( ONE, ONE )
00644          END IF
00645 *
00646       ELSE IF( IMAT.EQ.16 ) THEN
00647 *
00648 *        Type 16:  One zero diagonal element.
00649 *
00650          IY = N / 2 + 1
00651          IF( UPPER ) THEN
00652             JC = 1
00653             DO 340 J = 1, N
00654                CALL ZLARNV( 4, ISEED, J, AP( JC ) )
00655                IF( J.NE.IY ) THEN
00656                   AP( JC+J-1 ) = ZLARND( 5, ISEED )*TWO
00657                ELSE
00658                   AP( JC+J-1 ) = ZERO
00659                END IF
00660                JC = JC + J
00661   340       CONTINUE
00662          ELSE
00663             JC = 1
00664             DO 350 J = 1, N
00665                CALL ZLARNV( 4, ISEED, N-J+1, AP( JC ) )
00666                IF( J.NE.IY ) THEN
00667                   AP( JC ) = ZLARND( 5, ISEED )*TWO
00668                ELSE
00669                   AP( JC ) = ZERO
00670                END IF
00671                JC = JC + N - J + 1
00672   350       CONTINUE
00673          END IF
00674          CALL ZLARNV( 2, ISEED, N, B )
00675          CALL ZDSCAL( N, TWO, B, 1 )
00676 *
00677       ELSE IF( IMAT.EQ.17 ) THEN
00678 *
00679 *        Type 17:  Make the offdiagonal elements large to cause overflow
00680 *        when adding a column of T.  In the non-transposed case, the
00681 *        matrix is constructed to cause overflow when adding a column in
00682 *        every other step.
00683 *
00684          TSCAL = UNFL / ULP
00685          TSCAL = ( ONE-ULP ) / TSCAL
00686          DO 360 J = 1, N*( N+1 ) / 2
00687             AP( J ) = ZERO
00688   360    CONTINUE
00689          TEXP = ONE
00690          IF( UPPER ) THEN
00691             JC = ( N-1 )*N / 2 + 1
00692             DO 370 J = N, 2, -2
00693                AP( JC ) = -TSCAL / DBLE( N+1 )
00694                AP( JC+J-1 ) = ONE
00695                B( J ) = TEXP*( ONE-ULP )
00696                JC = JC - J + 1
00697                AP( JC ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 )
00698                AP( JC+J-2 ) = ONE
00699                B( J-1 ) = TEXP*DBLE( N*N+N-1 )
00700                TEXP = TEXP*TWO
00701                JC = JC - J + 2
00702   370       CONTINUE
00703             B( 1 ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL
00704          ELSE
00705             JC = 1
00706             DO 380 J = 1, N - 1, 2
00707                AP( JC+N-J ) = -TSCAL / DBLE( N+1 )
00708                AP( JC ) = ONE
00709                B( J ) = TEXP*( ONE-ULP )
00710                JC = JC + N - J + 1
00711                AP( JC+N-J-1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 )
00712                AP( JC ) = ONE
00713                B( J+1 ) = TEXP*DBLE( N*N+N-1 )
00714                TEXP = TEXP*TWO
00715                JC = JC + N - J
00716   380       CONTINUE
00717             B( N ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL
00718          END IF
00719 *
00720       ELSE IF( IMAT.EQ.18 ) THEN
00721 *
00722 *        Type 18:  Generate a unit triangular matrix with elements
00723 *        between -1 and 1, and make the right hand side large so that it
00724 *        requires scaling.
00725 *
00726          IF( UPPER ) THEN
00727             JC = 1
00728             DO 390 J = 1, N
00729                CALL ZLARNV( 4, ISEED, J-1, AP( JC ) )
00730                AP( JC+J-1 ) = ZERO
00731                JC = JC + J
00732   390       CONTINUE
00733          ELSE
00734             JC = 1
00735             DO 400 J = 1, N
00736                IF( J.LT.N )
00737      $            CALL ZLARNV( 4, ISEED, N-J, AP( JC+1 ) )
00738                AP( JC ) = ZERO
00739                JC = JC + N - J + 1
00740   400       CONTINUE
00741          END IF
00742 *
00743 *        Set the right hand side so that the largest value is BIGNUM.
00744 *
00745          CALL ZLARNV( 2, ISEED, N, B )
00746          IY = IZAMAX( N, B, 1 )
00747          BNORM = ABS( B( IY ) )
00748          BSCAL = BIGNUM / MAX( ONE, BNORM )
00749          CALL ZDSCAL( N, BSCAL, B, 1 )
00750 *
00751       ELSE IF( IMAT.EQ.19 ) THEN
00752 *
00753 *        Type 19:  Generate a triangular matrix with elements between
00754 *        BIGNUM/(n-1) and BIGNUM so that at least one of the column
00755 *        norms will exceed BIGNUM.
00756 *        1/3/91:  ZLATPS no longer can handle this case
00757 *
00758          TLEFT = BIGNUM / MAX( ONE, DBLE( N-1 ) )
00759          TSCAL = BIGNUM*( DBLE( N-1 ) / MAX( ONE, DBLE( N ) ) )
00760          IF( UPPER ) THEN
00761             JC = 1
00762             DO 420 J = 1, N
00763                CALL ZLARNV( 5, ISEED, J, AP( JC ) )
00764                CALL DLARNV( 1, ISEED, J, RWORK )
00765                DO 410 I = 1, J
00766                   AP( JC+I-1 ) = AP( JC+I-1 )*( TLEFT+RWORK( I )*TSCAL )
00767   410          CONTINUE
00768                JC = JC + J
00769   420       CONTINUE
00770          ELSE
00771             JC = 1
00772             DO 440 J = 1, N
00773                CALL ZLARNV( 5, ISEED, N-J+1, AP( JC ) )
00774                CALL DLARNV( 1, ISEED, N-J+1, RWORK )
00775                DO 430 I = J, N
00776                   AP( JC+I-J ) = AP( JC+I-J )*
00777      $                           ( TLEFT+RWORK( I-J+1 )*TSCAL )
00778   430          CONTINUE
00779                JC = JC + N - J + 1
00780   440       CONTINUE
00781          END IF
00782          CALL ZLARNV( 2, ISEED, N, B )
00783          CALL ZDSCAL( N, TWO, B, 1 )
00784       END IF
00785 *
00786 *     Flip the matrix across its counter-diagonal if the transpose will
00787 *     be used.
00788 *
00789       IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
00790          IF( UPPER ) THEN
00791             JJ = 1
00792             JR = N*( N+1 ) / 2
00793             DO 460 J = 1, N / 2
00794                JL = JJ
00795                DO 450 I = J, N - J
00796                   T = AP( JR-I+J )
00797                   AP( JR-I+J ) = AP( JL )
00798                   AP( JL ) = T
00799                   JL = JL + I
00800   450          CONTINUE
00801                JJ = JJ + J + 1
00802                JR = JR - ( N-J+1 )
00803   460       CONTINUE
00804          ELSE
00805             JL = 1
00806             JJ = N*( N+1 ) / 2
00807             DO 480 J = 1, N / 2
00808                JR = JJ
00809                DO 470 I = J, N - J
00810                   T = AP( JL+I-J )
00811                   AP( JL+I-J ) = AP( JR )
00812                   AP( JR ) = T
00813                   JR = JR - I
00814   470          CONTINUE
00815                JL = JL + N - J + 1
00816                JJ = JJ - J - 1
00817   480       CONTINUE
00818          END IF
00819       END IF
00820 *
00821       RETURN
00822 *
00823 *     End of ZLATTP
00824 *
00825       END
 All Files Functions