LAPACK 3.3.0

slarge.f

Go to the documentation of this file.
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
 All Files Functions