LAPACK 3.3.1 Linear Algebra PACKage

# dlatme.f

Go to the documentation of this file.
```00001       SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
00002      \$  RSIGN,
00003      \$                   UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
00004      \$  A,
00005      \$                   LDA, WORK, INFO )
00006 *
00007 *  -- LAPACK test routine (version 3.1) --
00008 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00009 *     June 2010
00010 *
00011 *     .. Scalar Arguments ..
00012       CHARACTER          DIST, RSIGN, SIM, UPPER
00013       INTEGER            INFO, KL, KU, LDA, MODE, MODES, N
00014       DOUBLE PRECISION   ANORM, COND, CONDS, DMAX
00015 *     ..
00016 *     .. Array Arguments ..
00017       CHARACTER          EI( * )
00018       INTEGER            ISEED( 4 )
00019       DOUBLE PRECISION   A( LDA, * ), D( * ), DS( * ), WORK( * )
00020 *     ..
00021 *
00022 *  Purpose
00023 *  =======
00024 *
00025 *     DLATME generates random non-symmetric square matrices with
00026 *     specified eigenvalues for testing LAPACK programs.
00027 *
00028 *     DLATME operates by applying the following sequence of
00029 *     operations:
00030 *
00031 *     1. Set the diagonal to D, where D may be input or
00032 *          computed according to MODE, COND, DMAX, and RSIGN
00033 *          as described below.
00034 *
00035 *     2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R',
00036 *          or MODE=5), certain pairs of adjacent elements of D are
00037 *          interpreted as the real and complex parts of a complex
00038 *          conjugate pair; A thus becomes block diagonal, with 1x1
00039 *          and 2x2 blocks.
00040 *
00041 *     3. If UPPER='T', the upper triangle of A is set to random values
00042 *          out of distribution DIST.
00043 *
00044 *     4. If SIM='T', A is multiplied on the left by a random matrix
00045 *          X, whose singular values are specified by DS, MODES, and
00046 *          CONDS, and on the right by X inverse.
00047 *
00048 *     5. If KL < N-1, the lower bandwidth is reduced to KL using
00049 *          Householder transformations.  If KU < N-1, the upper
00050 *          bandwidth is reduced to KU.
00051 *
00052 *     6. If ANORM is not negative, the matrix is scaled to have
00053 *          maximum-element-norm ANORM.
00054 *
00055 *     (Note: since the matrix cannot be reduced beyond Hessenberg form,
00056 *      no packing options are available.)
00057 *
00058 *  Arguments
00059 *  =========
00060 *
00061 *  N        (input) INTEGER
00062 *           The number of columns (or rows) of A. Not modified.
00063 *
00064 *  DIST     (input) CHARACTER*1
00065 *           On entry, DIST specifies the type of distribution to be used
00066 *           to generate the random eigen-/singular values, and for the
00067 *           upper triangle (see UPPER).
00068 *           'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )
00069 *           'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
00070 *           'N' => NORMAL( 0, 1 )   ( 'N' for normal )
00071 *           Not modified.
00072 *
00073 *  ISEED    (input/output) INTEGER array, dimension ( 4 )
00074 *           On entry ISEED specifies the seed of the random number
00075 *           generator. They should lie between 0 and 4095 inclusive,
00076 *           and ISEED(4) should be odd. The random number generator
00077 *           uses a linear congruential sequence limited to small
00078 *           integers, and so should produce machine independent
00079 *           random numbers. The values of ISEED are changed on
00080 *           exit, and can be used in the next call to DLATME
00081 *           to continue the same random number sequence.
00082 *           Changed on exit.
00083 *
00084 *  D        (input/output) DOUBLE PRECISION array, dimension ( N )
00085 *           This array is used to specify the eigenvalues of A.  If
00086 *           MODE=0, then D is assumed to contain the eigenvalues (but
00087 *           see the description of EI), otherwise they will be
00088 *           computed according to MODE, COND, DMAX, and RSIGN and
00089 *           placed in D.
00090 *           Modified if MODE is nonzero.
00091 *
00092 *  MODE     (input) INTEGER
00093 *           On entry this describes how the eigenvalues are to
00094 *           be specified:
00095 *           MODE = 0 means use D (with EI) as input
00096 *           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
00097 *           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
00098 *           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
00099 *           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
00100 *           MODE = 5 sets D to random numbers in the range
00101 *                    ( 1/COND , 1 ) such that their logarithms
00102 *                    are uniformly distributed.  Each odd-even pair
00103 *                    of elements will be either used as two real
00104 *                    eigenvalues or as the real and imaginary part
00105 *                    of a complex conjugate pair of eigenvalues;
00106 *                    the choice of which is done is random, with
00107 *                    50-50 probability, for each pair.
00108 *           MODE = 6 set D to random numbers from same distribution
00109 *                    as the rest of the matrix.
00110 *           MODE < 0 has the same meaning as ABS(MODE), except that
00111 *              the order of the elements of D is reversed.
00112 *           Thus if MODE is between 1 and 4, D has entries ranging
00113 *              from 1 to 1/COND, if between -1 and -4, D has entries
00114 *              ranging from 1/COND to 1,
00115 *           Not modified.
00116 *
00117 *  COND     (input) DOUBLE PRECISION
00118 *           On entry, this is used as described under MODE above.
00119 *           If used, it must be >= 1. Not modified.
00120 *
00121 *  DMAX     (input) DOUBLE PRECISION
00122 *           If MODE is neither -6, 0 nor 6, the contents of D, as
00123 *           computed according to MODE and COND, will be scaled by
00124 *           DMAX / max(abs(D(i))).  Note that DMAX need not be
00125 *           positive: if DMAX is negative (or zero), D will be
00126 *           scaled by a negative number (or zero).
00127 *           Not modified.
00128 *
00129 *  EI       (input) CHARACTER*1 array, dimension ( N )
00130 *           If MODE is 0, and EI(1) is not ' ' (space character),
00131 *           this array specifies which elements of D (on input) are
00132 *           real eigenvalues and which are the real and imaginary parts
00133 *           of a complex conjugate pair of eigenvalues.  The elements
00134 *           of EI may then only have the values 'R' and 'I'.  If
00135 *           EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is
00136 *           CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex
00137 *           conjugate thereof.  If EI(j)=EI(j+1)='R', then the j-th
00138 *           eigenvalue is D(j) (i.e., real).  EI(1) may not be 'I',
00139 *           nor may two adjacent elements of EI both have the value 'I'.
00140 *           If MODE is not 0, then EI is ignored.  If MODE is 0 and
00141 *           EI(1)=' ', then the eigenvalues will all be real.
00142 *           Not modified.
00143 *
00144 *  RSIGN    (input) CHARACTER*1
00145 *           If MODE is not 0, 6, or -6, and RSIGN='T', then the
00146 *           elements of D, as computed according to MODE and COND, will
00147 *           be multiplied by a random sign (+1 or -1).  If RSIGN='F',
00148 *           they will not be.  RSIGN may only have the values 'T' or
00149 *           'F'.
00150 *           Not modified.
00151 *
00152 *  UPPER    (input) CHARACTER*1
00153 *           If UPPER='T', then the elements of A above the diagonal
00154 *           (and above the 2x2 diagonal blocks, if A has complex
00155 *           eigenvalues) will be set to random numbers out of DIST.
00156 *           If UPPER='F', they will not.  UPPER may only have the
00157 *           values 'T' or 'F'.
00158 *           Not modified.
00159 *
00160 *  SIM      (input) CHARACTER*1
00161 *           If SIM='T', then A will be operated on by a "similarity
00162 *           transform", i.e., multiplied on the left by a matrix X and
00163 *           on the right by X inverse.  X = U S V, where U and V are
00164 *           random unitary matrices and S is a (diagonal) matrix of
00165 *           singular values specified by DS, MODES, and CONDS.  If
00166 *           SIM='F', then A will not be transformed.
00167 *           Not modified.
00168 *
00169 *  DS       (input/output) DOUBLE PRECISION array, dimension ( N )
00170 *           This array is used to specify the singular values of X,
00171 *           in the same way that D specifies the eigenvalues of A.
00172 *           If MODE=0, the DS contains the singular values, which
00173 *           may not be zero.
00174 *           Modified if MODE is nonzero.
00175 *
00176 *  MODES    (input) INTEGER
00177 *
00178 *  CONDS    (input) DOUBLE PRECISION
00179 *           Same as MODE and COND, but for specifying the diagonal
00180 *           of S.  MODES=-6 and +6 are not allowed (since they would
00181 *           result in randomly ill-conditioned eigenvalues.)
00182 *
00183 *  KL       (input) INTEGER
00184 *           This specifies the lower bandwidth of the  matrix.  KL=1
00185 *           specifies upper Hessenberg form.  If KL is at least N-1,
00186 *           then A will have full lower bandwidth.  KL must be at
00187 *           least 1.
00188 *           Not modified.
00189 *
00190 *  KU       (input) INTEGER
00191 *           This specifies the upper bandwidth of the  matrix.  KU=1
00192 *           specifies lower Hessenberg form.  If KU is at least N-1,
00193 *           then A will have full upper bandwidth; if KU and KL
00194 *           are both at least N-1, then A will be dense.  Only one of
00195 *           KU and KL may be less than N-1.  KU must be at least 1.
00196 *           Not modified.
00197 *
00198 *  ANORM    (input) DOUBLE PRECISION
00199 *           If ANORM is not negative, then A will be scaled by a non-
00200 *           negative real number to make the maximum-element-norm of A
00201 *           to be ANORM.
00202 *           Not modified.
00203 *
00204 *  A        (output) DOUBLE PRECISION array, dimension ( LDA, N )
00205 *           On exit A is the desired test matrix.
00206 *           Modified.
00207 *
00208 *  LDA      (input) INTEGER
00209 *           LDA specifies the first dimension of A as declared in the
00210 *           calling program.  LDA must be at least N.
00211 *           Not modified.
00212 *
00213 *  WORK     (workspace) DOUBLE PRECISION array, dimension ( 3*N )
00214 *           Workspace.
00215 *           Modified.
00216 *
00217 *  INFO     (output) INTEGER
00218 *           Error code.  On exit, INFO will be set to one of the
00219 *           following values:
00220 *             0 => normal return
00221 *            -1 => N negative
00222 *            -2 => DIST illegal string
00223 *            -5 => MODE not in range -6 to 6
00224 *            -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
00225 *            -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or
00226 *                  two adjacent elements of EI are 'I'.
00227 *            -9 => RSIGN is not 'T' or 'F'
00228 *           -10 => UPPER is not 'T' or 'F'
00229 *           -11 => SIM   is not 'T' or 'F'
00230 *           -12 => MODES=0 and DS has a zero singular value.
00231 *           -13 => MODES is not in the range -5 to 5.
00232 *           -14 => MODES is nonzero and CONDS is less than 1.
00233 *           -15 => KL is less than 1.
00234 *           -16 => KU is less than 1, or KL and KU are both less than
00235 *                  N-1.
00236 *           -19 => LDA is less than N.
00237 *            1  => Error return from DLATM1 (computing D)
00238 *            2  => Cannot scale to DMAX (max. eigenvalue is 0)
00239 *            3  => Error return from DLATM1 (computing DS)
00240 *            4  => Error return from DLARGE
00241 *            5  => Zero singular value from DLATM1.
00242 *
00243 *  =====================================================================
00244 *
00245 *     .. Parameters ..
00246       DOUBLE PRECISION   ZERO
00247       PARAMETER          ( ZERO = 0.0D0 )
00248       DOUBLE PRECISION   ONE
00249       PARAMETER          ( ONE = 1.0D0 )
00250       DOUBLE PRECISION   HALF
00251       PARAMETER          ( HALF = 1.0D0 / 2.0D0 )
00252 *     ..
00253 *     .. Local Scalars ..
00255       INTEGER            I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
00256      \$                   ISIM, IUPPER, J, JC, JCR, JR
00257       DOUBLE PRECISION   ALPHA, TAU, TEMP, XNORMS
00258 *     ..
00259 *     .. Local Arrays ..
00260       DOUBLE PRECISION   TEMPA( 1 )
00261 *     ..
00262 *     .. External Functions ..
00263       LOGICAL            LSAME
00264       DOUBLE PRECISION   DLANGE, DLARAN
00265       EXTERNAL           LSAME, DLANGE, DLARAN
00266 *     ..
00267 *     .. External Subroutines ..
00268       EXTERNAL           DCOPY, DGEMV, DGER, DLARFG, DLARGE, DLARNV,
00269      \$                   DLASET, DLATM1, DSCAL, XERBLA
00270 *     ..
00271 *     .. Intrinsic Functions ..
00272       INTRINSIC          ABS, MAX, MOD
00273 *     ..
00274 *     .. Executable Statements ..
00275 *
00276 *     1)      Decode and Test the input parameters.
00277 *             Initialize flags & seed.
00278 *
00279       INFO = 0
00280 *
00281 *     Quick return if possible
00282 *
00283       IF( N.EQ.0 )
00284      \$   RETURN
00285 *
00286 *     Decode DIST
00287 *
00288       IF( LSAME( DIST, 'U' ) ) THEN
00289          IDIST = 1
00290       ELSE IF( LSAME( DIST, 'S' ) ) THEN
00291          IDIST = 2
00292       ELSE IF( LSAME( DIST, 'N' ) ) THEN
00293          IDIST = 3
00294       ELSE
00295          IDIST = -1
00296       END IF
00297 *
00298 *     Check EI
00299 *
00300       USEEI = .TRUE.
00301       BADEI = .FALSE.
00302       IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN
00303          USEEI = .FALSE.
00304       ELSE
00305          IF( LSAME( EI( 1 ), 'R' ) ) THEN
00306             DO 10 J = 2, N
00307                IF( LSAME( EI( J ), 'I' ) ) THEN
00308                   IF( LSAME( EI( J-1 ), 'I' ) )
00309      \$               BADEI = .TRUE.
00310                ELSE
00311                   IF( .NOT.LSAME( EI( J ), 'R' ) )
00312      \$               BADEI = .TRUE.
00313                END IF
00314    10       CONTINUE
00315          ELSE
00316             BADEI = .TRUE.
00317          END IF
00318       END IF
00319 *
00320 *     Decode RSIGN
00321 *
00322       IF( LSAME( RSIGN, 'T' ) ) THEN
00323          IRSIGN = 1
00324       ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
00325          IRSIGN = 0
00326       ELSE
00327          IRSIGN = -1
00328       END IF
00329 *
00330 *     Decode UPPER
00331 *
00332       IF( LSAME( UPPER, 'T' ) ) THEN
00333          IUPPER = 1
00334       ELSE IF( LSAME( UPPER, 'F' ) ) THEN
00335          IUPPER = 0
00336       ELSE
00337          IUPPER = -1
00338       END IF
00339 *
00340 *     Decode SIM
00341 *
00342       IF( LSAME( SIM, 'T' ) ) THEN
00343          ISIM = 1
00344       ELSE IF( LSAME( SIM, 'F' ) ) THEN
00345          ISIM = 0
00346       ELSE
00347          ISIM = -1
00348       END IF
00349 *
00350 *     Check DS, if MODES=0 and ISIM=1
00351 *
00352       BADS = .FALSE.
00353       IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
00354          DO 20 J = 1, N
00355             IF( DS( J ).EQ.ZERO )
00356      \$         BADS = .TRUE.
00357    20    CONTINUE
00358       END IF
00359 *
00360 *     Set INFO if an error
00361 *
00362       IF( N.LT.0 ) THEN
00363          INFO = -1
00364       ELSE IF( IDIST.EQ.-1 ) THEN
00365          INFO = -2
00366       ELSE IF( ABS( MODE ).GT.6 ) THEN
00367          INFO = -5
00368       ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
00369      \$          THEN
00370          INFO = -6
00371       ELSE IF( BADEI ) THEN
00372          INFO = -8
00373       ELSE IF( IRSIGN.EQ.-1 ) THEN
00374          INFO = -9
00375       ELSE IF( IUPPER.EQ.-1 ) THEN
00376          INFO = -10
00377       ELSE IF( ISIM.EQ.-1 ) THEN
00378          INFO = -11
00379       ELSE IF( BADS ) THEN
00380          INFO = -12
00381       ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
00382          INFO = -13
00383       ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
00384          INFO = -14
00385       ELSE IF( KL.LT.1 ) THEN
00386          INFO = -15
00387       ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
00388          INFO = -16
00389       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
00390          INFO = -19
00391       END IF
00392 *
00393       IF( INFO.NE.0 ) THEN
00394          CALL XERBLA( 'DLATME', -INFO )
00395          RETURN
00396       END IF
00397 *
00398 *     Initialize random number generator
00399 *
00400       DO 30 I = 1, 4
00401          ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
00402    30 CONTINUE
00403 *
00404       IF( MOD( ISEED( 4 ), 2 ).NE.1 )
00405      \$   ISEED( 4 ) = ISEED( 4 ) + 1
00406 *
00407 *     2)      Set up diagonal of A
00408 *
00409 *             Compute D according to COND and MODE
00410 *
00411       CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
00412       IF( IINFO.NE.0 ) THEN
00413          INFO = 1
00414          RETURN
00415       END IF
00416       IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
00417 *
00418 *        Scale by DMAX
00419 *
00420          TEMP = ABS( D( 1 ) )
00421          DO 40 I = 2, N
00422             TEMP = MAX( TEMP, ABS( D( I ) ) )
00423    40    CONTINUE
00424 *
00425          IF( TEMP.GT.ZERO ) THEN
00426             ALPHA = DMAX / TEMP
00427          ELSE IF( DMAX.NE.ZERO ) THEN
00428             INFO = 2
00429             RETURN
00430          ELSE
00431             ALPHA = ZERO
00432          END IF
00433 *
00434          CALL DSCAL( N, ALPHA, D, 1 )
00435 *
00436       END IF
00437 *
00438       CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
00439       CALL DCOPY( N, D, 1, A, LDA+1 )
00440 *
00441 *     Set up complex conjugate pairs
00442 *
00443       IF( MODE.EQ.0 ) THEN
00444          IF( USEEI ) THEN
00445             DO 50 J = 2, N
00446                IF( LSAME( EI( J ), 'I' ) ) THEN
00447                   A( J-1, J ) = A( J, J )
00448                   A( J, J-1 ) = -A( J, J )
00449                   A( J, J ) = A( J-1, J-1 )
00450                END IF
00451    50       CONTINUE
00452          END IF
00453 *
00454       ELSE IF( ABS( MODE ).EQ.5 ) THEN
00455 *
00456          DO 60 J = 2, N, 2
00457             IF( DLARAN( ISEED ).GT.HALF ) THEN
00458                A( J-1, J ) = A( J, J )
00459                A( J, J-1 ) = -A( J, J )
00460                A( J, J ) = A( J-1, J-1 )
00461             END IF
00462    60    CONTINUE
00463       END IF
00464 *
00465 *     3)      If UPPER='T', set upper triangle of A to random numbers.
00466 *             (but don't modify the corners of 2x2 blocks.)
00467 *
00468       IF( IUPPER.NE.0 ) THEN
00469          DO 70 JC = 2, N
00470             IF( A( JC-1, JC ).NE.ZERO ) THEN
00471                JR = JC - 2
00472             ELSE
00473                JR = JC - 1
00474             END IF
00475             CALL DLARNV( IDIST, ISEED, JR, A( 1, JC ) )
00476    70    CONTINUE
00477       END IF
00478 *
00479 *     4)      If SIM='T', apply similarity transformation.
00480 *
00481 *                                -1
00482 *             Transform is  X A X  , where X = U S V, thus
00483 *
00484 *             it is  U S V A V' (1/S) U'
00485 *
00486       IF( ISIM.NE.0 ) THEN
00487 *
00488 *        Compute S (singular values of the eigenvector matrix)
00489 *        according to CONDS and MODES
00490 *
00491          CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
00492          IF( IINFO.NE.0 ) THEN
00493             INFO = 3
00494             RETURN
00495          END IF
00496 *
00497 *        Multiply by V and V'
00498 *
00499          CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO )
00500          IF( IINFO.NE.0 ) THEN
00501             INFO = 4
00502             RETURN
00503          END IF
00504 *
00505 *        Multiply by S and (1/S)
00506 *
00507          DO 80 J = 1, N
00508             CALL DSCAL( N, DS( J ), A( J, 1 ), LDA )
00509             IF( DS( J ).NE.ZERO ) THEN
00510                CALL DSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
00511             ELSE
00512                INFO = 5
00513                RETURN
00514             END IF
00515    80    CONTINUE
00516 *
00517 *        Multiply by U and U'
00518 *
00519          CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO )
00520          IF( IINFO.NE.0 ) THEN
00521             INFO = 4
00522             RETURN
00523          END IF
00524       END IF
00525 *
00526 *     5)      Reduce the bandwidth.
00527 *
00528       IF( KL.LT.N-1 ) THEN
00529 *
00530 *        Reduce bandwidth -- kill column
00531 *
00532          DO 90 JCR = KL + 1, N - 1
00533             IC = JCR - KL
00534             IROWS = N + 1 - JCR
00535             ICOLS = N + KL - JCR
00536 *
00537             CALL DCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
00538             XNORMS = WORK( 1 )
00539             CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
00540             WORK( 1 ) = ONE
00541 *
00542             CALL DGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA,
00543      \$                  WORK, 1, ZERO, WORK( IROWS+1 ), 1 )
00544             CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
00545      \$                 A( JCR, IC+1 ), LDA )
00546 *
00547             CALL DGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1,
00548      \$                  ZERO, WORK( IROWS+1 ), 1 )
00549             CALL DGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1,
00550      \$                 A( 1, JCR ), LDA )
00551 *
00552             A( JCR, IC ) = XNORMS
00553             CALL DLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ),
00554      \$                   LDA )
00555    90    CONTINUE
00556       ELSE IF( KU.LT.N-1 ) THEN
00557 *
00558 *        Reduce upper bandwidth -- kill a row at a time.
00559 *
00560          DO 100 JCR = KU + 1, N - 1
00561             IR = JCR - KU
00562             IROWS = N + KU - JCR
00563             ICOLS = N + 1 - JCR
00564 *
00565             CALL DCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
00566             XNORMS = WORK( 1 )
00567             CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
00568             WORK( 1 ) = ONE
00569 *
00570             CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA,
00571      \$                  WORK, 1, ZERO, WORK( ICOLS+1 ), 1 )
00572             CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
00573      \$                 A( IR+1, JCR ), LDA )
00574 *
00575             CALL DGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1,
00576      \$                  ZERO, WORK( ICOLS+1 ), 1 )
00577             CALL DGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1,
00578      \$                 A( JCR, 1 ), LDA )
00579 *
00580             A( IR, JCR ) = XNORMS
00581             CALL DLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ),
00582      \$                   LDA )
00583   100    CONTINUE
00584       END IF
00585 *
00586 *     Scale the matrix to have norm ANORM
00587 *
00588       IF( ANORM.GE.ZERO ) THEN
00589          TEMP = DLANGE( 'M', N, N, A, LDA, TEMPA )
00590          IF( TEMP.GT.ZERO ) THEN
00591             ALPHA = ANORM / TEMP
00592             DO 110 J = 1, N
00593                CALL DSCAL( N, ALPHA, A( 1, J ), 1 )
00594   110       CONTINUE
00595          END IF
00596       END IF
00597 *
00598       RETURN
00599 *
00600 *     End of DLATME
00601 *
00602       END
```