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