00001 SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) 00002 * 00003 * -- LAPACK auxiliary routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER UPLO 00010 INTEGER INFO, LDA, N 00011 * .. 00012 * .. Array Arguments .. 00013 REAL A( LDA, * ) 00014 * .. 00015 * 00016 * Purpose 00017 * ======= 00018 * 00019 * SLAUU2 computes the product U * U' or L' * L, where the triangular 00020 * factor U or L is stored in the upper or lower triangular part of 00021 * the array A. 00022 * 00023 * If UPLO = 'U' or 'u' then the upper triangle of the result is stored, 00024 * overwriting the factor U in A. 00025 * If UPLO = 'L' or 'l' then the lower triangle of the result is stored, 00026 * overwriting the factor L in A. 00027 * 00028 * This is the unblocked form of the algorithm, calling Level 2 BLAS. 00029 * 00030 * Arguments 00031 * ========= 00032 * 00033 * UPLO (input) CHARACTER*1 00034 * Specifies whether the triangular factor stored in the array A 00035 * is upper or lower triangular: 00036 * = 'U': Upper triangular 00037 * = 'L': Lower triangular 00038 * 00039 * N (input) INTEGER 00040 * The order of the triangular factor U or L. N >= 0. 00041 * 00042 * A (input/output) REAL array, dimension (LDA,N) 00043 * On entry, the triangular factor U or L. 00044 * On exit, if UPLO = 'U', the upper triangle of A is 00045 * overwritten with the upper triangle of the product U * U'; 00046 * if UPLO = 'L', the lower triangle of A is overwritten with 00047 * the lower triangle of the product L' * L. 00048 * 00049 * LDA (input) INTEGER 00050 * The leading dimension of the array A. LDA >= max(1,N). 00051 * 00052 * INFO (output) INTEGER 00053 * = 0: successful exit 00054 * < 0: if INFO = -k, the k-th argument had an illegal value 00055 * 00056 * ===================================================================== 00057 * 00058 * .. Parameters .. 00059 REAL ONE 00060 PARAMETER ( ONE = 1.0E+0 ) 00061 * .. 00062 * .. Local Scalars .. 00063 LOGICAL UPPER 00064 INTEGER I 00065 REAL AII 00066 * .. 00067 * .. External Functions .. 00068 LOGICAL LSAME 00069 REAL SDOT 00070 EXTERNAL LSAME, SDOT 00071 * .. 00072 * .. External Subroutines .. 00073 EXTERNAL SGEMV, SSCAL, XERBLA 00074 * .. 00075 * .. Intrinsic Functions .. 00076 INTRINSIC MAX 00077 * .. 00078 * .. Executable Statements .. 00079 * 00080 * Test the input parameters. 00081 * 00082 INFO = 0 00083 UPPER = LSAME( UPLO, 'U' ) 00084 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00085 INFO = -1 00086 ELSE IF( N.LT.0 ) THEN 00087 INFO = -2 00088 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00089 INFO = -4 00090 END IF 00091 IF( INFO.NE.0 ) THEN 00092 CALL XERBLA( 'SLAUU2', -INFO ) 00093 RETURN 00094 END IF 00095 * 00096 * Quick return if possible 00097 * 00098 IF( N.EQ.0 ) 00099 $ RETURN 00100 * 00101 IF( UPPER ) THEN 00102 * 00103 * Compute the product U * U'. 00104 * 00105 DO 10 I = 1, N 00106 AII = A( I, I ) 00107 IF( I.LT.N ) THEN 00108 A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) 00109 CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), 00110 $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) 00111 ELSE 00112 CALL SSCAL( I, AII, A( 1, I ), 1 ) 00113 END IF 00114 10 CONTINUE 00115 * 00116 ELSE 00117 * 00118 * Compute the product L' * L. 00119 * 00120 DO 20 I = 1, N 00121 AII = A( I, I ) 00122 IF( I.LT.N ) THEN 00123 A( I, I ) = SDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) 00124 CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, 00125 $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) 00126 ELSE 00127 CALL SSCAL( I, AII, A( I, 1 ), LDA ) 00128 END IF 00129 20 CONTINUE 00130 END IF 00131 * 00132 RETURN 00133 * 00134 * End of SLAUU2 00135 * 00136 END
1.7.2