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
real function scnrm2(N, X, INCX)
SCNRM2
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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.