212 SUBROUTINE cunbdb4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
213 $ taup1, taup2, tauq1, phantom, work, lwork,
222 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
225 REAL PHI(*), THETA(*)
226 COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
227 $ work(*), x11(ldx11,*), x21(ldx21,*)
233 COMPLEX NEGONE, ONE, ZERO
234 parameter( negone = (-1.0e0,0.0e0), one = (1.0e0,0.0e0),
235 $ zero = (0.0e0,0.0e0) )
239 INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
240 $ lorbdb5, lworkmin, lworkopt
251 INTRINSIC atan2, cos, max, sin, sqrt
258 lquery = lwork .EQ. -1
262 ELSE IF( p .LT. m-q .OR. m-p .LT. m-q )
THEN
264 ELSE IF( q .LT. m-q .OR. q .GT. m )
THEN
266 ELSE IF( ldx11 .LT. max( 1, p ) )
THEN
268 ELSE IF( ldx21 .LT. max( 1, m-p ) )
THEN
274 IF( info .EQ. 0 )
THEN
276 llarf = max( q-1, p-1, m-p-1 )
279 lworkopt = ilarf + llarf - 1
280 lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 )
283 IF( lwork .LT. lworkmin .AND. .NOT.lquery )
THEN
287 IF( info .NE. 0 )
THEN
288 CALL xerbla(
'CUNBDB4', -info )
290 ELSE IF( lquery )
THEN
302 CALL cunbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,
303 $ x11, ldx11, x21, ldx21, work(iorbdb5),
304 $ lorbdb5, childinfo )
305 CALL cscal( p, negone, phantom(1), 1 )
306 CALL clarfgp( p, phantom(1), phantom(2), 1, taup1(1) )
307 CALL clarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) )
308 theta(i) = atan2(
REAL( PHANTOM(1) ),
REAL( PHANTOM(P+1) ) )
313 CALL clarf(
'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,
314 $ ldx11, work(ilarf) )
315 CALL clarf(
'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),
316 $ x21, ldx21, work(ilarf) )
318 CALL cunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,
319 $ x21(i,i-1), 1, x11(i,i), ldx11, x21(i,i),
320 $ ldx21, work(iorbdb5), lorbdb5, childinfo )
321 CALL cscal( p-i+1, negone, x11(i,i-1), 1 )
322 CALL clarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) )
323 CALL clarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,
325 theta(i) = atan2(
REAL( X11(I,I-1) ),
REAL( X21(I,I-1) ) )
330 CALL clarf(
'L', p-i+1, q-i+1, x11(i,i-1), 1,
331 $ conjg(taup1(i)), x11(i,i), ldx11, work(ilarf) )
332 CALL clarf(
'L', m-p-i+1, q-i+1, x21(i,i-1), 1,
333 $ conjg(taup2(i)), x21(i,i), ldx21, work(ilarf) )
336 CALL csrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c )
337 CALL clacgv( q-i+1, x21(i,i), ldx21 )
338 CALL clarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) )
341 CALL clarf(
'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
342 $ x11(i+1,i), ldx11, work(ilarf) )
343 CALL clarf(
'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
344 $ x21(i+1,i), ldx21, work(ilarf) )
345 CALL clacgv( q-i+1, x21(i,i), ldx21 )
346 IF( i .LT. m-q )
THEN
347 s = sqrt( scnrm2( p-i, x11(i+1,i), 1, x11(i+1,i),
348 $ 1 )**2 + scnrm2( m-p-i, x21(i+1,i), 1, x21(i+1,i),
350 phi(i) = atan2( s, c )
358 CALL clacgv( q-i+1, x11(i,i), ldx11 )
359 CALL clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
361 CALL clarf(
'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
362 $ x11(i+1,i), ldx11, work(ilarf) )
363 CALL clarf(
'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),
364 $ x21(m-q+1,i), ldx21, work(ilarf) )
365 CALL clacgv( q-i+1, x11(i,i), ldx11 )
371 CALL clacgv( q-i+1, x21(m-q+i-p,i), ldx21 )
372 CALL clarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,
375 CALL clarf(
'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),
376 $ x21(m-q+i-p+1,i), ldx21, work(ilarf) )
377 CALL clacgv( q-i+1, x21(m-q+i-p,i), ldx21 )
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine csrot(N, CX, INCX, CY, INCY, C, S)
CSROT
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cunbdb5(M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2, WORK, LWORK, INFO)
CUNBDB5
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cunbdb4(M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, INFO)
CUNBDB4
subroutine clarfgp(N, ALPHA, X, INCX, TAU)
CLARFGP generates an elementary reflector (Householder matrix) with non-negatibe beta.
subroutine clarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
CLARF applies an elementary reflector to a general rectangular matrix.