SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LREAL, LTRAN
INTEGER INFO, LDT, N
DOUBLE PRECISION SCALE, W
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLAQTR solves the real quasi-triangular system
*
* op(T)*p = scale*c, if LREAL = .TRUE.
*
* or the complex quasi-triangular systems
*
* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
*
* in real arithmetic, where T is upper quasi-triangular.
* If LREAL = .FALSE., then the first diagonal block of T must be
* 1 by 1, B is the specially structured matrix
*
* B = [ b(1) b(2) ... b(n) ]
* [ w ]
* [ w ]
* [ . ]
* [ w ]
*
* op(A) = A or A', A' denotes the conjugate transpose of
* matrix A.
*
* On input, X = [ c ]. On output, X = [ p ].
* [ d ] [ q ]
*
* This subroutine is designed for the condition number estimation
* in routine DTRSNA.
*
* Arguments
* =========
*
* LTRAN (input) LOGICAL
* On entry, LTRAN specifies the option of conjugate transpose:
* = .FALSE., op(T+i*B) = T+i*B,
* = .TRUE., op(T+i*B) = (T+i*B)'.
*
* LREAL (input) LOGICAL
* On entry, LREAL specifies the input matrix structure:
* = .FALSE., the input is complex
* = .TRUE., the input is real
*
* N (input) INTEGER
* On entry, N specifies the order of T+i*B. N >= 0.
*
* T (input) DOUBLE PRECISION array, dimension (LDT,N)
* On entry, T contains a matrix in Schur canonical form.
* If LREAL = .FALSE., then the first diagonal block of T mu
* be 1 by 1.
*
* LDT (input) INTEGER
* The leading dimension of the matrix T. LDT >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (N)
* On entry, B contains the elements to form the matrix
* B as described above.
* If LREAL = .TRUE., B is not referenced.
*
* W (input) DOUBLE PRECISION
* On entry, W is the diagonal element of the matrix B.
* If LREAL = .TRUE., W is not referenced.
*
* SCALE (output) DOUBLE PRECISION
* On exit, SCALE is the scale factor.
*
* X (input/output) DOUBLE PRECISION array, dimension (2*N)
* On entry, X contains the right hand side of the system.
* On exit, X is overwritten by the solution.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* On exit, INFO is set to
* 0: successful exit.
* 1: the some diagonal 1 by 1 block has been perturbed by
* a small number SMIN to keep nonsingularity.
* 2: the some diagonal 2 by 2 block has been perturbed by
* a small number in DLALN2 to keep nonsingularity.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
$ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
* ..
* .. Local Arrays ..
DOUBLE PRECISION D( 2, 2 ), V( 2, 2 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLADIV, DLALN2, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Do not test the input parameters for errors
*
NOTRAN = .NOT.LTRAN
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
XNORM = DLANGE( 'M', N, N, T, LDT, D )
IF( .NOT.LREAL )
$ XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) )
SMIN = MAX( SMLNUM, EPS*XNORM )
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 10 J = 2, N
WORK( J ) = DASUM( J-1, T( 1, J ), 1 )
10 CONTINUE
*
IF( .NOT.LREAL ) THEN
DO 20 I = 2, N
WORK( I ) = WORK( I ) + ABS( B( I ) )
20 CONTINUE
END IF
*
N2 = 2*N
N1 = N
IF( .NOT.LREAL )
$ N1 = N2
K = IDAMAX( N1, X, 1 )
XMAX = ABS( X( K ) )
SCALE = ONE
*
IF( XMAX.GT.BIGNUM ) THEN
SCALE = BIGNUM / XMAX
CALL DSCAL( N1, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( LREAL ) THEN
*
IF( NOTRAN ) THEN
*
* Solve T*p = scale*c
*
JNEXT = N
DO 30 J = N, 1, -1
IF( J.GT.JNEXT )
$ GO TO 30
J1 = J
J2 = J
JNEXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNEXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* Meet 1 by 1 diagonal block
*
* Scale to avoid overflow when computing
* x(j) = b(j)/T(j,j)
*
XJ = ABS( X( J1 ) )
TJJ = ABS( T( J1, J1 ) )
TMP = T( J1, J1 )
IF( TJJ.LT.SMIN ) THEN
TMP = SMIN
TJJ = SMIN
INFO = 1
END IF
*
IF( XJ.EQ.ZERO )
$ GO TO 30
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J1 ) = X( J1 ) / TMP
XJ = ABS( X( J1 ) )
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j1 of T.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
K = IDAMAX( J1-1, X, 1 )
XMAX = ABS( X( K ) )
END IF
*
ELSE
*
* Meet 2 by 2 diagonal block
*
* Call 2 by 2 linear system solve, to take
* care of possible overflow by scaling factor.
*
D( 1, 1 ) = X( J1 )
D( 2, 1 ) = X( J2 )
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( N, SCALOC, X, 1 )
SCALE = SCALE*SCALOC
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
*
* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
* to avoid overflow in updating right-hand side.
*
XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
* Update right-hand side
*
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
K = IDAMAX( J1-1, X, 1 )
XMAX = ABS( X( K ) )
END IF
*
END IF
*
30 CONTINUE
*
ELSE
*
* Solve T'*p = scale*c
*
JNEXT = 1
DO 40 J = 1, N
IF( J.LT.JNEXT )
$ GO TO 40
J1 = J
J2 = J
JNEXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNEXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = ABS( X( J1 ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
*
XJ = ABS( X( J1 ) )
TJJ = ABS( T( J1, J1 ) )
TMP = T( J1, J1 )
IF( TJJ.LT.SMIN ) THEN
TMP = SMIN
TJJ = SMIN
INFO = 1
END IF
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J1 ) = X( J1 ) / TMP
XMAX = MAX( XMAX, ABS( X( J1 ) ) )
*
ELSE
*
* 2 by 2 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side elements by inner product.
*
XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
$ REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
$ 1 )
D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
$ 1 )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( N, SCALOC, X, 1 )
SCALE = SCALE*SCALOC
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
*
END IF
40 CONTINUE
END IF
*
ELSE
*
SMINW = MAX( EPS*ABS( W ), SMIN )
IF( NOTRAN ) THEN
*
* Solve (T + iB)*(p+iq) = c+id
*
JNEXT = N
DO 70 J = N, 1, -1
IF( J.GT.JNEXT )
$ GO TO 70
J1 = J
J2 = J
JNEXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNEXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in division
*
Z = W
IF( J1.EQ.1 )
$ Z = B( 1 )
XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
TMP = T( J1, J1 )
IF( TJJ.LT.SMINW ) THEN
TMP = SMINW
TJJ = SMINW
INFO = 1
END IF
*
IF( XJ.EQ.ZERO )
$ GO TO 70
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
X( J1 ) = SR
X( N+J1 ) = SI
XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j1 of T.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
$ X( N+1 ), 1 )
*
X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
*
XMAX = ZERO
DO 50 K = 1, J1 - 1
XMAX = MAX( XMAX, ABS( X( K ) )+
$ ABS( X( K+N ) ) )
50 CONTINUE
END IF
*
ELSE
*
* Meet 2 by 2 diagonal block
*
D( 1, 1 ) = X( J1 )
D( 2, 1 ) = X( J2 )
D( 1, 2 ) = X( N+J1 )
D( 2, 2 ) = X( N+J2 )
CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( 2*N, SCALOC, X, 1 )
SCALE = SCALOC*SCALE
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
X( N+J1 ) = V( 1, 2 )
X( N+J2 ) = V( 2, 2 )
*
* Scale X(J1), .... to avoid overflow in
* updating right hand side.
*
XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
$ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
* Update the right-hand side.
*
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
*
CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
$ X( N+1 ), 1 )
CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
$ X( N+1 ), 1 )
*
X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
$ B( J2 )*X( N+J2 )
X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
$ B( J2 )*X( J2 )
*
XMAX = ZERO
DO 60 K = 1, J1 - 1
XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
$ XMAX )
60 CONTINUE
END IF
*
END IF
70 CONTINUE
*
ELSE
*
* Solve (T + iB)'*(p+iq) = c+id
*
JNEXT = 1
DO 80 J = 1, N
IF( J.LT.JNEXT )
$ GO TO 80
J1 = J
J2 = J
JNEXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNEXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
$ X( N+1 ), 1 )
IF( J1.GT.1 ) THEN
X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
END IF
XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
*
Z = W
IF( J1.EQ.1 )
$ Z = B( 1 )
*
* Scale if necessary to avoid overflow in
* complex division
*
TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
TMP = T( J1, J1 )
IF( TJJ.LT.SMINW ) THEN
TMP = SMINW
TJJ = SMINW
INFO = 1
END IF
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
X( J1 ) = SR
X( J1+N ) = SI
XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
*
ELSE
*
* 2 by 2 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
$ ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XJ ) / XMAX ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
$ 1 )
D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
$ 1 )
D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
$ X( N+1 ), 1 )
D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1,
$ X( N+1 ), 1 )
D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
*
CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( N2, SCALOC, X, 1 )
SCALE = SCALOC*SCALE
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
X( N+J1 ) = V( 1, 2 )
X( N+J2 ) = V( 2, 2 )
XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
$ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
*
END IF
*
80 CONTINUE
*
END IF
*
END IF
*
RETURN
*
* End of DLAQTR
*
END