LAPACK: TESTING/EIG/schkbd.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS,
00002      $                   ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX,
00003      $                   Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK,
00004      $                   IWORK, NOUT, INFO )
00005 *
00006 *  -- LAPACK test routine (version 3.1) --
00007 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00008 *     November 2006
00009 *
00010 *     .. Scalar Arguments ..
00011       INTEGER            INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
00012      $                   NSIZES, NTYPES
00013       REAL               THRESH
00014 *     ..
00015 *     .. Array Arguments ..
00016       LOGICAL            DOTYPE( * )
00017       INTEGER            ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
00018       REAL               A( LDA, * ), BD( * ), BE( * ), PT( LDPT, * ),
00019      $                   Q( LDQ, * ), S1( * ), S2( * ), U( LDPT, * ),
00020      $                   VT( LDPT, * ), WORK( * ), X( LDX, * ),
00021      $                   Y( LDX, * ), Z( LDX, * )
00022 *     ..
00023 *
00024 *  Purpose
00025 *  =======
00026 *
00027 *  SCHKBD checks the singular value decomposition (SVD) routines.
00028 *
00029 *  SGEBRD reduces a real general m by n matrix A to upper or lower
00030 *  bidiagonal form B by an orthogonal transformation:  Q' * A * P = B
00031 *  (or A = Q * B * P').  The matrix B is upper bidiagonal if m >= n
00032 *  and lower bidiagonal if m < n.
00033 *
00034 *  SORGBR generates the orthogonal matrices Q and P' from SGEBRD.
00035 *  Note that Q and P are not necessarily square.
00036 *
00037 *  SBDSQR computes the singular value decomposition of the bidiagonal
00038 *  matrix B as B = U S V'.  It is called three times to compute
00039 *     1)  B = U S1 V', where S1 is the diagonal matrix of singular
00040 *         values and the columns of the matrices U and V are the left
00041 *         and right singular vectors, respectively, of B.
00042 *     2)  Same as 1), but the singular values are stored in S2 and the
00043 *         singular vectors are not computed.
00044 *     3)  A = (UQ) S (P'V'), the SVD of the original matrix A.
00045 *  In addition, SBDSQR has an option to apply the left orthogonal matrix
00046 *  U to a matrix X, useful in least squares applications.
00047 *
00048 *  SBDSDC computes the singular value decomposition of the bidiagonal
00049 *  matrix B as B = U S V' using divide-and-conquer. It is called twice
00050 *  to compute
00051 *     1) B = U S1 V', where S1 is the diagonal matrix of singular
00052 *         values and the columns of the matrices U and V are the left
00053 *         and right singular vectors, respectively, of B.
00054 *     2) Same as 1), but the singular values are stored in S2 and the
00055 *         singular vectors are not computed.
00056 *
00057 *  For each pair of matrix dimensions (M,N) and each selected matrix
00058 *  type, an M by N matrix A and an M by NRHS matrix X are generated.
00059 *  The problem dimensions are as follows
00060 *     A:          M x N
00061 *     Q:          M x min(M,N) (but M x M if NRHS > 0)
00062 *     P:          min(M,N) x N
00063 *     B:          min(M,N) x min(M,N)
00064 *     U, V:       min(M,N) x min(M,N)
00065 *     S1, S2      diagonal, order min(M,N)
00066 *     X:          M x NRHS
00067 *
00068 *  For each generated matrix, 14 tests are performed:
00069 *
00070 *  Test SGEBRD and SORGBR
00071 *
00072 *  (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
00073 *
00074 *  (2)   | I - Q' Q | / ( M ulp )
00075 *
00076 *  (3)   | I - PT PT' | / ( N ulp )
00077 *
00078 *  Test SBDSQR on bidiagonal matrix B
00079 *
00080 *  (4)   | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
00081 *
00082 *  (5)   | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
00083 *                                                   and   Z = U' Y.
00084 *  (6)   | I - U' U | / ( min(M,N) ulp )
00085 *
00086 *  (7)   | I - VT VT' | / ( min(M,N) ulp )
00087 *
00088 *  (8)   S1 contains min(M,N) nonnegative values in decreasing order.
00089 *        (Return 0 if true, 1/ULP if false.)
00090 *
00091 *  (9)   | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
00092 *                                    computing U and V.
00093 *
00094 *  (10)  0 if the true singular values of B are within THRESH of
00095 *        those in S1.  2*THRESH if they are not.  (Tested using
00096 *        SSVDCH)
00097 *
00098 *  Test SBDSQR on matrix A
00099 *
00100 *  (11)  | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
00101 *
00102 *  (12)  | X - (QU) Z | / ( |X| max(M,k) ulp )
00103 *
00104 *  (13)  | I - (QU)'(QU) | / ( M ulp )
00105 *
00106 *  (14)  | I - (VT PT) (PT'VT') | / ( N ulp )
00107 *
00108 *  Test SBDSDC on bidiagonal matrix B
00109 *
00110 *  (15)  | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
00111 *
00112 *  (16)  | I - U' U | / ( min(M,N) ulp )
00113 *
00114 *  (17)  | I - VT VT' | / ( min(M,N) ulp )
00115 *
00116 *  (18)  S1 contains min(M,N) nonnegative values in decreasing order.
00117 *        (Return 0 if true, 1/ULP if false.)
00118 *
00119 *  (19)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
00120 *                                    computing U and V.
00121 *  The possible matrix types are
00122 *
00123 *  (1)  The zero matrix.
00124 *  (2)  The identity matrix.
00125 *
00126 *  (3)  A diagonal matrix with evenly spaced entries
00127 *       1, ..., ULP  and random signs.
00128 *       (ULP = (first number larger than 1) - 1 )
00129 *  (4)  A diagonal matrix with geometrically spaced entries
00130 *       1, ..., ULP  and random signs.
00131 *  (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
00132 *       and random signs.
00133 *
00134 *  (6)  Same as (3), but multiplied by SQRT( overflow threshold )
00135 *  (7)  Same as (3), but multiplied by SQRT( underflow threshold )
00136 *
00137 *  (8)  A matrix of the form  U D V, where U and V are orthogonal and
00138 *       D has evenly spaced entries 1, ..., ULP with random signs
00139 *       on the diagonal.
00140 *
00141 *  (9)  A matrix of the form  U D V, where U and V are orthogonal and
00142 *       D has geometrically spaced entries 1, ..., ULP with random
00143 *       signs on the diagonal.
00144 *
00145 *  (10) A matrix of the form  U D V, where U and V are orthogonal and
00146 *       D has "clustered" entries 1, ULP,..., ULP with random
00147 *       signs on the diagonal.
00148 *
00149 *  (11) Same as (8), but multiplied by SQRT( overflow threshold )
00150 *  (12) Same as (8), but multiplied by SQRT( underflow threshold )
00151 *
00152 *  (13) Rectangular matrix with random entries chosen from (-1,1).
00153 *  (14) Same as (13), but multiplied by SQRT( overflow threshold )
00154 *  (15) Same as (13), but multiplied by SQRT( underflow threshold )
00155 *
00156 *  Special case:
00157 *  (16) A bidiagonal matrix with random entries chosen from a
00158 *       logarithmic distribution on [ulp^2,ulp^(-2)]  (I.e., each
00159 *       entry is  e^x, where x is chosen uniformly on
00160 *       [ 2 log(ulp), -2 log(ulp) ] .)  For *this* type:
00161 *       (a) SGEBRD is not called to reduce it to bidiagonal form.
00162 *       (b) the bidiagonal is  min(M,N) x min(M,N); if M<N, the
00163 *           matrix will be lower bidiagonal, otherwise upper.
00164 *       (c) only tests 5--8 and 14 are performed.
00165 *
00166 *  A subset of the full set of matrix types may be selected through
00167 *  the logical array DOTYPE.
00168 *
00169 *  Arguments
00170 *  ==========
00171 *
00172 *  NSIZES  (input) INTEGER
00173 *          The number of values of M and N contained in the vectors
00174 *          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
00175 *
00176 *  MVAL    (input) INTEGER array, dimension (NM)
00177 *          The values of the matrix row dimension M.
00178 *
00179 *  NVAL    (input) INTEGER array, dimension (NM)
00180 *          The values of the matrix column dimension N.
00181 *
00182 *  NTYPES  (input) INTEGER
00183 *          The number of elements in DOTYPE.   If it is zero, SCHKBD
00184 *          does nothing.  It must be at least zero.  If it is MAXTYP+1
00185 *          and NSIZES is 1, then an additional type, MAXTYP+1 is
00186 *          defined, which is to use whatever matrices are in A and B.
00187 *          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
00188 *          DOTYPE(MAXTYP+1) is .TRUE. .
00189 *
00190 *  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
00191 *          If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
00192 *          of type j will be generated.  If NTYPES is smaller than the
00193 *          maximum number of types defined (PARAMETER MAXTYP), then
00194 *          types NTYPES+1 through MAXTYP will not be generated.  If
00195 *          NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
00196 *          DOTYPE(NTYPES) will be ignored.
00197 *
00198 *  NRHS    (input) INTEGER
00199 *          The number of columns in the "right-hand side" matrices X, Y,
00200 *          and Z, used in testing SBDSQR.  If NRHS = 0, then the
00201 *          operations on the right-hand side will not be tested.
00202 *          NRHS must be at least 0.
00203 *
00204 *  ISEED   (input/output) INTEGER array, dimension (4)
00205 *          On entry ISEED specifies the seed of the random number
00206 *          generator. The array elements should be between 0 and 4095;
00207 *          if not they will be reduced mod 4096.  Also, ISEED(4) must
00208 *          be odd.  The values of ISEED are changed on exit, and can be
00209 *          used in the next call to SCHKBD to continue the same random
00210 *          number sequence.
00211 *
00212 *  THRESH  (input) REAL
00213 *          The threshold value for the test ratios.  A result is
00214 *          included in the output file if RESULT >= THRESH.  To have
00215 *          every test ratio printed, use THRESH = 0.  Note that the
00216 *          expected value of the test ratios is O(1), so THRESH should
00217 *          be a reasonably small multiple of 1, e.g., 10 or 100.
00218 *
00219 *  A       (workspace) REAL array, dimension (LDA,NMAX)
00220 *          where NMAX is the maximum value of N in NVAL.
00221 *
00222 *  LDA     (input) INTEGER
00223 *          The leading dimension of the array A.  LDA >= max(1,MMAX),
00224 *          where MMAX is the maximum value of M in MVAL.
00225 *
00226 *  BD      (workspace) REAL array, dimension
00227 *                      (max(min(MVAL(j),NVAL(j))))
00228 *
00229 *  BE      (workspace) REAL array, dimension
00230 *                      (max(min(MVAL(j),NVAL(j))))
00231 *
00232 *  S1      (workspace) REAL array, dimension
00233 *                      (max(min(MVAL(j),NVAL(j))))
00234 *
00235 *  S2      (workspace) REAL array, dimension
00236 *                      (max(min(MVAL(j),NVAL(j))))
00237 *
00238 *  X       (workspace) REAL array, dimension (LDX,NRHS)
00239 *
00240 *  LDX     (input) INTEGER
00241 *          The leading dimension of the arrays X, Y, and Z.
00242 *          LDX >= max(1,MMAX)
00243 *
00244 *  Y       (workspace) REAL array, dimension (LDX,NRHS)
00245 *
00246 *  Z       (workspace) REAL array, dimension (LDX,NRHS)
00247 *
00248 *  Q       (workspace) REAL array, dimension (LDQ,MMAX)
00249 *
00250 *  LDQ     (input) INTEGER
00251 *          The leading dimension of the array Q.  LDQ >= max(1,MMAX).
00252 *
00253 *  PT      (workspace) REAL array, dimension (LDPT,NMAX)
00254 *
00255 *  LDPT    (input) INTEGER
00256 *          The leading dimension of the arrays PT, U, and V.
00257 *          LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
00258 *
00259 *  U       (workspace) REAL array, dimension
00260 *                      (LDPT,max(min(MVAL(j),NVAL(j))))
00261 *
00262 *  V       (workspace) REAL array, dimension
00263 *                      (LDPT,max(min(MVAL(j),NVAL(j))))
00264 *
00265 *  WORK    (workspace) REAL array, dimension (LWORK)
00266 *
00267 *  LWORK   (input) INTEGER
00268 *          The number of entries in WORK.  This must be at least
00269 *          3(M+N) and  M(M + max(M,N,k) + 1) + N*min(M,N)  for all
00270 *          pairs  (M,N)=(MM(j),NN(j))
00271 *
00272 *  IWORK   (workspace) INTEGER array, dimension at least 8*min(M,N)
00273 *
00274 *  NOUT    (input) INTEGER
00275 *          The FORTRAN unit number for printing out error messages
00276 *          (e.g., if a routine returns IINFO not equal to 0.)
00277 *
00278 *  INFO    (output) INTEGER
00279 *          If 0, then everything ran OK.
00280 *           -1: NSIZES < 0
00281 *           -2: Some MM(j) < 0
00282 *           -3: Some NN(j) < 0
00283 *           -4: NTYPES < 0
00284 *           -6: NRHS  < 0
00285 *           -8: THRESH < 0
00286 *          -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
00287 *          -17: LDB < 1 or LDB < MMAX.
00288 *          -21: LDQ < 1 or LDQ < MMAX.
00289 *          -23: LDPT< 1 or LDPT< MNMAX.
00290 *          -27: LWORK too small.
00291 *          If  SLATMR, SLATMS, SGEBRD, SORGBR, or SBDSQR,
00292 *              returns an error code, the
00293 *              absolute value of it is returned.
00294 *
00295 *-----------------------------------------------------------------------
00296 *
00297 *     Some Local Variables and Parameters:
00298 *     ---- ----- --------- --- ----------
00299 *
00300 *     ZERO, ONE       Real 0 and 1.
00301 *     MAXTYP          The number of types defined.
00302 *     NTEST           The number of tests performed, or which can
00303 *                     be performed so far, for the current matrix.
00304 *     MMAX            Largest value in NN.
00305 *     NMAX            Largest value in NN.
00306 *     MNMIN           min(MM(j), NN(j)) (the dimension of the bidiagonal
00307 *                     matrix.)
00308 *     MNMAX           The maximum value of MNMIN for j=1,...,NSIZES.
00309 *     NFAIL           The number of tests which have exceeded THRESH
00310 *     COND, IMODE     Values to be passed to the matrix generators.
00311 *     ANORM           Norm of A; passed to matrix generators.
00312 *
00313 *     OVFL, UNFL      Overflow and underflow thresholds.
00314 *     RTOVFL, RTUNFL  Square roots of the previous 2 values.
00315 *     ULP, ULPINV     Finest relative precision and its inverse.
00316 *
00317 *             The following four arrays decode JTYPE:
00318 *     KTYPE(j)        The general type (1-10) for type "j".
00319 *     KMODE(j)        The MODE value to be passed to the matrix
00320 *                     generator for type "j".
00321 *     KMAGN(j)        The order of magnitude ( O(1),
00322 *                     O(overflow^(1/2) ), O(underflow^(1/2) )
00323 *
00324 * ======================================================================
00325 *
00326 *     .. Parameters ..
00327       REAL               ZERO, ONE, TWO, HALF
00328       PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
00329      $                   HALF = 0.5E0 )
00330       INTEGER            MAXTYP
00331       PARAMETER          ( MAXTYP = 16 )
00332 *     ..
00333 *     .. Local Scalars ..
00334       LOGICAL            BADMM, BADNN, BIDIAG
00335       CHARACTER          UPLO
00336       CHARACTER*3        PATH
00337       INTEGER            I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
00338      $                   LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, MQ,
00339      $                   MTYPES, N, NFAIL, NMAX, NTEST
00340       REAL               AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
00341      $                   TEMP1, TEMP2, ULP, ULPINV, UNFL
00342 *     ..
00343 *     .. Local Arrays ..
00344       INTEGER            IDUM( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
00345      $                   KMODE( MAXTYP ), KTYPE( MAXTYP )
00346       REAL               DUM( 1 ), DUMMA( 1 ), RESULT( 19 )
00347 *     ..
00348 *     .. External Functions ..
00349       REAL               SLAMCH, SLARND
00350       EXTERNAL           SLAMCH, SLARND
00351 *     ..
00352 *     .. External Subroutines ..
00353       EXTERNAL           ALASUM, SBDSDC, SBDSQR, SBDT01, SBDT02, SBDT03,
00354      $                   SCOPY, SGEBRD, SGEMM, SLABAD, SLACPY, SLAHD2,
00355      $                   SLASET, SLATMR, SLATMS, SORGBR, SORT01, XERBLA
00356 *     ..
00357 *     .. Intrinsic Functions ..
00358       INTRINSIC          ABS, EXP, INT, LOG, MAX, MIN, SQRT
00359 *     ..
00360 *     .. Scalars in Common ..
00361       LOGICAL            LERR, OK
00362       CHARACTER*32       SRNAMT
00363       INTEGER            INFOT, NUNIT
00364 *     ..
00365 *     .. Common blocks ..
00366       COMMON             / INFOC / INFOT, NUNIT, OK, LERR
00367       COMMON             / SRNAMC / SRNAMT
00368 *     ..
00369 *     .. Data statements ..
00370       DATA               KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 /
00371       DATA               KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
00372       DATA               KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
00373      $                   0, 0, 0 /
00374 *     ..
00375 *     .. Executable Statements ..
00376 *
00377 *     Check for errors
00378 *
00379       INFO = 0
00380 *
00381       BADMM = .FALSE.
00382       BADNN = .FALSE.
00383       MMAX = 1
00384       NMAX = 1
00385       MNMAX = 1
00386       MINWRK = 1
00387       DO 10 J = 1, NSIZES
00388          MMAX = MAX( MMAX, MVAL( J ) )
00389          IF( MVAL( J ).LT.0 )
00390      $      BADMM = .TRUE.
00391          NMAX = MAX( NMAX, NVAL( J ) )
00392          IF( NVAL( J ).LT.0 )
00393      $      BADNN = .TRUE.
00394          MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
00395          MINWRK = MAX( MINWRK, 3*( MVAL( J )+NVAL( J ) ),
00396      $            MVAL( J )*( MVAL( J )+MAX( MVAL( J ), NVAL( J ),
00397      $            NRHS )+1 )+NVAL( J )*MIN( NVAL( J ), MVAL( J ) ) )
00398    10 CONTINUE
00399 *
00400 *     Check for errors
00401 *
00402       IF( NSIZES.LT.0 ) THEN
00403          INFO = -1
00404       ELSE IF( BADMM ) THEN
00405          INFO = -2
00406       ELSE IF( BADNN ) THEN
00407          INFO = -3
00408       ELSE IF( NTYPES.LT.0 ) THEN
00409          INFO = -4
00410       ELSE IF( NRHS.LT.0 ) THEN
00411          INFO = -6
00412       ELSE IF( LDA.LT.MMAX ) THEN
00413          INFO = -11
00414       ELSE IF( LDX.LT.MMAX ) THEN
00415          INFO = -17
00416       ELSE IF( LDQ.LT.MMAX ) THEN
00417          INFO = -21
00418       ELSE IF( LDPT.LT.MNMAX ) THEN
00419          INFO = -23
00420       ELSE IF( MINWRK.GT.LWORK ) THEN
00421          INFO = -27
00422       END IF
00423 *
00424       IF( INFO.NE.0 ) THEN
00425          CALL XERBLA( 'SCHKBD', -INFO )
00426          RETURN
00427       END IF
00428 *
00429 *     Initialize constants
00430 *
00431       PATH( 1: 1 ) = 'Single precision'
00432       PATH( 2: 3 ) = 'BD'
00433       NFAIL = 0
00434       NTEST = 0
00435       UNFL = SLAMCH( 'Safe minimum' )
00436       OVFL = SLAMCH( 'Overflow' )
00437       CALL SLABAD( UNFL, OVFL )
00438       ULP = SLAMCH( 'Precision' )
00439       ULPINV = ONE / ULP
00440       LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
00441       RTUNFL = SQRT( UNFL )
00442       RTOVFL = SQRT( OVFL )
00443       INFOT = 0
00444 *
00445 *     Loop over sizes, types
00446 *
00447       DO 200 JSIZE = 1, NSIZES
00448          M = MVAL( JSIZE )
00449          N = NVAL( JSIZE )
00450          MNMIN = MIN( M, N )
00451          AMNINV = ONE / MAX( M, N, 1 )
00452 *
00453          IF( NSIZES.NE.1 ) THEN
00454             MTYPES = MIN( MAXTYP, NTYPES )
00455          ELSE
00456             MTYPES = MIN( MAXTYP+1, NTYPES )
00457          END IF
00458 *
00459          DO 190 JTYPE = 1, MTYPES
00460             IF( .NOT.DOTYPE( JTYPE ) )
00461      $         GO TO 190
00462 *
00463             DO 20 J = 1, 4
00464                IOLDSD( J ) = ISEED( J )
00465    20       CONTINUE
00466 *
00467             DO 30 J = 1, 14
00468                RESULT( J ) = -ONE
00469    30       CONTINUE
00470 *
00471             UPLO = ' '
00472 *
00473 *           Compute "A"
00474 *
00475 *           Control parameters:
00476 *
00477 *           KMAGN  KMODE        KTYPE
00478 *       =1  O(1)   clustered 1  zero
00479 *       =2  large  clustered 2  identity
00480 *       =3  small  exponential  (none)
00481 *       =4         arithmetic   diagonal, (w/ eigenvalues)
00482 *       =5         random       symmetric, w/ eigenvalues
00483 *       =6                      nonsymmetric, w/ singular values
00484 *       =7                      random diagonal
00485 *       =8                      random symmetric
00486 *       =9                      random nonsymmetric
00487 *       =10                     random bidiagonal (log. distrib.)
00488 *
00489             IF( MTYPES.GT.MAXTYP )
00490      $         GO TO 100
00491 *
00492             ITYPE = KTYPE( JTYPE )
00493             IMODE = KMODE( JTYPE )
00494 *
00495 *           Compute norm
00496 *
00497             GO TO ( 40, 50, 60 )KMAGN( JTYPE )
00498 *
00499    40       CONTINUE
00500             ANORM = ONE
00501             GO TO 70
00502 *
00503    50       CONTINUE
00504             ANORM = ( RTOVFL*ULP )*AMNINV
00505             GO TO 70
00506 *
00507    60       CONTINUE
00508             ANORM = RTUNFL*MAX( M, N )*ULPINV
00509             GO TO 70
00510 *
00511    70       CONTINUE
00512 *
00513             CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
00514             IINFO = 0
00515             COND = ULPINV
00516 *
00517             BIDIAG = .FALSE.
00518             IF( ITYPE.EQ.1 ) THEN
00519 *
00520 *              Zero matrix
00521 *
00522                IINFO = 0
00523 *
00524             ELSE IF( ITYPE.EQ.2 ) THEN
00525 *
00526 *              Identity
00527 *
00528                DO 80 JCOL = 1, MNMIN
00529                   A( JCOL, JCOL ) = ANORM
00530    80          CONTINUE
00531 *
00532             ELSE IF( ITYPE.EQ.4 ) THEN
00533 *
00534 *              Diagonal Matrix, [Eigen]values Specified
00535 *
00536                CALL SLATMS( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, IMODE,
00537      $                      COND, ANORM, 0, 0, 'N', A, LDA,
00538      $                      WORK( MNMIN+1 ), IINFO )
00539 *
00540             ELSE IF( ITYPE.EQ.5 ) THEN
00541 *
00542 *              Symmetric, eigenvalues specified
00543 *
00544                CALL SLATMS( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, IMODE,
00545      $                      COND, ANORM, M, N, 'N', A, LDA,
00546      $                      WORK( MNMIN+1 ), IINFO )
00547 *
00548             ELSE IF( ITYPE.EQ.6 ) THEN
00549 *
00550 *              Nonsymmetric, singular values specified
00551 *
00552                CALL SLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
00553      $                      ANORM, M, N, 'N', A, LDA, WORK( MNMIN+1 ),
00554      $                      IINFO )
00555 *
00556             ELSE IF( ITYPE.EQ.7 ) THEN
00557 *
00558 *              Diagonal, random entries
00559 *
00560                CALL SLATMR( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, 6, ONE,
00561      $                      ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
00562      $                      WORK( 2*MNMIN+1 ), 1, ONE, 'N', IWORK, 0, 0,
00563      $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
00564 *
00565             ELSE IF( ITYPE.EQ.8 ) THEN
00566 *
00567 *              Symmetric, random entries
00568 *
00569                CALL SLATMR( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, 6, ONE,
00570      $                      ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
00571      $                      WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
00572      $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
00573 *
00574             ELSE IF( ITYPE.EQ.9 ) THEN
00575 *
00576 *              Nonsymmetric, random entries
00577 *
00578                CALL SLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
00579      $                      'T', 'N', WORK( MNMIN+1 ), 1, ONE,
00580      $                      WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
00581      $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
00582 *
00583             ELSE IF( ITYPE.EQ.10 ) THEN
00584 *
00585 *              Bidiagonal, random entries
00586 *
00587                TEMP1 = -TWO*LOG( ULP )
00588                DO 90 J = 1, MNMIN
00589                   BD( J ) = EXP( TEMP1*SLARND( 2, ISEED ) )
00590                   IF( J.LT.MNMIN )
00591      $               BE( J ) = EXP( TEMP1*SLARND( 2, ISEED ) )
00592    90          CONTINUE
00593 *
00594                IINFO = 0
00595                BIDIAG = .TRUE.
00596                IF( M.GE.N ) THEN
00597                   UPLO = 'U'
00598                ELSE
00599                   UPLO = 'L'
00600                END IF
00601             ELSE
00602                IINFO = 1
00603             END IF
00604 *
00605             IF( IINFO.EQ.0 ) THEN
00606 *
00607 *              Generate Right-Hand Side
00608 *
00609                IF( BIDIAG ) THEN
00610                   CALL SLATMR( MNMIN, NRHS, 'S', ISEED, 'N', WORK, 6,
00611      $                         ONE, ONE, 'T', 'N', WORK( MNMIN+1 ), 1,
00612      $                         ONE, WORK( 2*MNMIN+1 ), 1, ONE, 'N',
00613      $                         IWORK, MNMIN, NRHS, ZERO, ONE, 'NO', Y,
00614      $                         LDX, IWORK, IINFO )
00615                ELSE
00616                   CALL SLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
00617      $                         ONE, 'T', 'N', WORK( M+1 ), 1, ONE,
00618      $                         WORK( 2*M+1 ), 1, ONE, 'N', IWORK, M,
00619      $                         NRHS, ZERO, ONE, 'NO', X, LDX, IWORK,
00620      $                         IINFO )
00621                END IF
00622             END IF
00623 *
00624 *           Error Exit
00625 *
00626             IF( IINFO.NE.0 ) THEN
00627                WRITE( NOUT, FMT = 9998 )'Generator', IINFO, M, N,
00628      $            JTYPE, IOLDSD
00629                INFO = ABS( IINFO )
00630                RETURN
00631             END IF
00632 *
00633   100       CONTINUE
00634 *
00635 *           Call SGEBRD and SORGBR to compute B, Q, and P, do tests.
00636 *
00637             IF( .NOT.BIDIAG ) THEN
00638 *
00639 *              Compute transformations to reduce A to bidiagonal form:
00640 *              B := Q' * A * P.
00641 *
00642                CALL SLACPY( ' ', M, N, A, LDA, Q, LDQ )
00643                CALL SGEBRD( M, N, Q, LDQ, BD, BE, WORK, WORK( MNMIN+1 ),
00644      $                      WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
00645 *
00646 *              Check error code from SGEBRD.
00647 *
00648                IF( IINFO.NE.0 ) THEN
00649                   WRITE( NOUT, FMT = 9998 )'SGEBRD', IINFO, M, N,
00650      $               JTYPE, IOLDSD
00651                   INFO = ABS( IINFO )
00652                   RETURN
00653                END IF
00654 *
00655                CALL SLACPY( ' ', M, N, Q, LDQ, PT, LDPT )
00656                IF( M.GE.N ) THEN
00657                   UPLO = 'U'
00658                ELSE
00659                   UPLO = 'L'
00660                END IF
00661 *
00662 *              Generate Q
00663 *
00664                MQ = M
00665                IF( NRHS.LE.0 )
00666      $            MQ = MNMIN
00667                CALL SORGBR( 'Q', M, MQ, N, Q, LDQ, WORK,
00668      $                      WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
00669 *
00670 *              Check error code from SORGBR.
00671 *
00672                IF( IINFO.NE.0 ) THEN
00673                   WRITE( NOUT, FMT = 9998 )'SORGBR(Q)', IINFO, M, N,
00674      $               JTYPE, IOLDSD
00675                   INFO = ABS( IINFO )
00676                   RETURN
00677                END IF
00678 *
00679 *              Generate P'
00680 *
00681                CALL SORGBR( 'P', MNMIN, N, M, PT, LDPT, WORK( MNMIN+1 ),
00682      $                      WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
00683 *
00684 *              Check error code from SORGBR.
00685 *
00686                IF( IINFO.NE.0 ) THEN
00687                   WRITE( NOUT, FMT = 9998 )'SORGBR(P)', IINFO, M, N,
00688      $               JTYPE, IOLDSD
00689                   INFO = ABS( IINFO )
00690                   RETURN
00691                END IF
00692 *
00693 *              Apply Q' to an M by NRHS matrix X:  Y := Q' * X.
00694 *
00695                CALL SGEMM( 'Transpose', 'No transpose', M, NRHS, M, ONE,
00696      $                     Q, LDQ, X, LDX, ZERO, Y, LDX )
00697 *
00698 *              Test 1:  Check the decomposition A := Q * B * PT
00699 *                   2:  Check the orthogonality of Q
00700 *                   3:  Check the orthogonality of PT
00701 *
00702                CALL SBDT01( M, N, 1, A, LDA, Q, LDQ, BD, BE, PT, LDPT,
00703      $                      WORK, RESULT( 1 ) )
00704                CALL SORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
00705      $                      RESULT( 2 ) )
00706                CALL SORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
00707      $                      RESULT( 3 ) )
00708             END IF
00709 *
00710 *           Use SBDSQR to form the SVD of the bidiagonal matrix B:
00711 *           B := U * S1 * VT, and compute Z = U' * Y.
00712 *
00713             CALL SCOPY( MNMIN, BD, 1, S1, 1 )
00714             IF( MNMIN.GT.0 )
00715      $         CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
00716             CALL SLACPY( ' ', M, NRHS, Y, LDX, Z, LDX )
00717             CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
00718             CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
00719 *
00720             CALL SBDSQR( UPLO, MNMIN, MNMIN, MNMIN, NRHS, S1, WORK, VT,
00721      $                   LDPT, U, LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
00722 *
00723 *           Check error code from SBDSQR.
00724 *
00725             IF( IINFO.NE.0 ) THEN
00726                WRITE( NOUT, FMT = 9998 )'SBDSQR(vects)', IINFO, M, N,
00727      $            JTYPE, IOLDSD
00728                INFO = ABS( IINFO )
00729                IF( IINFO.LT.0 ) THEN
00730                   RETURN
00731                ELSE
00732                   RESULT( 4 ) = ULPINV
00733                   GO TO 170
00734                END IF
00735             END IF
00736 *
00737 *           Use SBDSQR to compute only the singular values of the
00738 *           bidiagonal matrix B;  U, VT, and Z should not be modified.
00739 *
00740             CALL SCOPY( MNMIN, BD, 1, S2, 1 )
00741             IF( MNMIN.GT.0 )
00742      $         CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
00743 *
00744             CALL SBDSQR( UPLO, MNMIN, 0, 0, 0, S2, WORK, VT, LDPT, U,
00745      $                   LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
00746 *
00747 *           Check error code from SBDSQR.
00748 *
00749             IF( IINFO.NE.0 ) THEN
00750                WRITE( NOUT, FMT = 9998 )'SBDSQR(values)', IINFO, M, N,
00751      $            JTYPE, IOLDSD
00752                INFO = ABS( IINFO )
00753                IF( IINFO.LT.0 ) THEN
00754                   RETURN
00755                ELSE
00756                   RESULT( 9 ) = ULPINV
00757                   GO TO 170
00758                END IF
00759             END IF
00760 *
00761 *           Test 4:  Check the decomposition B := U * S1 * VT
00762 *                5:  Check the computation Z := U' * Y
00763 *                6:  Check the orthogonality of U
00764 *                7:  Check the orthogonality of VT
00765 *
00766             CALL SBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
00767      $                   WORK, RESULT( 4 ) )
00768             CALL SBDT02( MNMIN, NRHS, Y, LDX, Z, LDX, U, LDPT, WORK,
00769      $                   RESULT( 5 ) )
00770             CALL SORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
00771      $                   RESULT( 6 ) )
00772             CALL SORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
00773      $                   RESULT( 7 ) )
00774 *
00775 *           Test 8:  Check that the singular values are sorted in
00776 *                    non-increasing order and are non-negative
00777 *
00778             RESULT( 8 ) = ZERO
00779             DO 110 I = 1, MNMIN - 1
00780                IF( S1( I ).LT.S1( I+1 ) )
00781      $            RESULT( 8 ) = ULPINV
00782                IF( S1( I ).LT.ZERO )
00783      $            RESULT( 8 ) = ULPINV
00784   110       CONTINUE
00785             IF( MNMIN.GE.1 ) THEN
00786                IF( S1( MNMIN ).LT.ZERO )
00787      $            RESULT( 8 ) = ULPINV
00788             END IF
00789 *
00790 *           Test 9:  Compare SBDSQR with and without singular vectors
00791 *
00792             TEMP2 = ZERO
00793 *
00794             DO 120 J = 1, MNMIN
00795                TEMP1 = ABS( S1( J )-S2( J ) ) /
00796      $                 MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
00797      $                 ULP*MAX( ABS( S1( J ) ), ABS( S2( J ) ) ) )
00798                TEMP2 = MAX( TEMP1, TEMP2 )
00799   120       CONTINUE
00800 *
00801             RESULT( 9 ) = TEMP2
00802 *
00803 *           Test 10:  Sturm sequence test of singular values
00804 *                     Go up by factors of two until it succeeds
00805 *
00806             TEMP1 = THRESH*( HALF-ULP )
00807 *
00808             DO 130 J = 0, LOG2UI
00809 *               CALL SSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO )
00810                IF( IINFO.EQ.0 )
00811      $            GO TO 140
00812                TEMP1 = TEMP1*TWO
00813   130       CONTINUE
00814 *
00815   140       CONTINUE
00816             RESULT( 10 ) = TEMP1
00817 *
00818 *           Use SBDSQR to form the decomposition A := (QU) S (VT PT)
00819 *           from the bidiagonal form A := Q B PT.
00820 *
00821             IF( .NOT.BIDIAG ) THEN
00822                CALL SCOPY( MNMIN, BD, 1, S2, 1 )
00823                IF( MNMIN.GT.0 )
00824      $            CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
00825 *
00826                CALL SBDSQR( UPLO, MNMIN, N, M, NRHS, S2, WORK, PT, LDPT,
00827      $                      Q, LDQ, Y, LDX, WORK( MNMIN+1 ), IINFO )
00828 *
00829 *              Test 11:  Check the decomposition A := Q*U * S2 * VT*PT
00830 *                   12:  Check the computation Z := U' * Q' * X
00831 *                   13:  Check the orthogonality of Q*U
00832 *                   14:  Check the orthogonality of VT*PT
00833 *
00834                CALL SBDT01( M, N, 0, A, LDA, Q, LDQ, S2, DUMMA, PT,
00835      $                      LDPT, WORK, RESULT( 11 ) )
00836                CALL SBDT02( M, NRHS, X, LDX, Y, LDX, Q, LDQ, WORK,
00837      $                      RESULT( 12 ) )
00838                CALL SORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
00839      $                      RESULT( 13 ) )
00840                CALL SORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
00841      $                      RESULT( 14 ) )
00842             END IF
00843 *
00844 *           Use SBDSDC to form the SVD of the bidiagonal matrix B:
00845 *           B := U * S1 * VT
00846 *
00847             CALL SCOPY( MNMIN, BD, 1, S1, 1 )
00848             IF( MNMIN.GT.0 )
00849      $         CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
00850             CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
00851             CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
00852 *
00853             CALL SBDSDC( UPLO, 'I', MNMIN, S1, WORK, U, LDPT, VT, LDPT,
00854      $                   DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
00855 *
00856 *           Check error code from SBDSDC.
00857 *
00858             IF( IINFO.NE.0 ) THEN
00859                WRITE( NOUT, FMT = 9998 )'SBDSDC(vects)', IINFO, M, N,
00860      $            JTYPE, IOLDSD
00861                INFO = ABS( IINFO )
00862                IF( IINFO.LT.0 ) THEN
00863                   RETURN
00864                ELSE
00865                   RESULT( 15 ) = ULPINV
00866                   GO TO 170
00867                END IF
00868             END IF
00869 *
00870 *           Use SBDSDC to compute only the singular values of the
00871 *           bidiagonal matrix B;  U and VT should not be modified.
00872 *
00873             CALL SCOPY( MNMIN, BD, 1, S2, 1 )
00874             IF( MNMIN.GT.0 )
00875      $         CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
00876 *
00877             CALL SBDSDC( UPLO, 'N', MNMIN, S2, WORK, DUM, 1, DUM, 1,
00878      $                   DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
00879 *
00880 *           Check error code from SBDSDC.
00881 *
00882             IF( IINFO.NE.0 ) THEN
00883                WRITE( NOUT, FMT = 9998 )'SBDSDC(values)', IINFO, M, N,
00884      $            JTYPE, IOLDSD
00885                INFO = ABS( IINFO )
00886                IF( IINFO.LT.0 ) THEN
00887                   RETURN
00888                ELSE
00889                   RESULT( 18 ) = ULPINV
00890                   GO TO 170
00891                END IF
00892             END IF
00893 *
00894 *           Test 15:  Check the decomposition B := U * S1 * VT
00895 *                16:  Check the orthogonality of U
00896 *                17:  Check the orthogonality of VT
00897 *
00898             CALL SBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
00899      $                   WORK, RESULT( 15 ) )
00900             CALL SORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
00901      $                   RESULT( 16 ) )
00902             CALL SORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
00903      $                   RESULT( 17 ) )
00904 *
00905 *           Test 18:  Check that the singular values are sorted in
00906 *                     non-increasing order and are non-negative
00907 *
00908             RESULT( 18 ) = ZERO
00909             DO 150 I = 1, MNMIN - 1
00910                IF( S1( I ).LT.S1( I+1 ) )
00911      $            RESULT( 18 ) = ULPINV
00912                IF( S1( I ).LT.ZERO )
00913      $            RESULT( 18 ) = ULPINV
00914   150       CONTINUE
00915             IF( MNMIN.GE.1 ) THEN
00916                IF( S1( MNMIN ).LT.ZERO )
00917      $            RESULT( 18 ) = ULPINV
00918             END IF
00919 *
00920 *           Test 19:  Compare SBDSQR with and without singular vectors
00921 *
00922             TEMP2 = ZERO
00923 *
00924             DO 160 J = 1, MNMIN
00925                TEMP1 = ABS( S1( J )-S2( J ) ) /
00926      $                 MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
00927      $                 ULP*MAX( ABS( S1( 1 ) ), ABS( S2( 1 ) ) ) )
00928                TEMP2 = MAX( TEMP1, TEMP2 )
00929   160       CONTINUE
00930 *
00931             RESULT( 19 ) = TEMP2
00932 *
00933 *           End of Loop -- Check for RESULT(j) > THRESH
00934 *
00935   170       CONTINUE
00936             DO 180 J = 1, 19
00937                IF( RESULT( J ).GE.THRESH ) THEN
00938                   IF( NFAIL.EQ.0 )
00939      $               CALL SLAHD2( NOUT, PATH )
00940                   WRITE( NOUT, FMT = 9999 )M, N, JTYPE, IOLDSD, J,
00941      $               RESULT( J )
00942                   NFAIL = NFAIL + 1
00943                END IF
00944   180       CONTINUE
00945             IF( .NOT.BIDIAG ) THEN
00946                NTEST = NTEST + 19
00947             ELSE
00948                NTEST = NTEST + 5
00949             END IF
00950 *
00951   190    CONTINUE
00952   200 CONTINUE
00953 *
00954 *     Summary
00955 *
00956       CALL ALASUM( PATH, NOUT, NFAIL, NTEST, 0 )
00957 *
00958       RETURN
00959 *
00960 *     End of SCHKBD
00961 *
00962  9999 FORMAT( ' M=', I5, ', N=', I5, ', type ', I2, ', seed=',
00963      $      4( I4, ',' ), ' test(', I2, ')=', G11.4 )
00964  9998 FORMAT( ' SCHKBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
00965      $      I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
00966      $      I5, ')' )
00967 *
00968       END