LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine cunbdb6 ( integer M1, integer M2, integer N, complex, dimension(*) X1, integer INCX1, complex, dimension(*) X2, integer INCX2, complex, dimension(ldq1,*) Q1, integer LDQ1, complex, dimension(ldq2,*) Q2, integer LDQ2, complex, dimension(*) WORK, integer LWORK, integer INFO )

CUNBDB6

# Purpose:

``` CUNBDB6 orthogonalizes the column vector
X = [ X1 ]
[ X2 ]
with respect to the columns of
Q = [ Q1 ] .
[ Q2 ]
The columns of Q must be orthonormal.

If the projection is zero according to Kahan's "twice is enough"
criterion, then the zero vector is returned.```
Parameters
 [in] M1 ``` M1 is INTEGER The dimension of X1 and the number of rows in Q1. 0 <= M1.``` [in] M2 ``` M2 is INTEGER The dimension of X2 and the number of rows in Q2. 0 <= M2.``` [in] N ``` N is INTEGER The number of columns in Q1 and Q2. 0 <= N.``` [in,out] X1 ``` X1 is COMPLEX array, dimension (M1) On entry, the top part of the vector to be orthogonalized. On exit, the top part of the projected vector.``` [in] INCX1 ``` INCX1 is INTEGER Increment for entries of X1.``` [in,out] X2 ``` X2 is COMPLEX array, dimension (M2) On entry, the bottom part of the vector to be orthogonalized. On exit, the bottom part of the projected vector.``` [in] INCX2 ``` INCX2 is INTEGER Increment for entries of X2.``` [in] Q1 ``` Q1 is COMPLEX array, dimension (LDQ1, N) The top part of the orthonormal basis matrix.``` [in] LDQ1 ``` LDQ1 is INTEGER The leading dimension of Q1. LDQ1 >= M1.``` [in] Q2 ``` Q2 is COMPLEX array, dimension (LDQ2, N) The bottom part of the orthonormal basis matrix.``` [in] LDQ2 ``` LDQ2 is INTEGER The leading dimension of Q2. LDQ2 >= M2.``` [out] WORK ` WORK is COMPLEX array, dimension (LWORK)` [in] LWORK ``` LWORK is INTEGER The dimension of the array WORK. LWORK >= N.``` [out] INFO ``` INFO is INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value.```
Date
July 2012

Definition at line 156 of file cunbdb6.f.

156 *
157 * -- LAPACK computational routine (version 3.5.0) --
158 * -- LAPACK is a software package provided by Univ. of Tennessee, --
159 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160 * July 2012
161 *
162 * .. Scalar Arguments ..
163  INTEGER incx1, incx2, info, ldq1, ldq2, lwork, m1, m2,
164  \$ n
165 * ..
166 * .. Array Arguments ..
167  COMPLEX q1(ldq1,*), q2(ldq2,*), work(*), x1(*), x2(*)
168 * ..
169 *
170 * =====================================================================
171 *
172 * .. Parameters ..
173  REAL alphasq, realone, realzero
174  parameter ( alphasq = 0.01e0, realone = 1.0e0,
175  \$ realzero = 0.0e0 )
176  COMPLEX negone, one, zero
177  parameter ( negone = (-1.0e0,0.0e0), one = (1.0e0,0.0e0),
178  \$ zero = (0.0e0,0.0e0) )
179 * ..
180 * .. Local Scalars ..
181  INTEGER i
182  REAL normsq1, normsq2, scl1, scl2, ssq1, ssq2
183 * ..
184 * .. External Subroutines ..
185  EXTERNAL cgemv, classq, xerbla
186 * ..
187 * .. Intrinsic Function ..
188  INTRINSIC max
189 * ..
190 * .. Executable Statements ..
191 *
192 * Test input arguments
193 *
194  info = 0
195  IF( m1 .LT. 0 ) THEN
196  info = -1
197  ELSE IF( m2 .LT. 0 ) THEN
198  info = -2
199  ELSE IF( n .LT. 0 ) THEN
200  info = -3
201  ELSE IF( incx1 .LT. 1 ) THEN
202  info = -5
203  ELSE IF( incx2 .LT. 1 ) THEN
204  info = -7
205  ELSE IF( ldq1 .LT. max( 1, m1 ) ) THEN
206  info = -9
207  ELSE IF( ldq2 .LT. max( 1, m2 ) ) THEN
208  info = -11
209  ELSE IF( lwork .LT. n ) THEN
210  info = -13
211  END IF
212 *
213  IF( info .NE. 0 ) THEN
214  CALL xerbla( 'CUNBDB6', -info )
215  RETURN
216  END IF
217 *
218 * First, project X onto the orthogonal complement of Q's column
219 * space
220 *
221  scl1 = realzero
222  ssq1 = realone
223  CALL classq( m1, x1, incx1, scl1, ssq1 )
224  scl2 = realzero
225  ssq2 = realone
226  CALL classq( m2, x2, incx2, scl2, ssq2 )
227  normsq1 = scl1**2*ssq1 + scl2**2*ssq2
228 *
229  IF( m1 .EQ. 0 ) THEN
230  DO i = 1, n
231  work(i) = zero
232  END DO
233  ELSE
234  CALL cgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
235  \$ 1 )
236  END IF
237 *
238  CALL cgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
239 *
240  CALL cgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
241  \$ incx1 )
242  CALL cgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
243  \$ incx2 )
244 *
245  scl1 = realzero
246  ssq1 = realone
247  CALL classq( m1, x1, incx1, scl1, ssq1 )
248  scl2 = realzero
249  ssq2 = realone
250  CALL classq( m2, x2, incx2, scl2, ssq2 )
251  normsq2 = scl1**2*ssq1 + scl2**2*ssq2
252 *
253 * If projection is sufficiently large in norm, then stop.
254 * If projection is zero, then stop.
255 * Otherwise, project again.
256 *
257  IF( normsq2 .GE. alphasq*normsq1 ) THEN
258  RETURN
259  END IF
260 *
261  IF( normsq2 .EQ. zero ) THEN
262  RETURN
263  END IF
264 *
265  normsq1 = normsq2
266 *
267  DO i = 1, n
268  work(i) = zero
269  END DO
270 *
271  IF( m1 .EQ. 0 ) THEN
272  DO i = 1, n
273  work(i) = zero
274  END DO
275  ELSE
276  CALL cgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
277  \$ 1 )
278  END IF
279 *
280  CALL cgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
281 *
282  CALL cgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
283  \$ incx1 )
284  CALL cgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
285  \$ incx2 )
286 *
287  scl1 = realzero
288  ssq1 = realone
289  CALL classq( m1, x1, incx1, scl1, ssq1 )
290  scl2 = realzero
291  ssq2 = realone
292  CALL classq( m1, x1, incx1, scl1, ssq1 )
293  normsq2 = scl1**2*ssq1 + scl2**2*ssq2
294 *
295 * If second projection is sufficiently large in norm, then do
296 * nothing more. Alternatively, if it shrunk significantly, then
297 * truncate it to zero.
298 *
299  IF( normsq2 .LT. alphasq*normsq1 ) THEN
300  DO i = 1, m1
301  x1(i) = zero
302  END DO
303  DO i = 1, m2
304  x2(i) = zero
305  END DO
306  END IF
307 *
308  RETURN
309 *
310 * End of CUNBDB6
311 *
subroutine classq(N, X, INCX, SCALE, SUMSQ)
CLASSQ updates a sum of squares represented in scaled form.
Definition: classq.f:108
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
Definition: cgemv.f:160

Here is the call graph for this function:

Here is the caller graph for this function: