Annotation of rpl/lapack/lapack/dlauu2.f, revision 1.8
1.1 bertrand 1: SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )
2: *
1.8 ! bertrand 3: * -- LAPACK auxiliary routine (version 3.3.1) --
1.1 bertrand 4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.8 ! bertrand 6: * -- April 2011 --
1.1 bertrand 7: *
8: * .. Scalar Arguments ..
9: CHARACTER UPLO
10: INTEGER INFO, LDA, N
11: * ..
12: * .. Array Arguments ..
13: DOUBLE PRECISION A( LDA, * )
14: * ..
15: *
16: * Purpose
17: * =======
18: *
1.8 ! bertrand 19: * DLAUU2 computes the product U * U**T or L**T * L, where the triangular
1.1 bertrand 20: * factor U or L is stored in the upper or lower triangular part of
21: * the array A.
22: *
23: * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
24: * overwriting the factor U in A.
25: * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
26: * overwriting the factor L in A.
27: *
28: * This is the unblocked form of the algorithm, calling Level 2 BLAS.
29: *
30: * Arguments
31: * =========
32: *
33: * UPLO (input) CHARACTER*1
34: * Specifies whether the triangular factor stored in the array A
35: * is upper or lower triangular:
36: * = 'U': Upper triangular
37: * = 'L': Lower triangular
38: *
39: * N (input) INTEGER
40: * The order of the triangular factor U or L. N >= 0.
41: *
42: * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
43: * On entry, the triangular factor U or L.
44: * On exit, if UPLO = 'U', the upper triangle of A is
1.8 ! bertrand 45: * overwritten with the upper triangle of the product U * U**T;
1.1 bertrand 46: * if UPLO = 'L', the lower triangle of A is overwritten with
1.8 ! bertrand 47: * the lower triangle of the product L**T * L.
1.1 bertrand 48: *
49: * LDA (input) INTEGER
50: * The leading dimension of the array A. LDA >= max(1,N).
51: *
52: * INFO (output) INTEGER
53: * = 0: successful exit
54: * < 0: if INFO = -k, the k-th argument had an illegal value
55: *
56: * =====================================================================
57: *
58: * .. Parameters ..
59: DOUBLE PRECISION ONE
60: PARAMETER ( ONE = 1.0D+0 )
61: * ..
62: * .. Local Scalars ..
63: LOGICAL UPPER
64: INTEGER I
65: DOUBLE PRECISION AII
66: * ..
67: * .. External Functions ..
68: LOGICAL LSAME
69: DOUBLE PRECISION DDOT
70: EXTERNAL LSAME, DDOT
71: * ..
72: * .. External Subroutines ..
73: EXTERNAL DGEMV, DSCAL, XERBLA
74: * ..
75: * .. Intrinsic Functions ..
76: INTRINSIC MAX
77: * ..
78: * .. Executable Statements ..
79: *
80: * Test the input parameters.
81: *
82: INFO = 0
83: UPPER = LSAME( UPLO, 'U' )
84: IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
85: INFO = -1
86: ELSE IF( N.LT.0 ) THEN
87: INFO = -2
88: ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
89: INFO = -4
90: END IF
91: IF( INFO.NE.0 ) THEN
92: CALL XERBLA( 'DLAUU2', -INFO )
93: RETURN
94: END IF
95: *
96: * Quick return if possible
97: *
98: IF( N.EQ.0 )
99: $ RETURN
100: *
101: IF( UPPER ) THEN
102: *
1.8 ! bertrand 103: * Compute the product U * U**T.
1.1 bertrand 104: *
105: DO 10 I = 1, N
106: AII = A( I, I )
107: IF( I.LT.N ) THEN
108: A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
109: CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
110: $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
111: ELSE
112: CALL DSCAL( I, AII, A( 1, I ), 1 )
113: END IF
114: 10 CONTINUE
115: *
116: ELSE
117: *
1.8 ! bertrand 118: * Compute the product L**T * L.
1.1 bertrand 119: *
120: DO 20 I = 1, N
121: AII = A( I, I )
122: IF( I.LT.N ) THEN
123: A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
124: CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
125: $ A( I+1, I ), 1, AII, A( I, 1 ), LDA )
126: ELSE
127: CALL DSCAL( I, AII, A( I, 1 ), LDA )
128: END IF
129: 20 CONTINUE
130: END IF
131: *
132: RETURN
133: *
134: * End of DLAUU2
135: *
136: END
CVSweb interface <joel.bertrand@systella.fr>