![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SQRT15 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 SQRT15( 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 * REAL NORMA, NORMB 00017 * .. 00018 * .. Array Arguments .. 00019 * INTEGER ISEED( 4 ) 00020 * REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK ) 00021 * .. 00022 * 00023 * 00024 *> \par Purpose: 00025 * ============= 00026 *> 00027 *> \verbatim 00028 *> 00029 *> SQRT15 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 REAL 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 REAL 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 REAL 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 REAL 00108 *> one-norm of A. 00109 *> \endverbatim 00110 *> 00111 *> \param[out] NORMB 00112 *> \verbatim 00113 *> NORMB is REAL 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 REAL 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 single_lin 00146 * 00147 * ===================================================================== 00148 SUBROUTINE SQRT15( 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 REAL NORMA, NORMB 00159 * .. 00160 * .. Array Arguments .. 00161 INTEGER ISEED( 4 ) 00162 REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK ) 00163 * .. 00164 * 00165 * ===================================================================== 00166 * 00167 * .. Parameters .. 00168 REAL ZERO, ONE, TWO, SVMIN 00169 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, 00170 $ SVMIN = 0.1E0 ) 00171 * .. 00172 * .. Local Scalars .. 00173 INTEGER INFO, J, MN 00174 REAL BIGNUM, EPS, SMLNUM, TEMP 00175 * .. 00176 * .. Local Arrays .. 00177 REAL DUMMY( 1 ) 00178 * .. 00179 * .. External Functions .. 00180 REAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2 00181 EXTERNAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2 00182 * .. 00183 * .. External Subroutines .. 00184 EXTERNAL SGEMM, SLAORD, SLARF, SLARNV, SLAROR, SLASCL, 00185 $ SLASET, SSCAL, 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( 'SQRT15', 16 ) 00195 RETURN 00196 END IF 00197 * 00198 SMLNUM = SLAMCH( 'Safe minimum' ) 00199 BIGNUM = ONE / SMLNUM 00200 EPS = SLAMCH( '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( 'SQRT15', 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 = SLARND( 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 SLAORD( 'Decreasing', RANK, S, 1 ) 00232 * 00233 * Generate 'rank' columns of a random orthogonal matrix in A 00234 * 00235 CALL SLARNV( 2, ISEED, M, WORK ) 00236 CALL SSCAL( M, ONE / SNRM2( M, WORK, 1 ), WORK, 1 ) 00237 CALL SLASET( 'Full', M, RANK, ZERO, ONE, A, LDA ) 00238 CALL SLARF( '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 SLARNV( 2, ISEED, RANK*NRHS, WORK ) 00246 CALL SGEMM( '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 SSCAL( M, S( J ), A( 1, J ), 1 ) 00255 40 CONTINUE 00256 IF( RANK.LT.N ) 00257 $ CALL SLASET( 'Full', M, N-RANK, ZERO, ZERO, A( 1, RANK+1 ), 00258 $ LDA ) 00259 CALL SLAROR( '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 SLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) 00272 CALL SLASET( '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 = SLANGE( '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 SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, 00286 $ LDA, INFO ) 00287 CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S, 00288 $ MN, INFO ) 00289 CALL SLASCL( '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 SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, 00296 $ LDA, INFO ) 00297 CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S, 00298 $ MN, INFO ) 00299 CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B, 00300 $ LDB, INFO ) 00301 ELSE 00302 CALL XERBLA( 'SQRT15', 1 ) 00303 RETURN 00304 END IF 00305 END IF 00306 END IF 00307 * 00308 NORMA = SASUM( MN, S, 1 ) 00309 NORMB = SLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY ) 00310 * 00311 RETURN 00312 * 00313 * End of SQRT15 00314 * 00315 END