LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dqrt15.f
Go to the documentation of this file.
00001 *> \brief \b DQRT15
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 DQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
00012 *                          RANK, NORMA, NORMB, ISEED, WORK, LWORK )
00013 * 
00014 *       .. Scalar Arguments ..
00015 *       INTEGER            LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
00016 *       DOUBLE PRECISION   NORMA, NORMB
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       INTEGER            ISEED( 4 )
00020 *       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
00021 *       ..
00022 *  
00023 *
00024 *> \par Purpose:
00025 *  =============
00026 *>
00027 *> \verbatim
00028 *>
00029 *> DQRT15 generates a matrix with full or deficient rank and of various
00030 *> norms.
00031 *> \endverbatim
00032 *
00033 *  Arguments:
00034 *  ==========
00035 *
00036 *> \param[in] SCALE
00037 *> \verbatim
00038 *>          SCALE is INTEGER
00039 *>          SCALE = 1: normally scaled matrix
00040 *>          SCALE = 2: matrix scaled up
00041 *>          SCALE = 3: matrix scaled down
00042 *> \endverbatim
00043 *>
00044 *> \param[in] RKSEL
00045 *> \verbatim
00046 *>          RKSEL is INTEGER
00047 *>          RKSEL = 1: full rank matrix
00048 *>          RKSEL = 2: rank-deficient matrix
00049 *> \endverbatim
00050 *>
00051 *> \param[in] M
00052 *> \verbatim
00053 *>          M is INTEGER
00054 *>          The number of rows of the matrix A.
00055 *> \endverbatim
00056 *>
00057 *> \param[in] N
00058 *> \verbatim
00059 *>          N is INTEGER
00060 *>          The number of columns of A.
00061 *> \endverbatim
00062 *>
00063 *> \param[in] NRHS
00064 *> \verbatim
00065 *>          NRHS is INTEGER
00066 *>          The number of columns of B.
00067 *> \endverbatim
00068 *>
00069 *> \param[out] A
00070 *> \verbatim
00071 *>          A is DOUBLE PRECISION array, dimension (LDA,N)
00072 *>          The M-by-N matrix A.
00073 *> \endverbatim
00074 *>
00075 *> \param[in] LDA
00076 *> \verbatim
00077 *>          LDA is INTEGER
00078 *>          The leading dimension of the array A.
00079 *> \endverbatim
00080 *>
00081 *> \param[out] B
00082 *> \verbatim
00083 *>          B is DOUBLE PRECISION array, dimension (LDB, NRHS)
00084 *>          A matrix that is in the range space of matrix A.
00085 *> \endverbatim
00086 *>
00087 *> \param[in] LDB
00088 *> \verbatim
00089 *>          LDB is INTEGER
00090 *>          The leading dimension of the array B.
00091 *> \endverbatim
00092 *>
00093 *> \param[out] S
00094 *> \verbatim
00095 *>          S is DOUBLE PRECISION array, dimension MIN(M,N)
00096 *>          Singular values of A.
00097 *> \endverbatim
00098 *>
00099 *> \param[out] RANK
00100 *> \verbatim
00101 *>          RANK is INTEGER
00102 *>          number of nonzero singular values of A.
00103 *> \endverbatim
00104 *>
00105 *> \param[out] NORMA
00106 *> \verbatim
00107 *>          NORMA is DOUBLE PRECISION
00108 *>          one-norm of A.
00109 *> \endverbatim
00110 *>
00111 *> \param[out] NORMB
00112 *> \verbatim
00113 *>          NORMB is DOUBLE PRECISION
00114 *>          one-norm of B.
00115 *> \endverbatim
00116 *>
00117 *> \param[in,out] ISEED
00118 *> \verbatim
00119 *>          ISEED is integer array, dimension (4)
00120 *>          seed for random number generator.
00121 *> \endverbatim
00122 *>
00123 *> \param[out] WORK
00124 *> \verbatim
00125 *>          WORK is DOUBLE PRECISION array, dimension (LWORK)
00126 *> \endverbatim
00127 *>
00128 *> \param[in] LWORK
00129 *> \verbatim
00130 *>          LWORK is INTEGER
00131 *>          length of work space required.
00132 *>          LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
00133 *> \endverbatim
00134 *
00135 *  Authors:
00136 *  ========
00137 *
00138 *> \author Univ. of Tennessee 
00139 *> \author Univ. of California Berkeley 
00140 *> \author Univ. of Colorado Denver 
00141 *> \author NAG Ltd. 
00142 *
00143 *> \date November 2011
00144 *
00145 *> \ingroup double_lin
00146 *
00147 *  =====================================================================
00148       SUBROUTINE DQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
00149      $                   RANK, NORMA, NORMB, ISEED, WORK, LWORK )
00150 *
00151 *  -- LAPACK test routine (version 3.4.0) --
00152 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00153 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00154 *     November 2011
00155 *
00156 *     .. Scalar Arguments ..
00157       INTEGER            LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
00158       DOUBLE PRECISION   NORMA, NORMB
00159 *     ..
00160 *     .. Array Arguments ..
00161       INTEGER            ISEED( 4 )
00162       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
00163 *     ..
00164 *
00165 *  =====================================================================
00166 *
00167 *     .. Parameters ..
00168       DOUBLE PRECISION   ZERO, ONE, TWO, SVMIN
00169       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
00170      $                   SVMIN = 0.1D0 )
00171 *     ..
00172 *     .. Local Scalars ..
00173       INTEGER            INFO, J, MN
00174       DOUBLE PRECISION   BIGNUM, EPS, SMLNUM, TEMP
00175 *     ..
00176 *     .. Local Arrays ..
00177       DOUBLE PRECISION   DUMMY( 1 )
00178 *     ..
00179 *     .. External Functions ..
00180       DOUBLE PRECISION   DASUM, DLAMCH, DLANGE, DLARND, DNRM2
00181       EXTERNAL           DASUM, DLAMCH, DLANGE, DLARND, DNRM2
00182 *     ..
00183 *     .. External Subroutines ..
00184       EXTERNAL           DGEMM, DLAORD, DLARF, DLARNV, DLAROR, DLASCL,
00185      $                   DLASET, DSCAL, XERBLA
00186 *     ..
00187 *     .. Intrinsic Functions ..
00188       INTRINSIC          ABS, MAX, MIN
00189 *     ..
00190 *     .. Executable Statements ..
00191 *
00192       MN = MIN( M, N )
00193       IF( LWORK.LT.MAX( M+MN, MN*NRHS, 2*N+M ) ) THEN
00194          CALL XERBLA( 'DQRT15', 16 )
00195          RETURN
00196       END IF
00197 *
00198       SMLNUM = DLAMCH( 'Safe minimum' )
00199       BIGNUM = ONE / SMLNUM
00200       EPS = DLAMCH( 'Epsilon' )
00201       SMLNUM = ( SMLNUM / EPS ) / EPS
00202       BIGNUM = ONE / SMLNUM
00203 *
00204 *     Determine rank and (unscaled) singular values
00205 *
00206       IF( RKSEL.EQ.1 ) THEN
00207          RANK = MN
00208       ELSE IF( RKSEL.EQ.2 ) THEN
00209          RANK = ( 3*MN ) / 4
00210          DO 10 J = RANK + 1, MN
00211             S( J ) = ZERO
00212    10    CONTINUE
00213       ELSE
00214          CALL XERBLA( 'DQRT15', 2 )
00215       END IF
00216 *
00217       IF( RANK.GT.0 ) THEN
00218 *
00219 *        Nontrivial case
00220 *
00221          S( 1 ) = ONE
00222          DO 30 J = 2, RANK
00223    20       CONTINUE
00224             TEMP = DLARND( 1, ISEED )
00225             IF( TEMP.GT.SVMIN ) THEN
00226                S( J ) = ABS( TEMP )
00227             ELSE
00228                GO TO 20
00229             END IF
00230    30    CONTINUE
00231          CALL DLAORD( 'Decreasing', RANK, S, 1 )
00232 *
00233 *        Generate 'rank' columns of a random orthogonal matrix in A
00234 *
00235          CALL DLARNV( 2, ISEED, M, WORK )
00236          CALL DSCAL( M, ONE / DNRM2( M, WORK, 1 ), WORK, 1 )
00237          CALL DLASET( 'Full', M, RANK, ZERO, ONE, A, LDA )
00238          CALL DLARF( 'Left', M, RANK, WORK, 1, TWO, A, LDA,
00239      $               WORK( M+1 ) )
00240 *
00241 *        workspace used: m+mn
00242 *
00243 *        Generate consistent rhs in the range space of A
00244 *
00245          CALL DLARNV( 2, ISEED, RANK*NRHS, WORK )
00246          CALL DGEMM( 'No transpose', 'No transpose', M, NRHS, RANK, ONE,
00247      $               A, LDA, WORK, RANK, ZERO, B, LDB )
00248 *
00249 *        work space used: <= mn *nrhs
00250 *
00251 *        generate (unscaled) matrix A
00252 *
00253          DO 40 J = 1, RANK
00254             CALL DSCAL( M, S( J ), A( 1, J ), 1 )
00255    40    CONTINUE
00256          IF( RANK.LT.N )
00257      $      CALL DLASET( 'Full', M, N-RANK, ZERO, ZERO, A( 1, RANK+1 ),
00258      $                   LDA )
00259          CALL DLAROR( 'Right', 'No initialization', M, N, A, LDA, ISEED,
00260      $                WORK, INFO )
00261 *
00262       ELSE
00263 *
00264 *        work space used 2*n+m
00265 *
00266 *        Generate null matrix and rhs
00267 *
00268          DO 50 J = 1, MN
00269             S( J ) = ZERO
00270    50    CONTINUE
00271          CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
00272          CALL DLASET( 'Full', M, NRHS, ZERO, ZERO, B, LDB )
00273 *
00274       END IF
00275 *
00276 *     Scale the matrix
00277 *
00278       IF( SCALE.NE.1 ) THEN
00279          NORMA = DLANGE( 'Max', M, N, A, LDA, DUMMY )
00280          IF( NORMA.NE.ZERO ) THEN
00281             IF( SCALE.EQ.2 ) THEN
00282 *
00283 *              matrix scaled up
00284 *
00285                CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A,
00286      $                      LDA, INFO )
00287                CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S,
00288      $                      MN, INFO )
00289                CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, NRHS, B,
00290      $                      LDB, INFO )
00291             ELSE IF( SCALE.EQ.3 ) THEN
00292 *
00293 *              matrix scaled down
00294 *
00295                CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A,
00296      $                      LDA, INFO )
00297                CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S,
00298      $                      MN, INFO )
00299                CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B,
00300      $                      LDB, INFO )
00301             ELSE
00302                CALL XERBLA( 'DQRT15', 1 )
00303                RETURN
00304             END IF
00305          END IF
00306       END IF
00307 *
00308       NORMA = DASUM( MN, S, 1 )
00309       NORMB = DLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY )
00310 *
00311       RETURN
00312 *
00313 *     End of DQRT15
00314 *
00315       END
 All Files Functions