|
5340
|
1 SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) |
|
|
2 * |
|
|
3 * -- LAPACK auxiliary routine (version 3.0) -- |
|
|
4 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
|
|
5 * Courant Institute, Argonne National Lab, and Rice University |
|
|
6 * September 30, 1994 |
|
|
7 * |
|
|
8 * .. Scalar Arguments .. |
|
|
9 CHARACTER UPLO |
|
|
10 INTEGER INFO, LDA, N |
|
|
11 * .. |
|
|
12 * .. Array Arguments .. |
|
|
13 COMPLEX*16 A( LDA, * ) |
|
|
14 * .. |
|
|
15 * |
|
|
16 * Purpose |
|
|
17 * ======= |
|
|
18 * |
|
|
19 * ZLAUU2 computes the product U * U' or L' * L, where the triangular |
|
|
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) COMPLEX*16 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 |
|
|
45 * overwritten with the upper triangle of the product U * U'; |
|
|
46 * if UPLO = 'L', the lower triangle of A is overwritten with |
|
|
47 * the lower triangle of the product L' * L. |
|
|
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 COMPLEX*16 ONE |
|
|
60 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) |
|
|
61 * .. |
|
|
62 * .. Local Scalars .. |
|
|
63 LOGICAL UPPER |
|
|
64 INTEGER I |
|
|
65 DOUBLE PRECISION AII |
|
|
66 * .. |
|
|
67 * .. External Functions .. |
|
|
68 LOGICAL LSAME |
|
|
69 COMPLEX*16 ZDOTC |
|
|
70 EXTERNAL LSAME, ZDOTC |
|
|
71 * .. |
|
|
72 * .. External Subroutines .. |
|
|
73 EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV |
|
|
74 * .. |
|
|
75 * .. Intrinsic Functions .. |
|
|
76 INTRINSIC DBLE, DCMPLX, 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( 'ZLAUU2', -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 * |
|
|
103 * Compute the product U * U'. |
|
|
104 * |
|
|
105 DO 10 I = 1, N |
|
|
106 AII = A( I, I ) |
|
|
107 IF( I.LT.N ) THEN |
|
|
108 A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I, I+1 ), LDA, |
|
|
109 $ A( I, I+1 ), LDA ) ) |
|
|
110 CALL ZLACGV( N-I, A( I, I+1 ), LDA ) |
|
|
111 CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), |
|
|
112 $ LDA, A( I, I+1 ), LDA, DCMPLX( AII ), |
|
|
113 $ A( 1, I ), 1 ) |
|
|
114 CALL ZLACGV( N-I, A( I, I+1 ), LDA ) |
|
|
115 ELSE |
|
|
116 CALL ZDSCAL( I, AII, A( 1, I ), 1 ) |
|
|
117 END IF |
|
|
118 10 CONTINUE |
|
|
119 * |
|
|
120 ELSE |
|
|
121 * |
|
|
122 * Compute the product L' * L. |
|
|
123 * |
|
|
124 DO 20 I = 1, N |
|
|
125 AII = A( I, I ) |
|
|
126 IF( I.LT.N ) THEN |
|
|
127 A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I+1, I ), 1, |
|
|
128 $ A( I+1, I ), 1 ) ) |
|
|
129 CALL ZLACGV( I-1, A( I, 1 ), LDA ) |
|
|
130 CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, |
|
|
131 $ A( I+1, 1 ), LDA, A( I+1, I ), 1, |
|
|
132 $ DCMPLX( AII ), A( I, 1 ), LDA ) |
|
|
133 CALL ZLACGV( I-1, A( I, 1 ), LDA ) |
|
|
134 ELSE |
|
|
135 CALL ZDSCAL( I, AII, A( I, 1 ), LDA ) |
|
|
136 END IF |
|
|
137 20 CONTINUE |
|
|
138 END IF |
|
|
139 * |
|
|
140 RETURN |
|
|
141 * |
|
|
142 * End of ZLAUU2 |
|
|
143 * |
|
|
144 END |
