LAPACK 3.3.0

zchkbb.f

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