Mercurial > octave

comparison libcruft/lapack/sorm2r.f @ 7789:82be108cc558

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
2 $ WORK, INFO )
3 *
4 * -- LAPACK routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 CHARACTER SIDE, TRANS
10 INTEGER INFO, K, LDA, LDC, M, N
11 * ..
12 * .. Array Arguments ..
13 REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
14 * ..
15 *
16 * Purpose
17 * =======
18 *
19 * SORM2R overwrites the general real m by n matrix C with
20 *
21 * Q * C if SIDE = 'L' and TRANS = 'N', or
22 *
23 * Q'* C if SIDE = 'L' and TRANS = 'T', or
24 *
25 * C * Q if SIDE = 'R' and TRANS = 'N', or
26 *
27 * C * Q' if SIDE = 'R' and TRANS = 'T',
28 *
29 * where Q is a real orthogonal matrix defined as the product of k
30 * elementary reflectors
31 *
32 * Q = H(1) H(2) . . . H(k)
33 *
34 * as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n
35 * if SIDE = 'R'.
36 *
37 * Arguments
38 * =========
39 *
40 * SIDE (input) CHARACTER*1
41 * = 'L': apply Q or Q' from the Left
42 * = 'R': apply Q or Q' from the Right
43 *
44 * TRANS (input) CHARACTER*1
45 * = 'N': apply Q (No transpose)
46 * = 'T': apply Q' (Transpose)
47 *
48 * M (input) INTEGER
49 * The number of rows of the matrix C. M >= 0.
50 *
51 * N (input) INTEGER
52 * The number of columns of the matrix C. N >= 0.
53 *
54 * K (input) INTEGER
55 * The number of elementary reflectors whose product defines
56 * the matrix Q.
57 * If SIDE = 'L', M >= K >= 0;
58 * if SIDE = 'R', N >= K >= 0.
59 *
60 * A (input) REAL array, dimension (LDA,K)
61 * The i-th column must contain the vector which defines the
62 * elementary reflector H(i), for i = 1,2,...,k, as returned by
63 * SGEQRF in the first k columns of its array argument A.
64 * A is modified by the routine but restored on exit.
65 *
66 * LDA (input) INTEGER
67 * The leading dimension of the array A.
68 * If SIDE = 'L', LDA >= max(1,M);
69 * if SIDE = 'R', LDA >= max(1,N).
70 *
71 * TAU (input) REAL array, dimension (K)
72 * TAU(i) must contain the scalar factor of the elementary
73 * reflector H(i), as returned by SGEQRF.
74 *
75 * C (input/output) REAL array, dimension (LDC,N)
76 * On entry, the m by n matrix C.
77 * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
78 *
79 * LDC (input) INTEGER
80 * The leading dimension of the array C. LDC >= max(1,M).
81 *
82 * WORK (workspace) REAL array, dimension
83 * (N) if SIDE = 'L',
84 * (M) if SIDE = 'R'
85 *
86 * INFO (output) INTEGER
87 * = 0: successful exit
88 * < 0: if INFO = -i, the i-th argument had an illegal value
89 *
90 * =====================================================================
91 *
92 * .. Parameters ..
93 REAL ONE
94 PARAMETER ( ONE = 1.0E+0 )
95 * ..
96 * .. Local Scalars ..
97 LOGICAL LEFT, NOTRAN
98 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
99 REAL AII
100 * ..
101 * .. External Functions ..
102 LOGICAL LSAME
103 EXTERNAL LSAME
104 * ..
105 * .. External Subroutines ..
106 EXTERNAL SLARF, XERBLA
107 * ..
108 * .. Intrinsic Functions ..
109 INTRINSIC MAX
110 * ..
111 * .. Executable Statements ..
112 *
113 * Test the input arguments
114 *
115 INFO = 0
116 LEFT = LSAME( SIDE, 'L' )
117 NOTRAN = LSAME( TRANS, 'N' )
118 *
119 * NQ is the order of Q
120 *
121 IF( LEFT ) THEN
122 NQ = M
123 ELSE
124 NQ = N
125 END IF
126 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
127 INFO = -1
128 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
129 INFO = -2
130 ELSE IF( M.LT.0 ) THEN
131 INFO = -3
132 ELSE IF( N.LT.0 ) THEN
133 INFO = -4
134 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
135 INFO = -5
136 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
137 INFO = -7
138 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
139 INFO = -10
140 END IF
141 IF( INFO.NE.0 ) THEN
142 CALL XERBLA( 'SORM2R', -INFO )
143 RETURN
144 END IF
145 *
146 * Quick return if possible
147 *
148 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
149 $ RETURN
150 *
151 IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
152 $ THEN
153 I1 = 1
154 I2 = K
155 I3 = 1
156 ELSE
157 I1 = K
158 I2 = 1
159 I3 = -1
160 END IF
161 *
162 IF( LEFT ) THEN
163 NI = N
164 JC = 1
165 ELSE
166 MI = M
167 IC = 1
168 END IF
169 *
170 DO 10 I = I1, I2, I3
171 IF( LEFT ) THEN
172 *
173 * H(i) is applied to C(i:m,1:n)
174 *
175 MI = M - I + 1
176 IC = I
177 ELSE
178 *
179 * H(i) is applied to C(1:m,i:n)
180 *
181 NI = N - I + 1
182 JC = I
183 END IF
184 *
185 * Apply H(i)
186 *
187 AII = A( I, I )
188 A( I, I ) = ONE
189 CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
190 $ LDC, WORK )
191 A( I, I ) = AII
192 10 CONTINUE
193 RETURN
194 *
195 * End of SORM2R
196 *
197 END