Mercurial > octave-nkf
comparison libcruft/lapack/cungl2.f @ 7789:82be108cc558
First attempt at single precision tyeps
* * *
corrections to qrupdate single precision routines
* * *
prefer demotion to single over promotion to double
* * *
Add single precision support to log2 function
* * *
Trivial PROJECT file update
* * *
Cache optimized hermitian/transpose methods
* * *
Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author | David Bateman <dbateman@free.fr> |
---|---|
date | Sun, 27 Apr 2008 22:34:17 +0200 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
7788:45f5faba05a2 | 7789:82be108cc558 |
---|---|
1 SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) | |
2 * | |
3 * -- LAPACK routine (version 3.1) -- | |
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. | |
5 * November 2006 | |
6 * | |
7 * .. Scalar Arguments .. | |
8 INTEGER INFO, K, LDA, M, N | |
9 * .. | |
10 * .. Array Arguments .. | |
11 COMPLEX A( LDA, * ), TAU( * ), WORK( * ) | |
12 * .. | |
13 * | |
14 * Purpose | |
15 * ======= | |
16 * | |
17 * CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, | |
18 * which is defined as the first m rows of a product of k elementary | |
19 * reflectors of order n | |
20 * | |
21 * Q = H(k)' . . . H(2)' H(1)' | |
22 * | |
23 * as returned by CGELQF. | |
24 * | |
25 * Arguments | |
26 * ========= | |
27 * | |
28 * M (input) INTEGER | |
29 * The number of rows of the matrix Q. M >= 0. | |
30 * | |
31 * N (input) INTEGER | |
32 * The number of columns of the matrix Q. N >= M. | |
33 * | |
34 * K (input) INTEGER | |
35 * The number of elementary reflectors whose product defines the | |
36 * matrix Q. M >= K >= 0. | |
37 * | |
38 * A (input/output) COMPLEX array, dimension (LDA,N) | |
39 * On entry, the i-th row must contain the vector which defines | |
40 * the elementary reflector H(i), for i = 1,2,...,k, as returned | |
41 * by CGELQF in the first k rows of its array argument A. | |
42 * On exit, the m by n matrix Q. | |
43 * | |
44 * LDA (input) INTEGER | |
45 * The first dimension of the array A. LDA >= max(1,M). | |
46 * | |
47 * TAU (input) COMPLEX array, dimension (K) | |
48 * TAU(i) must contain the scalar factor of the elementary | |
49 * reflector H(i), as returned by CGELQF. | |
50 * | |
51 * WORK (workspace) COMPLEX array, dimension (M) | |
52 * | |
53 * INFO (output) INTEGER | |
54 * = 0: successful exit | |
55 * < 0: if INFO = -i, the i-th argument has an illegal value | |
56 * | |
57 * ===================================================================== | |
58 * | |
59 * .. Parameters .. | |
60 COMPLEX ONE, ZERO | |
61 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), | |
62 $ ZERO = ( 0.0E+0, 0.0E+0 ) ) | |
63 * .. | |
64 * .. Local Scalars .. | |
65 INTEGER I, J, L | |
66 * .. | |
67 * .. External Subroutines .. | |
68 EXTERNAL CLACGV, CLARF, CSCAL, XERBLA | |
69 * .. | |
70 * .. Intrinsic Functions .. | |
71 INTRINSIC CONJG, MAX | |
72 * .. | |
73 * .. Executable Statements .. | |
74 * | |
75 * Test the input arguments | |
76 * | |
77 INFO = 0 | |
78 IF( M.LT.0 ) THEN | |
79 INFO = -1 | |
80 ELSE IF( N.LT.M ) THEN | |
81 INFO = -2 | |
82 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN | |
83 INFO = -3 | |
84 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN | |
85 INFO = -5 | |
86 END IF | |
87 IF( INFO.NE.0 ) THEN | |
88 CALL XERBLA( 'CUNGL2', -INFO ) | |
89 RETURN | |
90 END IF | |
91 * | |
92 * Quick return if possible | |
93 * | |
94 IF( M.LE.0 ) | |
95 $ RETURN | |
96 * | |
97 IF( K.LT.M ) THEN | |
98 * | |
99 * Initialise rows k+1:m to rows of the unit matrix | |
100 * | |
101 DO 20 J = 1, N | |
102 DO 10 L = K + 1, M | |
103 A( L, J ) = ZERO | |
104 10 CONTINUE | |
105 IF( J.GT.K .AND. J.LE.M ) | |
106 $ A( J, J ) = ONE | |
107 20 CONTINUE | |
108 END IF | |
109 * | |
110 DO 40 I = K, 1, -1 | |
111 * | |
112 * Apply H(i)' to A(i:m,i:n) from the right | |
113 * | |
114 IF( I.LT.N ) THEN | |
115 CALL CLACGV( N-I, A( I, I+1 ), LDA ) | |
116 IF( I.LT.M ) THEN | |
117 A( I, I ) = ONE | |
118 CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, | |
119 $ CONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) | |
120 END IF | |
121 CALL CSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) | |
122 CALL CLACGV( N-I, A( I, I+1 ), LDA ) | |
123 END IF | |
124 A( I, I ) = ONE - CONJG( TAU( I ) ) | |
125 * | |
126 * Set A(i,1:i-1,i) to zero | |
127 * | |
128 DO 30 L = 1, I - 1 | |
129 A( I, L ) = ZERO | |
130 30 CONTINUE | |
131 40 CONTINUE | |
132 RETURN | |
133 * | |
134 * End of CUNGL2 | |
135 * | |
136 END |