LAPACK  3.10.1 LAPACK: Linear Algebra PACKage

## ◆ dorbdb6()

 subroutine dorbdb6 ( integer M1, integer M2, integer N, double precision, dimension(*) X1, integer INCX1, double precision, dimension(*) X2, integer INCX2, double precision, dimension(ldq1,*) Q1, integer LDQ1, double precision, dimension(ldq2,*) Q2, integer LDQ2, double precision, dimension(*) WORK, integer LWORK, integer INFO )

DORBDB6

Purpose:
``` DORBDB6 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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.```

Definition at line 152 of file dorbdb6.f.

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