1 SUBROUTINE ZQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, 2 $ RANK, NORMA, NORMB, ISEED, WORK, LWORK ) 3* 4* -- LAPACK test routine (version 3.0) -- 5* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 6* Courant Institute, Argonne National Lab, and Rice University 7* September 30, 1994 8* 9* .. Scalar Arguments .. 10 INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE 11 DOUBLE PRECISION NORMA, NORMB 12* .. 13* .. Array Arguments .. 14 INTEGER ISEED( 4 ) 15 DOUBLE PRECISION S( * ) 16 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( LWORK ) 17* .. 18* 19* Purpose 20* ======= 21* 22* ZQRT15 generates a matrix with full or deficient rank and of various 23* norms. 24* 25* Arguments 26* ========= 27* 28* SCALE (input) INTEGER 29* SCALE = 1: normally scaled matrix 30* SCALE = 2: matrix scaled up 31* SCALE = 3: matrix scaled down 32* 33* RKSEL (input) INTEGER 34* RKSEL = 1: full rank matrix 35* RKSEL = 2: rank-deficient matrix 36* 37* M (input) INTEGER 38* The number of rows of the matrix A. 39* 40* N (input) INTEGER 41* The number of columns of A. 42* 43* NRHS (input) INTEGER 44* The number of columns of B. 45* 46* A (output) COMPLEX*16 array, dimension (LDA,N) 47* The M-by-N matrix A. 48* 49* LDA (input) INTEGER 50* The leading dimension of the array A. 51* 52* B (output) COMPLEX*16 array, dimension (LDB, NRHS) 53* A matrix that is in the range space of matrix A. 54* 55* LDB (input) INTEGER 56* The leading dimension of the array B. 57* 58* S (output) DOUBLE PRECISION array, dimension MIN(M,N) 59* Singular values of A. 60* 61* RANK (output) INTEGER 62* number of nonzero singular values of A. 63* 64* NORMA (output) DOUBLE PRECISION 65* one-norm norm of A. 66* 67* NORMB (output) DOUBLE PRECISION 68* one-norm norm of B. 69* 70* ISEED (input/output) integer array, dimension (4) 71* seed for random number generator. 72* 73* WORK (workspace) COMPLEX*16 array, dimension (LWORK) 74* 75* LWORK (input) INTEGER 76* length of work space required. 77* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) 78* 79* ===================================================================== 80* 81* .. Parameters .. 82 DOUBLE PRECISION ZERO, ONE, TWO, SVMIN 83 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, 84 $ SVMIN = 0.1D+0 ) 85 COMPLEX*16 CZERO, CONE 86 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), 87 $ CONE = ( 1.0D+0, 0.0D+0 ) ) 88* .. 89* .. Local Scalars .. 90 INTEGER INFO, J, MN 91 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP 92* .. 93* .. Local Arrays .. 94 DOUBLE PRECISION DUMMY( 1 ) 95* .. 96* .. External Functions .. 97 DOUBLE PRECISION DASUM, DLAMCH, DLARND, DZNRM2, ZLANGE 98 EXTERNAL DASUM, DLAMCH, DLARND, DZNRM2, ZLANGE 99* .. 100* .. External Subroutines .. 101 EXTERNAL DLABAD, DLAORD, DLASCL, XERBLA, ZDSCAL, ZGEMM, 102 $ ZLARF, ZLARNV, ZLAROR, ZLASCL, ZLASET 103* .. 104* .. Intrinsic Functions .. 105 INTRINSIC ABS, DCMPLX, MAX, MIN 106* .. 107* .. Executable Statements .. 108* 109 MN = MIN( M, N ) 110 IF( LWORK.LT.MAX( M+MN, MN*NRHS, 2*N+M ) ) THEN 111 CALL XERBLA( 'ZQRT15', 16 ) 112 RETURN 113 END IF 114* 115 SMLNUM = DLAMCH( 'Safe minimum' ) 116 BIGNUM = ONE / SMLNUM 117 CALL DLABAD( SMLNUM, BIGNUM ) 118 EPS = DLAMCH( 'Epsilon' ) 119 SMLNUM = ( SMLNUM / EPS ) / EPS 120 BIGNUM = ONE / SMLNUM 121* 122* Determine rank and (unscaled) singular values 123* 124 IF( RKSEL.EQ.1 ) THEN 125 RANK = MN 126 ELSE IF( RKSEL.EQ.2 ) THEN 127 RANK = ( 3*MN ) / 4 128 DO 10 J = RANK + 1, MN 129 S( J ) = ZERO 130 10 CONTINUE 131 ELSE 132 CALL XERBLA( 'ZQRT15', 2 ) 133 END IF 134* 135 IF( RANK.GT.0 ) THEN 136* 137* Nontrivial case 138* 139 S( 1 ) = ONE 140 DO 30 J = 2, RANK 141 20 CONTINUE 142 TEMP = DLARND( 1, ISEED ) 143 IF( TEMP.GT.SVMIN ) THEN 144 S( J ) = ABS( TEMP ) 145 ELSE 146 GO TO 20 147 END IF 148 30 CONTINUE 149 CALL DLAORD( 'Decreasing', RANK, S, 1 ) 150* 151* Generate 'rank' columns of a random orthogonal matrix in A 152* 153 CALL ZLARNV( 2, ISEED, M, WORK ) 154 CALL ZDSCAL( M, ONE / DZNRM2( M, WORK, 1 ), WORK, 1 ) 155 CALL ZLASET( 'Full', M, RANK, CZERO, CONE, A, LDA ) 156 CALL ZLARF( 'Left', M, RANK, WORK, 1, DCMPLX( TWO ), A, LDA, 157 $ WORK( M+1 ) ) 158* 159* workspace used: m+mn 160* 161* Generate consistent rhs in the range space of A 162* 163 CALL ZLARNV( 2, ISEED, RANK*NRHS, WORK ) 164 CALL ZGEMM( 'No transpose', 'No transpose', M, NRHS, RANK, 165 $ CONE, A, LDA, WORK, RANK, CZERO, B, LDB ) 166* 167* work space used: <= mn *nrhs 168* 169* generate (unscaled) matrix A 170* 171 DO 40 J = 1, RANK 172 CALL ZDSCAL( M, S( J ), A( 1, J ), 1 ) 173 40 CONTINUE 174 IF( RANK.LT.N ) 175 $ CALL ZLASET( 'Full', M, N-RANK, CZERO, CZERO, 176 $ A( 1, RANK+1 ), LDA ) 177 CALL ZLAROR( 'Right', 'No initialization', M, N, A, LDA, ISEED, 178 $ WORK, INFO ) 179* 180 ELSE 181* 182* work space used 2*n+m 183* 184* Generate null matrix and rhs 185* 186 DO 50 J = 1, MN 187 S( J ) = ZERO 188 50 CONTINUE 189 CALL ZLASET( 'Full', M, N, CZERO, CZERO, A, LDA ) 190 CALL ZLASET( 'Full', M, NRHS, CZERO, CZERO, B, LDB ) 191* 192 END IF 193* 194* Scale the matrix 195* 196 IF( SCALE.NE.1 ) THEN 197 NORMA = ZLANGE( 'Max', M, N, A, LDA, DUMMY ) 198 IF( NORMA.NE.ZERO ) THEN 199 IF( SCALE.EQ.2 ) THEN 200* 201* matrix scaled up 202* 203 CALL ZLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, 204 $ LDA, INFO ) 205 CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S, 206 $ MN, INFO ) 207 CALL ZLASCL( 'General', 0, 0, NORMA, BIGNUM, M, NRHS, B, 208 $ LDB, INFO ) 209 ELSE IF( SCALE.EQ.3 ) THEN 210* 211* matrix scaled down 212* 213 CALL ZLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, 214 $ LDA, INFO ) 215 CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S, 216 $ MN, INFO ) 217 CALL ZLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B, 218 $ LDB, INFO ) 219 ELSE 220 CALL XERBLA( 'ZQRT15', 1 ) 221 RETURN 222 END IF 223 END IF 224 END IF 225* 226 NORMA = DASUM( MN, S, 1 ) 227 NORMB = ZLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY ) 228* 229 RETURN 230* 231* End of ZQRT15 232* 233 END 234