![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZCHKBB 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 ZCHKBB( 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 * DOUBLE PRECISION THRESH 00020 * .. 00021 * .. Array Arguments .. 00022 * LOGICAL DOTYPE( * ) 00023 * INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * ) 00024 * DOUBLE PRECISION BD( * ), BE( * ), RESULT( * ), RWORK( * ) 00025 * COMPLEX*16 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 *> ZCHKBB tests the reduction of a general complex rectangular band 00037 *> matrix to real bidiagonal form. 00038 *> 00039 *> ZGBBRD 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 *> ZGBBRD 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, ZCHKBB 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 *> ZCHKBB 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, ZCHKBB 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 ZCHKBB to continue the same random number 00182 *> sequence. 00183 *> \endverbatim 00184 *> 00185 *> \param[in] THRESH 00186 *> \verbatim 00187 *> THRESH is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (max(NN)) 00233 *> Used to hold the diagonal of the bidiagonal matrix computed 00234 *> by ZGBBRD. 00235 *> \endverbatim 00236 *> 00237 *> \param[out] BE 00238 *> \verbatim 00239 *> BE is DOUBLE PRECISION array, dimension (max(NN)) 00240 *> Used to hold the off-diagonal of the bidiagonal matrix 00241 *> computed by ZGBBRD. 00242 *> \endverbatim 00243 *> 00244 *> \param[out] Q 00245 *> \verbatim 00246 *> Q is COMPLEX*16 array, dimension (LDQ, max(NN)) 00247 *> Used to hold the unitary matrix Q computed by ZGBBRD. 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*16 array, dimension (LDP, max(NN)) 00260 *> Used to hold the unitary matrix P computed by ZGBBRD. 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*16 array, dimension (LDC, max(NN)) 00273 *> Used to hold the matrix C updated by ZGBBRD. 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*16 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*16 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 DOUBLE PRECISION array, dimension (max(NN)) 00304 *> \endverbatim 00305 *> 00306 *> \param[out] RESULT 00307 *> \verbatim 00308 *> RESULT is DOUBLE PRECISION 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 complex16_eig 00357 * 00358 * ===================================================================== 00359 SUBROUTINE ZCHKBB( 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 DOUBLE PRECISION THRESH 00373 * .. 00374 * .. Array Arguments .. 00375 LOGICAL DOTYPE( * ) 00376 INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * ) 00377 DOUBLE PRECISION BD( * ), BE( * ), RESULT( * ), RWORK( * ) 00378 COMPLEX*16 A( LDA, * ), AB( LDAB, * ), C( LDC, * ), 00379 $ CC( LDC, * ), P( LDP, * ), Q( LDQ, * ), 00380 $ WORK( * ) 00381 * .. 00382 * 00383 * ===================================================================== 00384 * 00385 * .. Parameters .. 00386 COMPLEX*16 CZERO, CONE 00387 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), 00388 $ CONE = ( 1.0D+0, 0.0D+0 ) ) 00389 DOUBLE PRECISION ZERO, ONE 00390 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+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 DOUBLE PRECISION 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 DOUBLE PRECISION DLAMCH 00409 EXTERNAL DLAMCH 00410 * .. 00411 * .. External Subroutines .. 00412 EXTERNAL DLAHD2, DLASUM, XERBLA, ZBDT01, ZBDT02, ZGBBRD, 00413 $ ZLACPY, ZLASET, ZLATMR, ZLATMS, ZUNT01 00414 * .. 00415 * .. Intrinsic Functions .. 00416 INTRINSIC ABS, DBLE, MAX, MIN, 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( 'ZCHKBB', -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 = DLAMCH( 'Safe minimum' ) 00499 OVFL = ONE / UNFL 00500 ULP = DLAMCH( 'Epsilon' )*DLAMCH( '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 / DBLE( 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 ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) 00579 CALL ZLASET( '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 ZLATMS( 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 ZLATMS( 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 ZLATMR( 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 ZLATMR( 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 ZLACPY( 'Full', M, NRHS, C, LDC, CC, LDC ) 00656 * 00657 * Call ZGBBRD to compute B, Q and P, and to update C. 00658 * 00659 CALL ZGBBRD( '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 )'ZGBBRD', 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 ZBDT01( M, N, -1, A, LDA, Q, LDQ, BD, BE, P, LDP, 00681 $ WORK, RWORK, RESULT( 1 ) ) 00682 CALL ZUNT01( 'Columns', M, M, Q, LDQ, WORK, LWORK, RWORK, 00683 $ RESULT( 2 ) ) 00684 CALL ZUNT01( 'Rows', N, N, P, LDP, WORK, LWORK, RWORK, 00685 $ RESULT( 3 ) ) 00686 CALL ZBDT02( 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 DLAHD2( NOUNIT, 'ZBB' ) 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 DLASUM( 'ZBB', NOUNIT, NERRS, NTESTT ) 00714 RETURN 00715 * 00716 9999 FORMAT( ' ZCHKBB: ', 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 ZCHKBB 00723 * 00724 END