|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO ) 00002 * 00003 * -- LAPACK auxiliary test routine (version 3.1) 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * November 2006 00006 * 00007 * .. Scalar Arguments .. 00008 INTEGER INFO, LDA, N 00009 * .. 00010 * .. Array Arguments .. 00011 INTEGER ISEED( 4 ) 00012 REAL A( LDA, * ), WORK( * ) 00013 * .. 00014 * 00015 * Purpose 00016 * ======= 00017 * 00018 * SLARGE pre- and post-multiplies a real general n by n matrix A 00019 * with a random orthogonal matrix: A = U*D*U'. 00020 * 00021 * Arguments 00022 * ========= 00023 * 00024 * N (input) INTEGER 00025 * The order of the matrix A. N >= 0. 00026 * 00027 * A (input/output) REAL array, dimension (LDA,N) 00028 * On entry, the original n by n matrix A. 00029 * On exit, A is overwritten by U*A*U' for some random 00030 * orthogonal matrix U. 00031 * 00032 * LDA (input) INTEGER 00033 * The leading dimension of the array A. LDA >= N. 00034 * 00035 * ISEED (input/output) INTEGER array, dimension (4) 00036 * On entry, the seed of the random number generator; the array 00037 * elements must be between 0 and 4095, and ISEED(4) must be 00038 * odd. 00039 * On exit, the seed is updated. 00040 * 00041 * WORK (workspace) REAL array, dimension (2*N) 00042 * 00043 * INFO (output) INTEGER 00044 * = 0: successful exit 00045 * < 0: if INFO = -i, the i-th argument had an illegal value 00046 * 00047 * ===================================================================== 00048 * 00049 * .. Parameters .. 00050 REAL ZERO, ONE 00051 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 00052 * .. 00053 * .. Local Scalars .. 00054 INTEGER I 00055 REAL TAU, WA, WB, WN 00056 * .. 00057 * .. External Subroutines .. 00058 EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA 00059 * .. 00060 * .. Intrinsic Functions .. 00061 INTRINSIC MAX, SIGN 00062 * .. 00063 * .. External Functions .. 00064 REAL SNRM2 00065 EXTERNAL SNRM2 00066 * .. 00067 * .. Executable Statements .. 00068 * 00069 * Test the input arguments 00070 * 00071 INFO = 0 00072 IF( N.LT.0 ) THEN 00073 INFO = -1 00074 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00075 INFO = -3 00076 END IF 00077 IF( INFO.LT.0 ) THEN 00078 CALL XERBLA( 'SLARGE', -INFO ) 00079 RETURN 00080 END IF 00081 * 00082 * pre- and post-multiply A by random orthogonal matrix 00083 * 00084 DO 10 I = N, 1, -1 00085 * 00086 * generate random reflection 00087 * 00088 CALL SLARNV( 3, ISEED, N-I+1, WORK ) 00089 WN = SNRM2( N-I+1, WORK, 1 ) 00090 WA = SIGN( WN, WORK( 1 ) ) 00091 IF( WN.EQ.ZERO ) THEN 00092 TAU = ZERO 00093 ELSE 00094 WB = WORK( 1 ) + WA 00095 CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) 00096 WORK( 1 ) = ONE 00097 TAU = WB / WA 00098 END IF 00099 * 00100 * multiply A(i:n,1:n) by random reflection from the left 00101 * 00102 CALL SGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK, 00103 $ 1, ZERO, WORK( N+1 ), 1 ) 00104 CALL SGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ), 00105 $ LDA ) 00106 * 00107 * multiply A(1:n,i:n) by random reflection from the right 00108 * 00109 CALL SGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA, 00110 $ WORK, 1, ZERO, WORK( N+1 ), 1 ) 00111 CALL SGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ), 00112 $ LDA ) 00113 10 CONTINUE 00114 RETURN 00115 * 00116 * End of SLARGE 00117 * 00118 END
1.7.3 
