Mercurial > octave-nkf
comparison libcruft/lapack/zlauu2.f @ 5340:15843d76156d
[project @ 2005-05-06 16:26:58 by jwe]
author | jwe |
---|---|
date | Fri, 06 May 2005 16:26:59 +0000 |
parents | |
children | 68db500cb558 |
comparison
equal
deleted
inserted
replaced
5339:4266ef7972b2 | 5340:15843d76156d |
---|---|
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 |