LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
cchkbb.f
Go to the documentation of this file.
00001 *> \brief \b CCHKBB
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 CCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
00012 *                          NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
00013 *                          BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
00014 *                          LWORK, RWORK, RESULT, INFO )
00015 * 
00016 *       .. Scalar Arguments ..
00017 *       INTEGER            INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
00018 *      $                   NRHS, NSIZES, NTYPES, NWDTHS
00019 *       REAL               THRESH
00020 *       ..
00021 *       .. Array Arguments ..
00022 *       LOGICAL            DOTYPE( * )
00023 *       INTEGER            ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
00024 *       REAL               BD( * ), BE( * ), RESULT( * ), RWORK( * )
00025 *       COMPLEX            A( LDA, * ), AB( LDAB, * ), C( LDC, * ),
00026 *      $                   CC( LDC, * ), P( LDP, * ), Q( LDQ, * ),
00027 *      $                   WORK( * )
00028 *       ..
00029 *  
00030 *
00031 *> \par Purpose:
00032 *  =============
00033 *>
00034 *> \verbatim
00035 *>
00036 *> CCHKBB tests the reduction of a general complex rectangular band
00037 *> matrix to real bidiagonal form.
00038 *>
00039 *> CGBBRD factors a general band matrix A as  Q B P* , where * means
00040 *> conjugate transpose, B is upper bidiagonal, and Q and P are unitary;
00041 *> CGBBRD can also overwrite a given matrix C with Q* C .
00042 *>
00043 *> For each pair of matrix dimensions (M,N) and each selected matrix
00044 *> type, an M by N matrix A and an M by NRHS matrix C are generated.
00045 *> The problem dimensions are as follows
00046 *>    A:          M x N
00047 *>    Q:          M x M
00048 *>    P:          N x N
00049 *>    B:          min(M,N) x min(M,N)
00050 *>    C:          M x NRHS
00051 *>
00052 *> For each generated matrix, 4 tests are performed:
00053 *>
00054 *> (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
00055 *>
00056 *> (2)   | I - Q' Q | / ( M ulp )
00057 *>
00058 *> (3)   | I - PT PT' | / ( N ulp )
00059 *>
00060 *> (4)   | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
00061 *>
00062 *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
00063 *> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
00064 *> Currently, the list of possible types is:
00065 *>
00066 *> The possible matrix types are
00067 *>
00068 *> (1)  The zero matrix.
00069 *> (2)  The identity matrix.
00070 *>
00071 *> (3)  A diagonal matrix with evenly spaced entries
00072 *>      1, ..., ULP  and random signs.
00073 *>      (ULP = (first number larger than 1) - 1 )
00074 *> (4)  A diagonal matrix with geometrically spaced entries
00075 *>      1, ..., ULP  and random signs.
00076 *> (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
00077 *>      and random signs.
00078 *>
00079 *> (6)  Same as (3), but multiplied by SQRT( overflow threshold )
00080 *> (7)  Same as (3), but multiplied by SQRT( underflow threshold )
00081 *>
00082 *> (8)  A matrix of the form  U D V, where U and V are orthogonal and
00083 *>      D has evenly spaced entries 1, ..., ULP with random signs
00084 *>      on the diagonal.
00085 *>
00086 *> (9)  A matrix of the form  U D V, where U and V are orthogonal and
00087 *>      D has geometrically spaced entries 1, ..., ULP with random
00088 *>      signs on the diagonal.
00089 *>
00090 *> (10) A matrix of the form  U D V, where U and V are orthogonal and
00091 *>      D has "clustered" entries 1, ULP,..., ULP with random
00092 *>      signs on the diagonal.
00093 *>
00094 *> (11) Same as (8), but multiplied by SQRT( overflow threshold )
00095 *> (12) Same as (8), but multiplied by SQRT( underflow threshold )
00096 *>
00097 *> (13) Rectangular matrix with random entries chosen from (-1,1).
00098 *> (14) Same as (13), but multiplied by SQRT( overflow threshold )
00099 *> (15) Same as (13), but multiplied by SQRT( underflow threshold )
00100 *> \endverbatim
00101 *
00102 *  Arguments:
00103 *  ==========
00104 *
00105 *> \param[in] NSIZES
00106 *> \verbatim
00107 *>          NSIZES is INTEGER
00108 *>          The number of values of M and N contained in the vectors
00109 *>          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
00110 *>          If NSIZES is zero, CCHKBB does nothing.  NSIZES must be at
00111 *>          least zero.
00112 *> \endverbatim
00113 *>
00114 *> \param[in] MVAL
00115 *> \verbatim
00116 *>          MVAL is INTEGER array, dimension (NSIZES)
00117 *>          The values of the matrix row dimension M.
00118 *> \endverbatim
00119 *>
00120 *> \param[in] NVAL
00121 *> \verbatim
00122 *>          NVAL is INTEGER array, dimension (NSIZES)
00123 *>          The values of the matrix column dimension N.
00124 *> \endverbatim
00125 *>
00126 *> \param[in] NWDTHS
00127 *> \verbatim
00128 *>          NWDTHS is INTEGER
00129 *>          The number of bandwidths to use.  If it is zero,
00130 *>          CCHKBB does nothing.  It must be at least zero.
00131 *> \endverbatim
00132 *>
00133 *> \param[in] KK
00134 *> \verbatim
00135 *>          KK is INTEGER array, dimension (NWDTHS)
00136 *>          An array containing the bandwidths to be used for the band
00137 *>          matrices.  The values must be at least zero.
00138 *> \endverbatim
00139 *>
00140 *> \param[in] NTYPES
00141 *> \verbatim
00142 *>          NTYPES is INTEGER
00143 *>          The number of elements in DOTYPE.   If it is zero, CCHKBB
00144 *>          does nothing.  It must be at least zero.  If it is MAXTYP+1
00145 *>          and NSIZES is 1, then an additional type, MAXTYP+1 is
00146 *>          defined, which is to use whatever matrix is in A.  This
00147 *>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
00148 *>          DOTYPE(MAXTYP+1) is .TRUE. .
00149 *> \endverbatim
00150 *>
00151 *> \param[in] DOTYPE
00152 *> \verbatim
00153 *>          DOTYPE is LOGICAL array, dimension (NTYPES)
00154 *>          If DOTYPE(j) is .TRUE., then for each size in NN a
00155 *>          matrix of that size and of type j will be generated.
00156 *>          If NTYPES is smaller than the maximum number of types
00157 *>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
00158 *>          MAXTYP will not be generated.  If NTYPES is larger
00159 *>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
00160 *>          will be ignored.
00161 *> \endverbatim
00162 *>
00163 *> \param[in] NRHS
00164 *> \verbatim
00165 *>          NRHS is INTEGER
00166 *>          The number of columns in the "right-hand side" matrix C.
00167 *>          If NRHS = 0, then the operations on the right-hand side will
00168 *>          not be tested. NRHS must be at least 0.
00169 *> \endverbatim
00170 *>
00171 *> \param[in,out] ISEED
00172 *> \verbatim
00173 *>          ISEED is INTEGER array, dimension (4)
00174 *>          On entry ISEED specifies the seed of the random number
00175 *>          generator. The array elements should be between 0 and 4095;
00176 *>          if not they will be reduced mod 4096.  Also, ISEED(4) must
00177 *>          be odd.  The random number generator uses a linear
00178 *>          congruential sequence limited to small integers, and so
00179 *>          should produce machine independent random numbers. The
00180 *>          values of ISEED are changed on exit, and can be used in the
00181 *>          next call to CCHKBB to continue the same random number
00182 *>          sequence.
00183 *> \endverbatim
00184 *>
00185 *> \param[in] THRESH
00186 *> \verbatim
00187 *>          THRESH is REAL
00188 *>          A test will count as "failed" if the "error", computed as
00189 *>          described above, exceeds THRESH.  Note that the error
00190 *>          is scaled to be O(1), so THRESH should be a reasonably
00191 *>          small multiple of 1, e.g., 10 or 100.  In particular,
00192 *>          it should not depend on the precision (single vs. double)
00193 *>          or the size of the matrix.  It must be at least zero.
00194 *> \endverbatim
00195 *>
00196 *> \param[in] NOUNIT
00197 *> \verbatim
00198 *>          NOUNIT is INTEGER
00199 *>          The FORTRAN unit number for printing out error messages
00200 *>          (e.g., if a routine returns IINFO not equal to 0.)
00201 *> \endverbatim
00202 *>
00203 *> \param[in,out] A
00204 *> \verbatim
00205 *>          A is REAL array, dimension
00206 *>                            (LDA, max(NN))
00207 *>          Used to hold the matrix A.
00208 *> \endverbatim
00209 *>
00210 *> \param[in] LDA
00211 *> \verbatim
00212 *>          LDA is INTEGER
00213 *>          The leading dimension of A.  It must be at least 1
00214 *>          and at least max( NN ).
00215 *> \endverbatim
00216 *>
00217 *> \param[out] AB
00218 *> \verbatim
00219 *>          AB is REAL array, dimension (LDAB, max(NN))
00220 *>          Used to hold A in band storage format.
00221 *> \endverbatim
00222 *>
00223 *> \param[in] LDAB
00224 *> \verbatim
00225 *>          LDAB is INTEGER
00226 *>          The leading dimension of AB.  It must be at least 2 (not 1!)
00227 *>          and at least max( KK )+1.
00228 *> \endverbatim
00229 *>
00230 *> \param[out] BD
00231 *> \verbatim
00232 *>          BD is REAL array, dimension (max(NN))
00233 *>          Used to hold the diagonal of the bidiagonal matrix computed
00234 *>          by CGBBRD.
00235 *> \endverbatim
00236 *>
00237 *> \param[out] BE
00238 *> \verbatim
00239 *>          BE is REAL array, dimension (max(NN))
00240 *>          Used to hold the off-diagonal of the bidiagonal matrix
00241 *>          computed by CGBBRD.
00242 *> \endverbatim
00243 *>
00244 *> \param[out] Q
00245 *> \verbatim
00246 *>          Q is COMPLEX array, dimension (LDQ, max(NN))
00247 *>          Used to hold the unitary matrix Q computed by CGBBRD.
00248 *> \endverbatim
00249 *>
00250 *> \param[in] LDQ
00251 *> \verbatim
00252 *>          LDQ is INTEGER
00253 *>          The leading dimension of Q.  It must be at least 1
00254 *>          and at least max( NN ).
00255 *> \endverbatim
00256 *>
00257 *> \param[out] P
00258 *> \verbatim
00259 *>          P is COMPLEX array, dimension (LDP, max(NN))
00260 *>          Used to hold the unitary matrix P computed by CGBBRD.
00261 *> \endverbatim
00262 *>
00263 *> \param[in] LDP
00264 *> \verbatim
00265 *>          LDP is INTEGER
00266 *>          The leading dimension of P.  It must be at least 1
00267 *>          and at least max( NN ).
00268 *> \endverbatim
00269 *>
00270 *> \param[out] C
00271 *> \verbatim
00272 *>          C is COMPLEX array, dimension (LDC, max(NN))
00273 *>          Used to hold the matrix C updated by CGBBRD.
00274 *> \endverbatim
00275 *>
00276 *> \param[in] LDC
00277 *> \verbatim
00278 *>          LDC is INTEGER
00279 *>          The leading dimension of U.  It must be at least 1
00280 *>          and at least max( NN ).
00281 *> \endverbatim
00282 *>
00283 *> \param[out] CC
00284 *> \verbatim
00285 *>          CC is COMPLEX array, dimension (LDC, max(NN))
00286 *>          Used to hold a copy of the matrix C.
00287 *> \endverbatim
00288 *>
00289 *> \param[out] WORK
00290 *> \verbatim
00291 *>          WORK is COMPLEX array, dimension (LWORK)
00292 *> \endverbatim
00293 *>
00294 *> \param[in] LWORK
00295 *> \verbatim
00296 *>          LWORK is INTEGER
00297 *>          The number of entries in WORK.  This must be at least
00298 *>          max( LDA+1, max(NN)+1 )*max(NN).
00299 *> \endverbatim
00300 *>
00301 *> \param[out] RWORK
00302 *> \verbatim
00303 *>          RWORK is REAL array, dimension (max(NN))
00304 *> \endverbatim
00305 *>
00306 *> \param[out] RESULT
00307 *> \verbatim
00308 *>          RESULT is REAL array, dimension (4)
00309 *>          The values computed by the tests described above.
00310 *>          The values are currently limited to 1/ulp, to avoid
00311 *>          overflow.
00312 *> \endverbatim
00313 *>
00314 *> \param[out] INFO
00315 *> \verbatim
00316 *>          INFO is INTEGER
00317 *>          If 0, then everything ran OK.
00318 *>
00319 *>-----------------------------------------------------------------------
00320 *>
00321 *>       Some Local Variables and Parameters:
00322 *>       ---- ----- --------- --- ----------
00323 *>       ZERO, ONE       Real 0 and 1.
00324 *>       MAXTYP          The number of types defined.
00325 *>       NTEST           The number of tests performed, or which can
00326 *>                       be performed so far, for the current matrix.
00327 *>       NTESTT          The total number of tests performed so far.
00328 *>       NMAX            Largest value in NN.
00329 *>       NMATS           The number of matrices generated so far.
00330 *>       NERRS           The number of tests which have exceeded THRESH
00331 *>                       so far.
00332 *>       COND, IMODE     Values to be passed to the matrix generators.
00333 *>       ANORM           Norm of A; passed to matrix generators.
00334 *>
00335 *>       OVFL, UNFL      Overflow and underflow thresholds.
00336 *>       ULP, ULPINV     Finest relative precision and its inverse.
00337 *>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
00338 *>               The following four arrays decode JTYPE:
00339 *>       KTYPE(j)        The general type (1-10) for type "j".
00340 *>       KMODE(j)        The MODE value to be passed to the matrix
00341 *>                       generator for type "j".
00342 *>       KMAGN(j)        The order of magnitude ( O(1),
00343 *>                       O(overflow^(1/2) ), O(underflow^(1/2) )
00344 *> \endverbatim
00345 *
00346 *  Authors:
00347 *  ========
00348 *
00349 *> \author Univ. of Tennessee 
00350 *> \author Univ. of California Berkeley 
00351 *> \author Univ. of Colorado Denver 
00352 *> \author NAG Ltd. 
00353 *
00354 *> \date November 2011
00355 *
00356 *> \ingroup complex_eig
00357 *
00358 *  =====================================================================
00359       SUBROUTINE CCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
00360      $                   NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
00361      $                   BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
00362      $                   LWORK, RWORK, RESULT, INFO )
00363 *
00364 *  -- LAPACK test routine (input) --
00365 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00366 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00367 *     November 2011
00368 *
00369 *     .. Scalar Arguments ..
00370       INTEGER            INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
00371      $                   NRHS, NSIZES, NTYPES, NWDTHS
00372       REAL               THRESH
00373 *     ..
00374 *     .. Array Arguments ..
00375       LOGICAL            DOTYPE( * )
00376       INTEGER            ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
00377       REAL               BD( * ), BE( * ), RESULT( * ), RWORK( * )
00378       COMPLEX            A( LDA, * ), AB( LDAB, * ), C( LDC, * ),
00379      $                   CC( LDC, * ), P( LDP, * ), Q( LDQ, * ),
00380      $                   WORK( * )
00381 *     ..
00382 *
00383 *  =====================================================================
00384 *
00385 *     .. Parameters ..
00386       COMPLEX            CZERO, CONE
00387       PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
00388      $                   CONE = ( 1.0E+0, 0.0E+0 ) )
00389       REAL               ZERO, ONE
00390       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00391       INTEGER            MAXTYP
00392       PARAMETER          ( MAXTYP = 15 )
00393 *     ..
00394 *     .. Local Scalars ..
00395       LOGICAL            BADMM, BADNN, BADNNB
00396       INTEGER            I, IINFO, IMODE, ITYPE, J, JCOL, JR, JSIZE,
00397      $                   JTYPE, JWIDTH, K, KL, KMAX, KU, M, MMAX, MNMAX,
00398      $                   MNMIN, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
00399      $                   NTESTT
00400       REAL               AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, ULP,
00401      $                   ULPINV, UNFL
00402 *     ..
00403 *     .. Local Arrays ..
00404       INTEGER            IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
00405      $                   KMODE( MAXTYP ), KTYPE( MAXTYP )
00406 *     ..
00407 *     .. External Functions ..
00408       REAL               SLAMCH
00409       EXTERNAL           SLAMCH
00410 *     ..
00411 *     .. External Subroutines ..
00412       EXTERNAL           CBDT01, CBDT02, CGBBRD, CLACPY, CLASET, CLATMR,
00413      $                   CLATMS, CUNT01, SLAHD2, SLASUM, XERBLA
00414 *     ..
00415 *     .. Intrinsic Functions ..
00416       INTRINSIC          ABS, MAX, MIN, REAL, SQRT
00417 *     ..
00418 *     .. Data statements ..
00419       DATA               KTYPE / 1, 2, 5*4, 5*6, 3*9 /
00420       DATA               KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3 /
00421       DATA               KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
00422      $                   0, 0 /
00423 *     ..
00424 *     .. Executable Statements ..
00425 *
00426 *     Check for errors
00427 *
00428       NTESTT = 0
00429       INFO = 0
00430 *
00431 *     Important constants
00432 *
00433       BADMM = .FALSE.
00434       BADNN = .FALSE.
00435       MMAX = 1
00436       NMAX = 1
00437       MNMAX = 1
00438       DO 10 J = 1, NSIZES
00439          MMAX = MAX( MMAX, MVAL( J ) )
00440          IF( MVAL( J ).LT.0 )
00441      $      BADMM = .TRUE.
00442          NMAX = MAX( NMAX, NVAL( J ) )
00443          IF( NVAL( J ).LT.0 )
00444      $      BADNN = .TRUE.
00445          MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
00446    10 CONTINUE
00447 *
00448       BADNNB = .FALSE.
00449       KMAX = 0
00450       DO 20 J = 1, NWDTHS
00451          KMAX = MAX( KMAX, KK( J ) )
00452          IF( KK( J ).LT.0 )
00453      $      BADNNB = .TRUE.
00454    20 CONTINUE
00455 *
00456 *     Check for errors
00457 *
00458       IF( NSIZES.LT.0 ) THEN
00459          INFO = -1
00460       ELSE IF( BADMM ) THEN
00461          INFO = -2
00462       ELSE IF( BADNN ) THEN
00463          INFO = -3
00464       ELSE IF( NWDTHS.LT.0 ) THEN
00465          INFO = -4
00466       ELSE IF( BADNNB ) THEN
00467          INFO = -5
00468       ELSE IF( NTYPES.LT.0 ) THEN
00469          INFO = -6
00470       ELSE IF( NRHS.LT.0 ) THEN
00471          INFO = -8
00472       ELSE IF( LDA.LT.NMAX ) THEN
00473          INFO = -13
00474       ELSE IF( LDAB.LT.2*KMAX+1 ) THEN
00475          INFO = -15
00476       ELSE IF( LDQ.LT.NMAX ) THEN
00477          INFO = -19
00478       ELSE IF( LDP.LT.NMAX ) THEN
00479          INFO = -21
00480       ELSE IF( LDC.LT.NMAX ) THEN
00481          INFO = -23
00482       ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
00483          INFO = -26
00484       END IF
00485 *
00486       IF( INFO.NE.0 ) THEN
00487          CALL XERBLA( 'CCHKBB', -INFO )
00488          RETURN
00489       END IF
00490 *
00491 *     Quick return if possible
00492 *
00493       IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
00494      $   RETURN
00495 *
00496 *     More Important constants
00497 *
00498       UNFL = SLAMCH( 'Safe minimum' )
00499       OVFL = ONE / UNFL
00500       ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
00501       ULPINV = ONE / ULP
00502       RTUNFL = SQRT( UNFL )
00503       RTOVFL = SQRT( OVFL )
00504 *
00505 *     Loop over sizes, widths, types
00506 *
00507       NERRS = 0
00508       NMATS = 0
00509 *
00510       DO 160 JSIZE = 1, NSIZES
00511          M = MVAL( JSIZE )
00512          N = NVAL( JSIZE )
00513          MNMIN = MIN( M, N )
00514          AMNINV = ONE / REAL( MAX( 1, M, N ) )
00515 *
00516          DO 150 JWIDTH = 1, NWDTHS
00517             K = KK( JWIDTH )
00518             IF( K.GE.M .AND. K.GE.N )
00519      $         GO TO 150
00520             KL = MAX( 0, MIN( M-1, K ) )
00521             KU = MAX( 0, MIN( N-1, K ) )
00522 *
00523             IF( NSIZES.NE.1 ) THEN
00524                MTYPES = MIN( MAXTYP, NTYPES )
00525             ELSE
00526                MTYPES = MIN( MAXTYP+1, NTYPES )
00527             END IF
00528 *
00529             DO 140 JTYPE = 1, MTYPES
00530                IF( .NOT.DOTYPE( JTYPE ) )
00531      $            GO TO 140
00532                NMATS = NMATS + 1
00533                NTEST = 0
00534 *
00535                DO 30 J = 1, 4
00536                   IOLDSD( J ) = ISEED( J )
00537    30          CONTINUE
00538 *
00539 *              Compute "A".
00540 *
00541 *              Control parameters:
00542 *
00543 *                  KMAGN  KMODE        KTYPE
00544 *              =1  O(1)   clustered 1  zero
00545 *              =2  large  clustered 2  identity
00546 *              =3  small  exponential  (none)
00547 *              =4         arithmetic   diagonal, (w/ singular values)
00548 *              =5         random log   (none)
00549 *              =6         random       nonhermitian, w/ singular values
00550 *              =7                      (none)
00551 *              =8                      (none)
00552 *              =9                      random nonhermitian
00553 *
00554                IF( MTYPES.GT.MAXTYP )
00555      $            GO TO 90
00556 *
00557                ITYPE = KTYPE( JTYPE )
00558                IMODE = KMODE( JTYPE )
00559 *
00560 *              Compute norm
00561 *
00562                GO TO ( 40, 50, 60 )KMAGN( JTYPE )
00563 *
00564    40          CONTINUE
00565                ANORM = ONE
00566                GO TO 70
00567 *
00568    50          CONTINUE
00569                ANORM = ( RTOVFL*ULP )*AMNINV
00570                GO TO 70
00571 *
00572    60          CONTINUE
00573                ANORM = RTUNFL*MAX( M, N )*ULPINV
00574                GO TO 70
00575 *
00576    70          CONTINUE
00577 *
00578                CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA )
00579                CALL CLASET( 'Full', LDAB, N, CZERO, CZERO, AB, LDAB )
00580                IINFO = 0
00581                COND = ULPINV
00582 *
00583 *              Special Matrices -- Identity & Jordan block
00584 *
00585 *                 Zero
00586 *
00587                IF( ITYPE.EQ.1 ) THEN
00588                   IINFO = 0
00589 *
00590                ELSE IF( ITYPE.EQ.2 ) THEN
00591 *
00592 *                 Identity
00593 *
00594                   DO 80 JCOL = 1, N
00595                      A( JCOL, JCOL ) = ANORM
00596    80             CONTINUE
00597 *
00598                ELSE IF( ITYPE.EQ.4 ) THEN
00599 *
00600 *                 Diagonal Matrix, singular values specified
00601 *
00602                   CALL CLATMS( M, N, 'S', ISEED, 'N', RWORK, IMODE,
00603      $                         COND, ANORM, 0, 0, 'N', A, LDA, WORK,
00604      $                         IINFO )
00605 *
00606                ELSE IF( ITYPE.EQ.6 ) THEN
00607 *
00608 *                 Nonhermitian, singular values specified
00609 *
00610                   CALL CLATMS( M, N, 'S', ISEED, 'N', RWORK, IMODE,
00611      $                         COND, ANORM, KL, KU, 'N', A, LDA, WORK,
00612      $                         IINFO )
00613 *
00614                ELSE IF( ITYPE.EQ.9 ) THEN
00615 *
00616 *                 Nonhermitian, random entries
00617 *
00618                   CALL CLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE,
00619      $                         CONE, 'T', 'N', WORK( N+1 ), 1, ONE,
00620      $                         WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, KL,
00621      $                         KU, ZERO, ANORM, 'N', A, LDA, IDUMMA,
00622      $                         IINFO )
00623 *
00624                ELSE
00625 *
00626                   IINFO = 1
00627                END IF
00628 *
00629 *              Generate Right-Hand Side
00630 *
00631                CALL CLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
00632      $                      CONE, 'T', 'N', WORK( M+1 ), 1, ONE,
00633      $                      WORK( 2*M+1 ), 1, ONE, 'N', IDUMMA, M, NRHS,
00634      $                      ZERO, ONE, 'NO', C, LDC, IDUMMA, IINFO )
00635 *
00636                IF( IINFO.NE.0 ) THEN
00637                   WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
00638      $               JTYPE, IOLDSD
00639                   INFO = ABS( IINFO )
00640                   RETURN
00641                END IF
00642 *
00643    90          CONTINUE
00644 *
00645 *              Copy A to band storage.
00646 *
00647                DO 110 J = 1, N
00648                   DO 100 I = MAX( 1, J-KU ), MIN( M, J+KL )
00649                      AB( KU+1+I-J, J ) = A( I, J )
00650   100             CONTINUE
00651   110          CONTINUE
00652 *
00653 *              Copy C
00654 *
00655                CALL CLACPY( 'Full', M, NRHS, C, LDC, CC, LDC )
00656 *
00657 *              Call CGBBRD to compute B, Q and P, and to update C.
00658 *
00659                CALL CGBBRD( 'B', M, N, NRHS, KL, KU, AB, LDAB, BD, BE,
00660      $                      Q, LDQ, P, LDP, CC, LDC, WORK, RWORK,
00661      $                      IINFO )
00662 *
00663                IF( IINFO.NE.0 ) THEN
00664                   WRITE( NOUNIT, FMT = 9999 )'CGBBRD', IINFO, N, JTYPE,
00665      $               IOLDSD
00666                   INFO = ABS( IINFO )
00667                   IF( IINFO.LT.0 ) THEN
00668                      RETURN
00669                   ELSE
00670                      RESULT( 1 ) = ULPINV
00671                      GO TO 120
00672                   END IF
00673                END IF
00674 *
00675 *              Test 1:  Check the decomposition A := Q * B * P'
00676 *                   2:  Check the orthogonality of Q
00677 *                   3:  Check the orthogonality of P
00678 *                   4:  Check the computation of Q' * C
00679 *
00680                CALL CBDT01( M, N, -1, A, LDA, Q, LDQ, BD, BE, P, LDP,
00681      $                      WORK, RWORK, RESULT( 1 ) )
00682                CALL CUNT01( 'Columns', M, M, Q, LDQ, WORK, LWORK, RWORK,
00683      $                      RESULT( 2 ) )
00684                CALL CUNT01( 'Rows', N, N, P, LDP, WORK, LWORK, RWORK,
00685      $                      RESULT( 3 ) )
00686                CALL CBDT02( M, NRHS, C, LDC, CC, LDC, Q, LDQ, WORK,
00687      $                      RWORK, RESULT( 4 ) )
00688 *
00689 *              End of Loop -- Check for RESULT(j) > THRESH
00690 *
00691                NTEST = 4
00692   120          CONTINUE
00693                NTESTT = NTESTT + NTEST
00694 *
00695 *              Print out tests which fail.
00696 *
00697                DO 130 JR = 1, NTEST
00698                   IF( RESULT( JR ).GE.THRESH ) THEN
00699                      IF( NERRS.EQ.0 )
00700      $                  CALL SLAHD2( NOUNIT, 'CBB' )
00701                      NERRS = NERRS + 1
00702                      WRITE( NOUNIT, FMT = 9998 )M, N, K, IOLDSD, JTYPE,
00703      $                  JR, RESULT( JR )
00704                   END IF
00705   130          CONTINUE
00706 *
00707   140       CONTINUE
00708   150    CONTINUE
00709   160 CONTINUE
00710 *
00711 *     Summary
00712 *
00713       CALL SLASUM( 'CBB', NOUNIT, NERRS, NTESTT )
00714       RETURN
00715 *
00716  9999 FORMAT( ' CCHKBB: ', A, ' returned INFO=', I5, '.', / 9X, 'M=',
00717      $      I5, ' N=', I5, ' K=', I5, ', JTYPE=', I5, ', ISEED=(',
00718      $      3( I5, ',' ), I5, ')' )
00719  9998 FORMAT( ' M =', I4, ' N=', I4, ', K=', I3, ', seed=',
00720      $      4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
00721 *
00722 *     End of CCHKBB
00723 *
00724       END
 All Files Functions