197 SUBROUTINE zunbdb2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
199 $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
206 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
209 DOUBLE PRECISION PHI(*), THETA(*)
210 COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
211 $ x11(ldx11,*), x21(ldx21,*)
217 COMPLEX*16 NEGONE, ONE
218 PARAMETER ( NEGONE = (-1.0d0,0.0d0),
219 $ one = (1.0d0,0.0d0) )
222 DOUBLE PRECISION C, S
223 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
233 DOUBLE PRECISION DZNRM2
237 INTRINSIC atan2, cos, max, sin, sqrt
244 lquery = lwork .EQ. -1
248 ELSE IF( p .LT. 0 .OR. p .GT. m-p )
THEN
250 ELSE IF( q .LT. 0 .OR. q .LT. p .OR. m-q .LT. p )
THEN
252 ELSE IF( ldx11 .LT. max( 1, p ) )
THEN
254 ELSE IF( ldx21 .LT. max( 1, m-p ) )
THEN
260 IF( info .EQ. 0 )
THEN
262 llarf = max( p-1, m-p, q-1 )
265 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 )
268 IF( lwork .LT. lworkmin .AND. .NOT.lquery )
THEN
272 IF( info .NE. 0 )
THEN
273 CALL xerbla(
'ZUNBDB2', -info )
275 ELSE IF( lquery )
THEN
284 CALL zdrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,
287 CALL zlacgv( q-i+1, x11(i,i), ldx11 )
288 CALL zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
290 CALL zlarf1f(
'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
291 $ x11(i+1,i), ldx11, work(ilarf) )
292 CALL zlarf1f(
'R', m-p-i+1, q-i+1, x11(i,i), ldx11,
293 $ tauq1(i), x21(i,i), ldx21, work(ilarf) )
294 CALL zlacgv( q-i+1, x11(i,i), ldx11 )
295 s = sqrt( dznrm2( p-i, x11(i+1,i), 1 )**2
296 $ + dznrm2( m-p-i+1, x21(i,i), 1 )**2 )
297 theta(i) = atan2( s, c )
299 CALL zunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,
300 $ x11(i+1,i+1), ldx11, x21(i,i+1), ldx21,
301 $ work(iorbdb5), lorbdb5, childinfo )
302 CALL zscal( p-i, negone, x11(i+1,i), 1 )
303 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
305 CALL zlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) )
306 phi(i) = atan2( dble( x11(i+1,i) ), dble( x21(i,i) ) )
309 CALL zlarf1f(
'L', p-i, q-i, x11(i+1,i), 1,
311 $ x11(i+1,i+1), ldx11, work(ilarf) )
313 CALL zlarf1f(
'L', m-p-i+1, q-i, x21(i,i), 1,
314 $ conjg(taup2(i)), x21(i,i+1), ldx21,
322 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
323 CALL zlarf1f(
'L', m-p-i+1, q-i, x21(i,i), 1,
324 $ conjg(taup2(i)), x21(i,i+1), ldx21,